From 0f6e79f918d930ce766c9f2d424204b397cb7314 Mon Sep 17 00:00:00 2001 From: Zhang Xianyi Date: Mon, 9 Dec 2013 16:50:02 +0800 Subject: [PATCH] Refs #324. Upgrade LAPACK to 3.5.0 version. --- exports/gensymbol | 3974 +++++++++-------- lapack-netlib/CMakeLists.txt | 3 +- lapack-netlib/DOCS/Doxyfile | 2 +- lapack-netlib/DOCS/psfig.tex | 391 -- lapack-netlib/INSTALL/dlamch.f | 4 + lapack-netlib/INSTALL/ilaver.f | 8 +- lapack-netlib/INSTALL/make.inc.ALPHA | 4 +- lapack-netlib/INSTALL/make.inc.HPPA | 4 +- lapack-netlib/INSTALL/make.inc.IRIX64 | 4 +- lapack-netlib/INSTALL/make.inc.O2K | 4 +- lapack-netlib/INSTALL/make.inc.SGI5 | 4 +- lapack-netlib/INSTALL/make.inc.SUN4 | 4 +- lapack-netlib/INSTALL/make.inc.SUN4SOL2 | 4 +- lapack-netlib/INSTALL/make.inc.XLF | 4 +- lapack-netlib/INSTALL/make.inc.gfortran | 8 +- lapack-netlib/INSTALL/make.inc.gfortran_debug | 8 +- lapack-netlib/INSTALL/make.inc.ifort | 4 +- lapack-netlib/INSTALL/make.inc.pgf95 | 4 +- lapack-netlib/INSTALL/make.inc.pghpf | 4 +- lapack-netlib/README | 5 +- lapack-netlib/SRC/CMakeLists.txt | 42 +- lapack-netlib/SRC/Makefile | 40 +- lapack-netlib/SRC/cbbcsd.f | 11 +- lapack-netlib/SRC/cgebal.f | 22 +- lapack-netlib/SRC/cgemqrt.f | 8 +- lapack-netlib/SRC/cgeqrt.f | 8 +- lapack-netlib/SRC/cgetc2.f | 12 +- lapack-netlib/SRC/checon_rook.f | 253 ++ lapack-netlib/SRC/chesv_rook.f | 295 ++ lapack-netlib/SRC/chetf2.f | 43 +- lapack-netlib/SRC/chetf2_rook.f | 910 ++++ lapack-netlib/SRC/chetrf_rook.f | 397 ++ lapack-netlib/SRC/chetri_rook.f | 516 +++ lapack-netlib/SRC/chetrs_rook.f | 503 +++ lapack-netlib/SRC/chsein.f | 16 +- lapack-netlib/SRC/chseqr.f | 8 +- lapack-netlib/SRC/cla_lin_berr.f | 10 +- lapack-netlib/SRC/clahef.f | 421 +- lapack-netlib/SRC/clahef_rook.f | 1176 +++++ lapack-netlib/SRC/clarfb.f | 279 +- lapack-netlib/SRC/clartg.f | 30 +- lapack-netlib/SRC/clasyf.f | 312 +- lapack-netlib/SRC/clasyf_rook.f | 900 ++++ lapack-netlib/SRC/cstemr.f | 7 +- lapack-netlib/SRC/csycon_rook.f | 255 ++ lapack-netlib/SRC/csysv_rook.f | 293 ++ lapack-netlib/SRC/csytf2.f | 41 +- lapack-netlib/SRC/csytf2_rook.f | 821 ++++ lapack-netlib/SRC/csytrf_rook.f | 393 ++ lapack-netlib/SRC/csytri_rook.f | 451 ++ lapack-netlib/SRC/csytrs_rook.f | 484 ++ lapack-netlib/SRC/ctpmqrt.f | 22 +- lapack-netlib/SRC/ctpqrt.f | 10 +- lapack-netlib/SRC/cunbdb.f | 121 +- lapack-netlib/SRC/cunbdb1.f | 327 ++ lapack-netlib/SRC/cunbdb2.f | 337 ++ lapack-netlib/SRC/cunbdb3.f | 336 ++ lapack-netlib/SRC/cunbdb4.f | 385 ++ lapack-netlib/SRC/cunbdb5.f | 274 ++ lapack-netlib/SRC/cunbdb6.f | 313 ++ lapack-netlib/SRC/cuncsd.f | 62 +- lapack-netlib/SRC/cuncsd2by1.f | 757 ++++ lapack-netlib/SRC/dbbcsd.f | 31 +- lapack-netlib/SRC/dgebal.f | 23 +- lapack-netlib/SRC/dgemqrt.f | 8 +- lapack-netlib/SRC/dgeqrt.f | 8 +- lapack-netlib/SRC/dgesdd.f | 9 +- lapack-netlib/SRC/dgetc2.f | 11 +- lapack-netlib/SRC/dhgeqz.f | 20 +- lapack-netlib/SRC/dhsein.f | 16 +- lapack-netlib/SRC/dladiv.f | 157 +- lapack-netlib/SRC/dlaqp2.f | 8 +- lapack-netlib/SRC/dlarfb.f | 298 +- lapack-netlib/SRC/dlasd4.f | 6 +- lapack-netlib/SRC/dlasyf.f | 312 +- lapack-netlib/SRC/dlasyf_rook.f | 892 ++++ lapack-netlib/SRC/dorbdb.f | 176 +- lapack-netlib/SRC/dorbdb1.f | 324 ++ lapack-netlib/SRC/dorbdb2.f | 333 ++ lapack-netlib/SRC/dorbdb3.f | 332 ++ lapack-netlib/SRC/dorbdb4.f | 378 ++ lapack-netlib/SRC/dorbdb5.f | 274 ++ lapack-netlib/SRC/dorbdb6.f | 312 ++ lapack-netlib/SRC/dorcsd.f | 52 +- lapack-netlib/SRC/dorcsd2by1.f | 715 +++ lapack-netlib/SRC/dstemr.f | 7 +- lapack-netlib/SRC/dsycon_rook.f | 258 ++ lapack-netlib/SRC/dsysv_rook.f | 293 ++ lapack-netlib/SRC/dsytf2.f | 41 +- lapack-netlib/SRC/dsytf2_rook.f | 813 ++++ lapack-netlib/SRC/dsytrf_rook.f | 393 ++ lapack-netlib/SRC/dsytri_rook.f | 450 ++ lapack-netlib/SRC/dsytrs_rook.f | 484 ++ lapack-netlib/SRC/dtpmqrt.f | 22 +- lapack-netlib/SRC/dtpqrt.f | 10 +- lapack-netlib/SRC/ilaver.f | 8 +- lapack-netlib/SRC/sbbcsd.f | 31 +- lapack-netlib/SRC/sgebal.f | 22 +- lapack-netlib/SRC/sgemqrt.f | 8 +- lapack-netlib/SRC/sgeqrt.f | 8 +- lapack-netlib/SRC/sgesdd.f | 9 +- lapack-netlib/SRC/sgetc2.f | 11 +- lapack-netlib/SRC/shgeqz.f | 20 +- lapack-netlib/SRC/shsein.f | 16 +- lapack-netlib/SRC/sladiv.f | 157 +- lapack-netlib/SRC/slarfb.f | 296 +- lapack-netlib/SRC/slasd4.f | 6 +- lapack-netlib/SRC/slasyf.f | 312 +- lapack-netlib/SRC/slasyf_rook.f | 892 ++++ lapack-netlib/SRC/sorbdb.f | 182 +- lapack-netlib/SRC/sorbdb1.f | 324 ++ lapack-netlib/SRC/sorbdb2.f | 332 ++ lapack-netlib/SRC/sorbdb3.f | 333 ++ lapack-netlib/SRC/sorbdb4.f | 379 ++ lapack-netlib/SRC/sorbdb5.f | 274 ++ lapack-netlib/SRC/sorbdb6.f | 312 ++ lapack-netlib/SRC/sorcsd.f | 25 +- lapack-netlib/SRC/sorcsd2by1.f | 711 +++ lapack-netlib/SRC/sstemr.f | 7 +- lapack-netlib/SRC/ssycon_rook.f | 258 ++ lapack-netlib/SRC/ssysv_rook.f | 293 ++ lapack-netlib/SRC/ssytf2.f | 41 +- lapack-netlib/SRC/ssytf2_rook.f | 813 ++++ lapack-netlib/SRC/ssytrf_rook.f | 393 ++ lapack-netlib/SRC/ssytri_rook.f | 450 ++ lapack-netlib/SRC/ssytrs_rook.f | 484 ++ lapack-netlib/SRC/stpmqrt.f | 22 +- lapack-netlib/SRC/stpqrt.f | 10 +- lapack-netlib/SRC/zbbcsd.f | 11 +- lapack-netlib/SRC/zgebal.f | 22 +- lapack-netlib/SRC/zgemqrt.f | 8 +- lapack-netlib/SRC/zgeqrt.f | 8 +- lapack-netlib/SRC/zgetc2.f | 12 +- lapack-netlib/SRC/zhecon_rook.f | 253 ++ lapack-netlib/SRC/zhesv_rook.f | 295 ++ lapack-netlib/SRC/zhetf2.f | 97 +- lapack-netlib/SRC/zhetf2_rook.f | 910 ++++ lapack-netlib/SRC/zhetrf_rook.f | 397 ++ lapack-netlib/SRC/zhetri_rook.f | 516 +++ lapack-netlib/SRC/zhetrs_rook.f | 503 +++ lapack-netlib/SRC/zhsein.f | 16 +- lapack-netlib/SRC/zhseqr.f | 8 +- lapack-netlib/SRC/zlahef.f | 390 +- lapack-netlib/SRC/zlahef_rook.f | 1176 +++++ lapack-netlib/SRC/zlarfb.f | 282 +- lapack-netlib/SRC/zlartg.f | 30 +- lapack-netlib/SRC/zlasyf.f | 310 +- lapack-netlib/SRC/zlasyf_rook.f | 900 ++++ lapack-netlib/SRC/zstemr.f | 9 +- lapack-netlib/SRC/zsycon_rook.f | 255 ++ lapack-netlib/SRC/zsysv_rook.f | 293 ++ lapack-netlib/SRC/zsytf2.f | 41 +- lapack-netlib/SRC/zsytf2_rook.f | 821 ++++ lapack-netlib/SRC/zsytrf_rook.f | 393 ++ lapack-netlib/SRC/zsytri_rook.f | 451 ++ lapack-netlib/SRC/zsytrs_rook.f | 484 ++ lapack-netlib/SRC/ztpmqrt.f | 22 +- lapack-netlib/SRC/ztpqrt.f | 10 +- lapack-netlib/SRC/zunbdb.f | 120 +- lapack-netlib/SRC/zunbdb1.f | 328 ++ lapack-netlib/SRC/zunbdb2.f | 336 ++ lapack-netlib/SRC/zunbdb3.f | 336 ++ lapack-netlib/SRC/zunbdb4.f | 385 ++ lapack-netlib/SRC/zunbdb5.f | 274 ++ lapack-netlib/SRC/zunbdb6.f | 313 ++ lapack-netlib/SRC/zuncsd.f | 64 +- lapack-netlib/SRC/zuncsd2by1.f | 756 ++++ lapack-netlib/TESTING/EIG/alahdg.f | 52 +- lapack-netlib/TESTING/EIG/cchkee.f | 10 +- lapack-netlib/TESTING/EIG/cckcsd.f | 28 +- lapack-netlib/TESTING/EIG/ccsdts.f | 210 +- lapack-netlib/TESTING/EIG/dchkee.f | 10 +- lapack-netlib/TESTING/EIG/dckcsd.f | 28 +- lapack-netlib/TESTING/EIG/dcsdts.f | 212 +- lapack-netlib/TESTING/EIG/dlahd2.f | 10 +- lapack-netlib/TESTING/EIG/schkee.f | 10 +- lapack-netlib/TESTING/EIG/sckcsd.f | 28 +- lapack-netlib/TESTING/EIG/scsdts.f | 210 +- lapack-netlib/TESTING/EIG/zchkee.f | 10 +- lapack-netlib/TESTING/EIG/zckcsd.f | 26 +- lapack-netlib/TESTING/EIG/zcsdts.f | 209 +- lapack-netlib/TESTING/LIN/CMakeLists.txt | 44 +- lapack-netlib/TESTING/LIN/Makefile | 84 +- lapack-netlib/TESTING/LIN/aladhd.f | 86 +- lapack-netlib/TESTING/LIN/alaerh.f | 22 +- lapack-netlib/TESTING/LIN/alahd.f | 136 +- lapack-netlib/TESTING/LIN/cchkaa.f | 80 +- lapack-netlib/TESTING/LIN/cchkhe.f | 142 +- lapack-netlib/TESTING/LIN/cchkhe_rook.f | 844 ++++ lapack-netlib/TESTING/LIN/cchksy.f | 56 +- lapack-netlib/TESTING/LIN/cchksy_rook.f | 860 ++++ lapack-netlib/TESTING/LIN/cdrvhe.f | 27 +- lapack-netlib/TESTING/LIN/cdrvhe_rook.f | 527 +++ lapack-netlib/TESTING/LIN/cdrvpox.f | 11 +- lapack-netlib/TESTING/LIN/cdrvrfp.f | 17 +- lapack-netlib/TESTING/LIN/cdrvsy.f | 25 +- lapack-netlib/TESTING/LIN/cdrvsy_rook.f | 536 +++ lapack-netlib/TESTING/LIN/cerrhe.f | 119 +- lapack-netlib/TESTING/LIN/cerrhex.f | 104 +- lapack-netlib/TESTING/LIN/cerrsy.f | 107 +- lapack-netlib/TESTING/LIN/cerrsyx.f | 100 +- lapack-netlib/TESTING/LIN/cerrvx.f | 66 +- lapack-netlib/TESTING/LIN/cerrvxx.f | 51 +- lapack-netlib/TESTING/LIN/chet01.f | 22 +- lapack-netlib/TESTING/LIN/chet01_rook.f | 239 + lapack-netlib/TESTING/LIN/clatb4.f | 9 +- lapack-netlib/TESTING/LIN/clavhe.f | 191 +- lapack-netlib/TESTING/LIN/clavhe_rook.f | 603 +++ lapack-netlib/TESTING/LIN/clavsy.f | 27 +- lapack-netlib/TESTING/LIN/clavsy_rook.f | 580 +++ lapack-netlib/TESTING/LIN/csyt01.f | 22 +- lapack-netlib/TESTING/LIN/csyt01_rook.f | 227 + lapack-netlib/TESTING/LIN/dchkaa.f | 30 +- lapack-netlib/TESTING/LIN/dchksy.f | 46 +- lapack-netlib/TESTING/LIN/dchksy_rook.f | 830 ++++ lapack-netlib/TESTING/LIN/ddrvpox.f | 11 +- lapack-netlib/TESTING/LIN/ddrvrfp.f | 22 +- lapack-netlib/TESTING/LIN/ddrvsy.f | 25 +- lapack-netlib/TESTING/LIN/ddrvsy_rook.f | 526 +++ lapack-netlib/TESTING/LIN/derrsy.f | 91 +- lapack-netlib/TESTING/LIN/derrsyx.f | 104 +- lapack-netlib/TESTING/LIN/derrvx.f | 20 +- lapack-netlib/TESTING/LIN/derrvxx.f | 6 +- lapack-netlib/TESTING/LIN/dlavsy.f | 23 +- lapack-netlib/TESTING/LIN/dlavsy_rook.f | 584 +++ lapack-netlib/TESTING/LIN/dsyt01.f | 22 +- lapack-netlib/TESTING/LIN/dsyt01_rook.f | 223 + lapack-netlib/TESTING/LIN/schkaa.f | 30 +- lapack-netlib/TESTING/LIN/schksy.f | 42 +- lapack-netlib/TESTING/LIN/schksy_rook.f | 830 ++++ lapack-netlib/TESTING/LIN/sdrvpox.f | 11 +- lapack-netlib/TESTING/LIN/sdrvrfp.f | 21 +- lapack-netlib/TESTING/LIN/sdrvsy.f | 25 +- lapack-netlib/TESTING/LIN/sdrvsy_rook.f | 527 +++ lapack-netlib/TESTING/LIN/serrsy.f | 95 +- lapack-netlib/TESTING/LIN/serrsyx.f | 104 +- lapack-netlib/TESTING/LIN/serrvx.f | 20 +- lapack-netlib/TESTING/LIN/serrvxx.f | 25 +- lapack-netlib/TESTING/LIN/slavsy.f | 23 +- lapack-netlib/TESTING/LIN/slavsy_rook.f | 584 +++ lapack-netlib/TESTING/LIN/ssyt01.f | 22 +- lapack-netlib/TESTING/LIN/ssyt01_rook.f | 223 + lapack-netlib/TESTING/LIN/zchkaa.f | 73 +- lapack-netlib/TESTING/LIN/zchkhe.f | 120 +- lapack-netlib/TESTING/LIN/zchkhe_rook.f | 844 ++++ lapack-netlib/TESTING/LIN/zchksy.f | 56 +- lapack-netlib/TESTING/LIN/zchksy_rook.f | 860 ++++ lapack-netlib/TESTING/LIN/zdrvhe.f | 27 +- lapack-netlib/TESTING/LIN/zdrvhe_rook.f | 528 +++ lapack-netlib/TESTING/LIN/zdrvpox.f | 11 +- lapack-netlib/TESTING/LIN/zdrvrfp.f | 21 +- lapack-netlib/TESTING/LIN/zdrvsy.f | 25 +- lapack-netlib/TESTING/LIN/zdrvsy_rook.f | 534 +++ lapack-netlib/TESTING/LIN/zerrhe.f | 120 +- lapack-netlib/TESTING/LIN/zerrhex.f | 104 +- lapack-netlib/TESTING/LIN/zerrsy.f | 101 +- lapack-netlib/TESTING/LIN/zerrsyx.f | 102 +- lapack-netlib/TESTING/LIN/zerrvx.f | 54 +- lapack-netlib/TESTING/LIN/zerrvxx.f | 70 +- lapack-netlib/TESTING/LIN/zhet01.f | 22 +- lapack-netlib/TESTING/LIN/zhet01_rook.f | 239 + lapack-netlib/TESTING/LIN/zlatb4.f | 9 +- lapack-netlib/TESTING/LIN/zlavhe.f | 191 +- lapack-netlib/TESTING/LIN/zlavhe_rook.f | 600 +++ lapack-netlib/TESTING/LIN/zlavsy.f | 27 +- lapack-netlib/TESTING/LIN/zlavsy_rook.f | 581 +++ lapack-netlib/TESTING/LIN/zsyt01.f | 22 +- lapack-netlib/TESTING/LIN/zsyt01_rook.f | 227 + lapack-netlib/TESTING/csd.in | 4 +- lapack-netlib/TESTING/ctest.in | 2 + lapack-netlib/TESTING/dtest.in | 1 + lapack-netlib/TESTING/stest.in | 1 + lapack-netlib/TESTING/ztest.in | 2 + lapack-netlib/lapack_testing.py | 2 +- lapack-netlib/lapacke/example/CMakeLists.txt | 14 +- lapack-netlib/lapacke/example/Makefile | 34 +- .../lapacke/example/example_DGELS_colmajor.c | 96 + .../lapacke/example/example_DGELS_rowmajor.c | 96 + .../lapacke/example/example_DGESV_colmajor.c | 111 + .../lapacke/example/example_DGESV_rowmajor.c | 169 +- lapack-netlib/lapacke/example/example_user.c | 97 + .../lapacke/example/lapacke_example_aux.c | 33 + .../lapacke/example/lapacke_example_aux.h | 9 + lapack-netlib/lapacke/include/lapacke.h | 150 +- lapack-netlib/lapacke/src/CMakeLists.txt | 22 +- lapack-netlib/lapacke/src/Makefile | 61 +- lapack-netlib/lapacke/src/lapacke_clacn2.c | 50 + .../lapacke/src/lapacke_clacn2_work.c | 45 + lapack-netlib/lapacke/src/lapacke_clacp2.c | 51 + .../lapacke/src/lapacke_clacp2_work.c | 96 + .../lapacke/src/lapacke_cstegr_work.c | 2 +- .../lapacke/src/lapacke_csysv_rook.c | 82 + .../lapacke/src/lapacke_csysv_rook_work.c | 112 + lapack-netlib/lapacke/src/lapacke_dlacn2.c | 49 + .../lapacke/src/lapacke_dlacn2_work.c | 44 + .../lapacke/src/lapacke_dstegr_work.c | 2 +- .../lapacke/src/lapacke_dsysv_rook.c | 80 + .../lapacke/src/lapacke_dsysv_rook_work.c | 107 + lapack-netlib/lapacke/src/lapacke_slacn2.c | 49 + .../lapacke/src/lapacke_slacn2_work.c | 44 + .../lapacke/src/lapacke_sstegr_work.c | 2 +- .../lapacke/src/lapacke_ssysv_rook.c | 80 + .../lapacke/src/lapacke_ssysv_rook_work.c | 107 + lapack-netlib/lapacke/src/lapacke_zlacn2.c | 50 + .../lapacke/src/lapacke_zlacn2_work.c | 45 + lapack-netlib/lapacke/src/lapacke_zlacp2.c | 51 + .../lapacke/src/lapacke_zlacp2_work.c | 96 + .../lapacke/src/lapacke_zstegr_work.c | 2 +- .../lapacke/src/lapacke_zsysv_rook.c | 82 + .../lapacke/src/lapacke_zsysv_rook_work.c | 112 + lapack-netlib/make.inc.example | 8 +- 311 files changed, 57651 insertions(+), 5519 deletions(-) delete mode 100644 lapack-netlib/DOCS/psfig.tex create mode 100644 lapack-netlib/SRC/checon_rook.f create mode 100644 lapack-netlib/SRC/chesv_rook.f create mode 100644 lapack-netlib/SRC/chetf2_rook.f create mode 100644 lapack-netlib/SRC/chetrf_rook.f create mode 100644 lapack-netlib/SRC/chetri_rook.f create mode 100644 lapack-netlib/SRC/chetrs_rook.f create mode 100644 lapack-netlib/SRC/clahef_rook.f create mode 100644 lapack-netlib/SRC/clasyf_rook.f create mode 100644 lapack-netlib/SRC/csycon_rook.f create mode 100644 lapack-netlib/SRC/csysv_rook.f create mode 100644 lapack-netlib/SRC/csytf2_rook.f create mode 100644 lapack-netlib/SRC/csytrf_rook.f create mode 100644 lapack-netlib/SRC/csytri_rook.f create mode 100644 lapack-netlib/SRC/csytrs_rook.f create mode 100644 lapack-netlib/SRC/cunbdb1.f create mode 100644 lapack-netlib/SRC/cunbdb2.f create mode 100644 lapack-netlib/SRC/cunbdb3.f create mode 100644 lapack-netlib/SRC/cunbdb4.f create mode 100644 lapack-netlib/SRC/cunbdb5.f create mode 100644 lapack-netlib/SRC/cunbdb6.f create mode 100644 lapack-netlib/SRC/cuncsd2by1.f create mode 100644 lapack-netlib/SRC/dlasyf_rook.f create mode 100644 lapack-netlib/SRC/dorbdb1.f create mode 100644 lapack-netlib/SRC/dorbdb2.f create mode 100644 lapack-netlib/SRC/dorbdb3.f create mode 100644 lapack-netlib/SRC/dorbdb4.f create mode 100644 lapack-netlib/SRC/dorbdb5.f create mode 100644 lapack-netlib/SRC/dorbdb6.f create mode 100644 lapack-netlib/SRC/dorcsd2by1.f create mode 100644 lapack-netlib/SRC/dsycon_rook.f create mode 100644 lapack-netlib/SRC/dsysv_rook.f create mode 100644 lapack-netlib/SRC/dsytf2_rook.f create mode 100644 lapack-netlib/SRC/dsytrf_rook.f create mode 100644 lapack-netlib/SRC/dsytri_rook.f create mode 100644 lapack-netlib/SRC/dsytrs_rook.f create mode 100644 lapack-netlib/SRC/slasyf_rook.f create mode 100644 lapack-netlib/SRC/sorbdb1.f create mode 100644 lapack-netlib/SRC/sorbdb2.f create mode 100644 lapack-netlib/SRC/sorbdb3.f create mode 100644 lapack-netlib/SRC/sorbdb4.f create mode 100644 lapack-netlib/SRC/sorbdb5.f create mode 100644 lapack-netlib/SRC/sorbdb6.f create mode 100644 lapack-netlib/SRC/sorcsd2by1.f create mode 100644 lapack-netlib/SRC/ssycon_rook.f create mode 100644 lapack-netlib/SRC/ssysv_rook.f create mode 100644 lapack-netlib/SRC/ssytf2_rook.f create mode 100644 lapack-netlib/SRC/ssytrf_rook.f create mode 100644 lapack-netlib/SRC/ssytri_rook.f create mode 100644 lapack-netlib/SRC/ssytrs_rook.f create mode 100644 lapack-netlib/SRC/zhecon_rook.f create mode 100644 lapack-netlib/SRC/zhesv_rook.f create mode 100644 lapack-netlib/SRC/zhetf2_rook.f create mode 100644 lapack-netlib/SRC/zhetrf_rook.f create mode 100644 lapack-netlib/SRC/zhetri_rook.f create mode 100644 lapack-netlib/SRC/zhetrs_rook.f create mode 100644 lapack-netlib/SRC/zlahef_rook.f create mode 100644 lapack-netlib/SRC/zlasyf_rook.f create mode 100644 lapack-netlib/SRC/zsycon_rook.f create mode 100644 lapack-netlib/SRC/zsysv_rook.f create mode 100644 lapack-netlib/SRC/zsytf2_rook.f create mode 100644 lapack-netlib/SRC/zsytrf_rook.f create mode 100644 lapack-netlib/SRC/zsytri_rook.f create mode 100644 lapack-netlib/SRC/zsytrs_rook.f create mode 100644 lapack-netlib/SRC/zunbdb1.f create mode 100644 lapack-netlib/SRC/zunbdb2.f create mode 100644 lapack-netlib/SRC/zunbdb3.f create mode 100644 lapack-netlib/SRC/zunbdb4.f create mode 100644 lapack-netlib/SRC/zunbdb5.f create mode 100644 lapack-netlib/SRC/zunbdb6.f create mode 100644 lapack-netlib/SRC/zuncsd2by1.f create mode 100644 lapack-netlib/TESTING/LIN/cchkhe_rook.f create mode 100644 lapack-netlib/TESTING/LIN/cchksy_rook.f create mode 100644 lapack-netlib/TESTING/LIN/cdrvhe_rook.f create mode 100644 lapack-netlib/TESTING/LIN/cdrvsy_rook.f create mode 100644 lapack-netlib/TESTING/LIN/chet01_rook.f create mode 100644 lapack-netlib/TESTING/LIN/clavhe_rook.f create mode 100644 lapack-netlib/TESTING/LIN/clavsy_rook.f create mode 100644 lapack-netlib/TESTING/LIN/csyt01_rook.f create mode 100644 lapack-netlib/TESTING/LIN/dchksy_rook.f create mode 100644 lapack-netlib/TESTING/LIN/ddrvsy_rook.f create mode 100644 lapack-netlib/TESTING/LIN/dlavsy_rook.f create mode 100644 lapack-netlib/TESTING/LIN/dsyt01_rook.f create mode 100644 lapack-netlib/TESTING/LIN/schksy_rook.f create mode 100644 lapack-netlib/TESTING/LIN/sdrvsy_rook.f create mode 100644 lapack-netlib/TESTING/LIN/slavsy_rook.f create mode 100644 lapack-netlib/TESTING/LIN/ssyt01_rook.f create mode 100644 lapack-netlib/TESTING/LIN/zchkhe_rook.f create mode 100644 lapack-netlib/TESTING/LIN/zchksy_rook.f create mode 100644 lapack-netlib/TESTING/LIN/zdrvhe_rook.f create mode 100644 lapack-netlib/TESTING/LIN/zdrvsy_rook.f create mode 100644 lapack-netlib/TESTING/LIN/zhet01_rook.f create mode 100644 lapack-netlib/TESTING/LIN/zlavhe_rook.f create mode 100644 lapack-netlib/TESTING/LIN/zlavsy_rook.f create mode 100644 lapack-netlib/TESTING/LIN/zsyt01_rook.f create mode 100644 lapack-netlib/lapacke/example/example_DGELS_colmajor.c create mode 100644 lapack-netlib/lapacke/example/example_DGELS_rowmajor.c create mode 100644 lapack-netlib/lapacke/example/example_DGESV_colmajor.c create mode 100644 lapack-netlib/lapacke/example/example_user.c create mode 100644 lapack-netlib/lapacke/example/lapacke_example_aux.c create mode 100644 lapack-netlib/lapacke/example/lapacke_example_aux.h create mode 100644 lapack-netlib/lapacke/src/lapacke_clacn2.c create mode 100644 lapack-netlib/lapacke/src/lapacke_clacn2_work.c create mode 100644 lapack-netlib/lapacke/src/lapacke_clacp2.c create mode 100644 lapack-netlib/lapacke/src/lapacke_clacp2_work.c create mode 100644 lapack-netlib/lapacke/src/lapacke_csysv_rook.c create mode 100644 lapack-netlib/lapacke/src/lapacke_csysv_rook_work.c create mode 100644 lapack-netlib/lapacke/src/lapacke_dlacn2.c create mode 100644 lapack-netlib/lapacke/src/lapacke_dlacn2_work.c create mode 100644 lapack-netlib/lapacke/src/lapacke_dsysv_rook.c create mode 100644 lapack-netlib/lapacke/src/lapacke_dsysv_rook_work.c create mode 100644 lapack-netlib/lapacke/src/lapacke_slacn2.c create mode 100644 lapack-netlib/lapacke/src/lapacke_slacn2_work.c create mode 100644 lapack-netlib/lapacke/src/lapacke_ssysv_rook.c create mode 100644 lapack-netlib/lapacke/src/lapacke_ssysv_rook_work.c create mode 100644 lapack-netlib/lapacke/src/lapacke_zlacn2.c create mode 100644 lapack-netlib/lapacke/src/lapacke_zlacn2_work.c create mode 100644 lapack-netlib/lapacke/src/lapacke_zlacp2.c create mode 100644 lapack-netlib/lapacke/src/lapacke_zlacp2_work.c create mode 100644 lapack-netlib/lapacke/src/lapacke_zsysv_rook.c create mode 100644 lapack-netlib/lapacke/src/lapacke_zsysv_rook_work.c diff --git a/exports/gensymbol b/exports/gensymbol index e154b26bb..daedf8dcc 100644 --- a/exports/gensymbol +++ b/exports/gensymbol @@ -181,7 +181,7 @@ slaqtr, slar1v, slar2v, ilaslr, ilaslc, slarf, slarfb, slarfg, slarfgp, slarft, slarfx, slargv, slarrv, slartv, - slarz, slarzb, slarzt, slasy2, slasyf, + slarz, slarzb, slarzt, slasy2, slasyf, slatbs, slatdf, slatps, slatrd, slatrs, slatrz, slatzm, sopgtr, sopmtr, sorg2l, sorg2r, sorgbr, sorghr, sorgl2, sorglq, sorgql, sorgqr, sorgr2, @@ -213,7 +213,8 @@ stfttr, stpttf, stpttr, strttf, strttp, sgejsv, sgesvj, sgsvj0, sgsvj1, sgeequb, ssyequb, spoequb, sgbequb, - sbbcsd, slapmr, sorbdb, sorcsd, + sbbcsd, slapmr, sorbdb, sorbdb1, sorbdb2, sorbdb3, sorbdb4, + sorbdb5, sorbdb6, sorcsd, sorcsd2by1, sgeqrt, sgeqrt2, sgeqrt3, sgemqrt, stpqrt, stpqrt2, stpmqrt, stprfb, @@ -288,7 +289,8 @@ chfrk, ctfttp, clanhf, cpftrf, cpftri, cpftrs, ctfsm, ctftri, ctfttr, ctpttf, ctpttr, ctrttf, ctrttp, cgeequb, cgbequb, csyequb, cpoequb, cheequb, - cbbcsd, clapmr, cunbdb, cuncsd, + cbbcsd, clapmr, cunbdb, cunbdb1, cunbdb2, cunbdb3, cunbdb4, + cunbdb5, cunbdb6, cuncsd, cuncsd2by1, cgeqrt, cgeqrt2, cgeqrt3, cgemqrt, ctpqrt, ctpqrt2, ctpmqrt, ctprfb, @@ -360,7 +362,8 @@ dtfttr, dtpttf, dtpttr, dtrttf, dtrttp, dgejsv, dgesvj, dgsvj0, dgsvj1, dgeequb, dsyequb, dpoequb, dgbequb, - dbbcsd, dlapmr, dorbdb, dorcsd, + dbbcsd, dlapmr, dorbdb, dorbdb1, dorbdb2, dorbdb3, dorbdb4, + dorbdb5, dorbdb6, dorcsd, dorcsd2by1, dgeqrt, dgeqrt2, dgeqrt3, dgemqrt, dtpqrt, dtpqrt2, dtpmqrt, dtprfb, @@ -433,7 +436,8 @@ zhfrk, ztfttp, zlanhf, zpftrf, zpftri, zpftrs, ztfsm, ztftri, ztfttr, ztpttf, ztpttr, ztrttf, ztrttp, zgeequb, zgbequb, zsyequb, zpoequb, zheequb, - zbbcsd, zlapmr, zunbdb, zuncsd, + zbbcsd, zlapmr, zunbdb, zunbdb1, zunbdb2, zunbdb3, zunbdb4, + zunbdb5, zunbdb6, zuncsd, zuncsd2by1, zgeqrt, zgeqrt2, zgeqrt3, zgemqrt, ztpqrt, ztpqrt2, ztpmqrt, ztprfb, ); @@ -603,1965 +607,1986 @@ lapack_make_complex_float, lapack_make_complex_double, - # @(SRC_OBJ) from `lapack-3.4.1/lapacke/src/Makefile` - LAPACKE_cbbcsd, - LAPACKE_cbbcsd_work, - LAPACKE_cbdsqr, - LAPACKE_cbdsqr_work, - LAPACKE_cgbbrd, - LAPACKE_cgbbrd_work, - LAPACKE_cgbcon, - LAPACKE_cgbcon_work, - LAPACKE_cgbequ, - LAPACKE_cgbequ_work, - LAPACKE_cgbequb, - LAPACKE_cgbequb_work, - LAPACKE_cgbrfs, - LAPACKE_cgbrfs_work, - LAPACKE_cgbsv, - LAPACKE_cgbsv_work, - LAPACKE_cgbsvx, - LAPACKE_cgbsvx_work, - LAPACKE_cgbtrf, - LAPACKE_cgbtrf_work, - LAPACKE_cgbtrs, - LAPACKE_cgbtrs_work, - LAPACKE_cgebak, - LAPACKE_cgebak_work, - LAPACKE_cgebal, - LAPACKE_cgebal_work, - LAPACKE_cgebrd, - LAPACKE_cgebrd_work, - LAPACKE_cgecon, - LAPACKE_cgecon_work, - LAPACKE_cgeequ, - LAPACKE_cgeequ_work, - LAPACKE_cgeequb, - LAPACKE_cgeequb_work, - LAPACKE_cgees, - LAPACKE_cgees_work, - LAPACKE_cgeesx, - LAPACKE_cgeesx_work, - LAPACKE_cgeev, - LAPACKE_cgeev_work, - LAPACKE_cgeevx, - LAPACKE_cgeevx_work, - LAPACKE_cgehrd, - LAPACKE_cgehrd_work, - LAPACKE_cgelq2, - LAPACKE_cgelq2_work, - LAPACKE_cgelqf, - LAPACKE_cgelqf_work, - LAPACKE_cgels, - LAPACKE_cgels_work, - LAPACKE_cgelsd, - LAPACKE_cgelsd_work, - LAPACKE_cgelss, - LAPACKE_cgelss_work, - LAPACKE_cgelsy, - LAPACKE_cgelsy_work, - LAPACKE_cgemqrt, - LAPACKE_cgemqrt_work, - LAPACKE_cgeqlf, - LAPACKE_cgeqlf_work, - LAPACKE_cgeqp3, - LAPACKE_cgeqp3_work, - LAPACKE_cgeqpf, - LAPACKE_cgeqpf_work, - LAPACKE_cgeqr2, - LAPACKE_cgeqr2_work, - LAPACKE_cgeqrf, - LAPACKE_cgeqrf_work, - LAPACKE_cgeqrfp, - LAPACKE_cgeqrfp_work, - LAPACKE_cgeqrt, - LAPACKE_cgeqrt2, - LAPACKE_cgeqrt2_work, - LAPACKE_cgeqrt3, - LAPACKE_cgeqrt3_work, - LAPACKE_cgeqrt_work, - LAPACKE_cgerfs, - LAPACKE_cgerfs_work, - LAPACKE_cgerqf, - LAPACKE_cgerqf_work, - LAPACKE_cgesdd, - LAPACKE_cgesdd_work, - LAPACKE_cgesv, - LAPACKE_cgesv_work, - LAPACKE_cgesvd, - LAPACKE_cgesvd_work, - LAPACKE_cgesvx, - LAPACKE_cgesvx_work, - LAPACKE_cgetf2, - LAPACKE_cgetf2_work, - LAPACKE_cgetrf, - LAPACKE_cgetrf_work, - LAPACKE_cgetri, - LAPACKE_cgetri_work, - LAPACKE_cgetrs, - LAPACKE_cgetrs_work, - LAPACKE_cggbak, - LAPACKE_cggbak_work, - LAPACKE_cggbal, - LAPACKE_cggbal_work, - LAPACKE_cgges, - LAPACKE_cgges_work, - LAPACKE_cggesx, - LAPACKE_cggesx_work, - LAPACKE_cggev, - LAPACKE_cggev_work, - LAPACKE_cggevx, - LAPACKE_cggevx_work, - LAPACKE_cggglm, - LAPACKE_cggglm_work, - LAPACKE_cgghrd, - LAPACKE_cgghrd_work, - LAPACKE_cgglse, - LAPACKE_cgglse_work, - LAPACKE_cggqrf, - LAPACKE_cggqrf_work, - LAPACKE_cggrqf, - LAPACKE_cggrqf_work, - LAPACKE_cggsvd, - LAPACKE_cggsvd_work, - LAPACKE_cggsvp, - LAPACKE_cggsvp_work, - LAPACKE_cgtcon, - LAPACKE_cgtcon_work, - LAPACKE_cgtrfs, - LAPACKE_cgtrfs_work, - LAPACKE_cgtsv, - LAPACKE_cgtsv_work, - LAPACKE_cgtsvx, - LAPACKE_cgtsvx_work, - LAPACKE_cgttrf, - LAPACKE_cgttrf_work, - LAPACKE_cgttrs, - LAPACKE_cgttrs_work, - LAPACKE_chbev, - LAPACKE_chbev_work, - LAPACKE_chbevd, - LAPACKE_chbevd_work, - LAPACKE_chbevx, - LAPACKE_chbevx_work, - LAPACKE_chbgst, - LAPACKE_chbgst_work, - LAPACKE_chbgv, - LAPACKE_chbgv_work, - LAPACKE_chbgvd, - LAPACKE_chbgvd_work, - LAPACKE_chbgvx, - LAPACKE_chbgvx_work, - LAPACKE_chbtrd, - LAPACKE_chbtrd_work, - LAPACKE_checon, - LAPACKE_checon_work, - LAPACKE_cheequb, - LAPACKE_cheequb_work, - LAPACKE_cheev, - LAPACKE_cheev_work, - LAPACKE_cheevd, - LAPACKE_cheevd_work, - LAPACKE_cheevr, - LAPACKE_cheevr_work, - LAPACKE_cheevx, - LAPACKE_cheevx_work, - LAPACKE_chegst, - LAPACKE_chegst_work, - LAPACKE_chegv, - LAPACKE_chegv_work, - LAPACKE_chegvd, - LAPACKE_chegvd_work, - LAPACKE_chegvx, - LAPACKE_chegvx_work, - LAPACKE_cherfs, - LAPACKE_cherfs_work, - LAPACKE_chesv, - LAPACKE_chesv_work, - LAPACKE_chesvx, - LAPACKE_chesvx_work, - LAPACKE_cheswapr, - LAPACKE_cheswapr_work, - LAPACKE_chetrd, - LAPACKE_chetrd_work, - LAPACKE_chetrf, - LAPACKE_chetrf_work, - LAPACKE_chetri, - LAPACKE_chetri2, - LAPACKE_chetri2_work, - LAPACKE_chetri2x, - LAPACKE_chetri2x_work, - LAPACKE_chetri_work, - LAPACKE_chetrs, - LAPACKE_chetrs2, - LAPACKE_chetrs2_work, - LAPACKE_chetrs_work, - LAPACKE_chfrk, - LAPACKE_chfrk_work, - LAPACKE_chgeqz, - LAPACKE_chgeqz_work, - LAPACKE_chpcon, - LAPACKE_chpcon_work, - LAPACKE_chpev, - LAPACKE_chpev_work, - LAPACKE_chpevd, - LAPACKE_chpevd_work, - LAPACKE_chpevx, - LAPACKE_chpevx_work, - LAPACKE_chpgst, - LAPACKE_chpgst_work, - LAPACKE_chpgv, - LAPACKE_chpgv_work, - LAPACKE_chpgvd, - LAPACKE_chpgvd_work, - LAPACKE_chpgvx, - LAPACKE_chpgvx_work, - LAPACKE_chprfs, - LAPACKE_chprfs_work, - LAPACKE_chpsv, - LAPACKE_chpsv_work, - LAPACKE_chpsvx, - LAPACKE_chpsvx_work, - LAPACKE_chptrd, - LAPACKE_chptrd_work, - LAPACKE_chptrf, - LAPACKE_chptrf_work, - LAPACKE_chptri, - LAPACKE_chptri_work, - LAPACKE_chptrs, - LAPACKE_chptrs_work, - LAPACKE_chsein, - LAPACKE_chsein_work, - LAPACKE_chseqr, - LAPACKE_chseqr_work, - LAPACKE_clacgv, - LAPACKE_clacgv_work, - LAPACKE_clacpy, - LAPACKE_clacpy_work, - LAPACKE_clag2z, - LAPACKE_clag2z_work, - LAPACKE_clange, - LAPACKE_clange_work, - LAPACKE_clanhe, - LAPACKE_clanhe_work, - LAPACKE_clansy, - LAPACKE_clansy_work, - LAPACKE_clantr, - LAPACKE_clantr_work, - LAPACKE_clapmr, - LAPACKE_clapmr_work, - LAPACKE_clarfb, - LAPACKE_clarfb_work, - LAPACKE_clarfg, - LAPACKE_clarfg_work, - LAPACKE_clarft, - LAPACKE_clarft_work, - LAPACKE_clarfx, - LAPACKE_clarfx_work, - LAPACKE_clarnv, - LAPACKE_clarnv_work, - LAPACKE_claset, - LAPACKE_claset_work, - LAPACKE_claswp, - LAPACKE_claswp_work, - LAPACKE_clauum, - LAPACKE_clauum_work, - LAPACKE_cpbcon, - LAPACKE_cpbcon_work, - LAPACKE_cpbequ, - LAPACKE_cpbequ_work, - LAPACKE_cpbrfs, - LAPACKE_cpbrfs_work, - LAPACKE_cpbstf, - LAPACKE_cpbstf_work, - LAPACKE_cpbsv, - LAPACKE_cpbsv_work, - LAPACKE_cpbsvx, - LAPACKE_cpbsvx_work, - LAPACKE_cpbtrf, - LAPACKE_cpbtrf_work, - LAPACKE_cpbtrs, - LAPACKE_cpbtrs_work, - LAPACKE_cpftrf, - LAPACKE_cpftrf_work, - LAPACKE_cpftri, - LAPACKE_cpftri_work, - LAPACKE_cpftrs, - LAPACKE_cpftrs_work, - LAPACKE_cpocon, - LAPACKE_cpocon_work, - LAPACKE_cpoequ, - LAPACKE_cpoequ_work, - LAPACKE_cpoequb, - LAPACKE_cpoequb_work, - LAPACKE_cporfs, - LAPACKE_cporfs_work, - LAPACKE_cposv, - LAPACKE_cposv_work, - LAPACKE_cposvx, - LAPACKE_cposvx_work, - LAPACKE_cpotrf, - LAPACKE_cpotrf_work, - LAPACKE_cpotri, - LAPACKE_cpotri_work, - LAPACKE_cpotrs, - LAPACKE_cpotrs_work, - LAPACKE_cppcon, - LAPACKE_cppcon_work, - LAPACKE_cppequ, - LAPACKE_cppequ_work, - LAPACKE_cpprfs, - LAPACKE_cpprfs_work, - LAPACKE_cppsv, - LAPACKE_cppsv_work, - LAPACKE_cppsvx, - LAPACKE_cppsvx_work, - LAPACKE_cpptrf, - LAPACKE_cpptrf_work, - LAPACKE_cpptri, - LAPACKE_cpptri_work, - LAPACKE_cpptrs, - LAPACKE_cpptrs_work, - LAPACKE_cpstrf, - LAPACKE_cpstrf_work, - LAPACKE_cptcon, - LAPACKE_cptcon_work, - LAPACKE_cpteqr, - LAPACKE_cpteqr_work, - LAPACKE_cptrfs, - LAPACKE_cptrfs_work, - LAPACKE_cptsv, - LAPACKE_cptsv_work, - LAPACKE_cptsvx, - LAPACKE_cptsvx_work, - LAPACKE_cpttrf, - LAPACKE_cpttrf_work, - LAPACKE_cpttrs, - LAPACKE_cpttrs_work, - LAPACKE_cspcon, - LAPACKE_cspcon_work, - LAPACKE_csprfs, - LAPACKE_csprfs_work, - LAPACKE_cspsv, - LAPACKE_cspsv_work, - LAPACKE_cspsvx, - LAPACKE_cspsvx_work, - LAPACKE_csptrf, - LAPACKE_csptrf_work, - LAPACKE_csptri, - LAPACKE_csptri_work, - LAPACKE_csptrs, - LAPACKE_csptrs_work, - LAPACKE_cstedc, - LAPACKE_cstedc_work, - LAPACKE_cstegr, - LAPACKE_cstegr_work, - LAPACKE_cstein, - LAPACKE_cstein_work, - LAPACKE_cstemr, - LAPACKE_cstemr_work, - LAPACKE_csteqr, - LAPACKE_csteqr_work, - LAPACKE_csycon, - LAPACKE_csycon_work, - LAPACKE_csyconv, - LAPACKE_csyconv_work, - LAPACKE_csyequb, - LAPACKE_csyequb_work, - LAPACKE_csyrfs, - LAPACKE_csyrfs_work, - LAPACKE_csysv, - LAPACKE_csysv_work, - LAPACKE_csysvx, - LAPACKE_csysvx_work, - LAPACKE_csyswapr, - LAPACKE_csyswapr_work, - LAPACKE_csytrf, - LAPACKE_csytrf_work, - LAPACKE_csytri, - LAPACKE_csytri2, - LAPACKE_csytri2_work, - LAPACKE_csytri2x, - LAPACKE_csytri2x_work, - LAPACKE_csytri_work, - LAPACKE_csytrs, - LAPACKE_csytrs2, - LAPACKE_csytrs2_work, - LAPACKE_csytrs_work, - LAPACKE_ctbcon, - LAPACKE_ctbcon_work, - LAPACKE_ctbrfs, - LAPACKE_ctbrfs_work, - LAPACKE_ctbtrs, - LAPACKE_ctbtrs_work, - LAPACKE_ctfsm, - LAPACKE_ctfsm_work, - LAPACKE_ctftri, - LAPACKE_ctftri_work, - LAPACKE_ctfttp, - LAPACKE_ctfttp_work, - LAPACKE_ctfttr, - LAPACKE_ctfttr_work, - LAPACKE_ctgevc, - LAPACKE_ctgevc_work, - LAPACKE_ctgexc, - LAPACKE_ctgexc_work, - LAPACKE_ctgsen, - LAPACKE_ctgsen_work, - LAPACKE_ctgsja, - LAPACKE_ctgsja_work, - LAPACKE_ctgsna, - LAPACKE_ctgsna_work, - LAPACKE_ctgsyl, - LAPACKE_ctgsyl_work, - LAPACKE_ctpcon, - LAPACKE_ctpcon_work, - LAPACKE_ctpmqrt, - LAPACKE_ctpmqrt_work, - LAPACKE_ctpqrt, - LAPACKE_ctpqrt2, - LAPACKE_ctpqrt2_work, - LAPACKE_ctpqrt_work, - LAPACKE_ctprfb, - LAPACKE_ctprfb_work, - LAPACKE_ctprfs, - LAPACKE_ctprfs_work, - LAPACKE_ctptri, - LAPACKE_ctptri_work, - LAPACKE_ctptrs, - LAPACKE_ctptrs_work, - LAPACKE_ctpttf, - LAPACKE_ctpttf_work, - LAPACKE_ctpttr, - LAPACKE_ctpttr_work, - LAPACKE_ctrcon, - LAPACKE_ctrcon_work, - LAPACKE_ctrevc, - LAPACKE_ctrevc_work, - LAPACKE_ctrexc, - LAPACKE_ctrexc_work, - LAPACKE_ctrrfs, - LAPACKE_ctrrfs_work, - LAPACKE_ctrsen, - LAPACKE_ctrsen_work, - LAPACKE_ctrsna, - LAPACKE_ctrsna_work, - LAPACKE_ctrsyl, - LAPACKE_ctrsyl_work, - LAPACKE_ctrtri, - LAPACKE_ctrtri_work, - LAPACKE_ctrtrs, - LAPACKE_ctrtrs_work, - LAPACKE_ctrttf, - LAPACKE_ctrttf_work, - LAPACKE_ctrttp, - LAPACKE_ctrttp_work, - LAPACKE_ctzrzf, - LAPACKE_ctzrzf_work, - LAPACKE_cunbdb, - LAPACKE_cunbdb_work, - LAPACKE_cuncsd, - LAPACKE_cuncsd_work, - LAPACKE_cungbr, - LAPACKE_cungbr_work, - LAPACKE_cunghr, - LAPACKE_cunghr_work, - LAPACKE_cunglq, - LAPACKE_cunglq_work, - LAPACKE_cungql, - LAPACKE_cungql_work, - LAPACKE_cungqr, - LAPACKE_cungqr_work, - LAPACKE_cungrq, - LAPACKE_cungrq_work, - LAPACKE_cungtr, - LAPACKE_cungtr_work, - LAPACKE_cunmbr, - LAPACKE_cunmbr_work, - LAPACKE_cunmhr, - LAPACKE_cunmhr_work, - LAPACKE_cunmlq, - LAPACKE_cunmlq_work, - LAPACKE_cunmql, - LAPACKE_cunmql_work, - LAPACKE_cunmqr, - LAPACKE_cunmqr_work, - LAPACKE_cunmrq, - LAPACKE_cunmrq_work, - LAPACKE_cunmrz, - LAPACKE_cunmrz_work, - LAPACKE_cunmtr, - LAPACKE_cunmtr_work, - LAPACKE_cupgtr, - LAPACKE_cupgtr_work, - LAPACKE_cupmtr, - LAPACKE_cupmtr_work, - LAPACKE_dbbcsd, - LAPACKE_dbbcsd_work, - LAPACKE_dbdsdc, - LAPACKE_dbdsdc_work, - LAPACKE_dbdsqr, - LAPACKE_dbdsqr_work, - LAPACKE_ddisna, - LAPACKE_ddisna_work, - LAPACKE_dgbbrd, - LAPACKE_dgbbrd_work, - LAPACKE_dgbcon, - LAPACKE_dgbcon_work, - LAPACKE_dgbequ, - LAPACKE_dgbequ_work, - LAPACKE_dgbequb, - LAPACKE_dgbequb_work, - LAPACKE_dgbrfs, - LAPACKE_dgbrfs_work, - LAPACKE_dgbsv, - LAPACKE_dgbsv_work, - LAPACKE_dgbsvx, - LAPACKE_dgbsvx_work, - LAPACKE_dgbtrf, - LAPACKE_dgbtrf_work, - LAPACKE_dgbtrs, - LAPACKE_dgbtrs_work, - LAPACKE_dgebak, - LAPACKE_dgebak_work, - LAPACKE_dgebal, - LAPACKE_dgebal_work, - LAPACKE_dgebrd, - LAPACKE_dgebrd_work, - LAPACKE_dgecon, - LAPACKE_dgecon_work, - LAPACKE_dgeequ, - LAPACKE_dgeequ_work, - LAPACKE_dgeequb, - LAPACKE_dgeequb_work, - LAPACKE_dgees, - LAPACKE_dgees_work, - LAPACKE_dgeesx, - LAPACKE_dgeesx_work, - LAPACKE_dgeev, - LAPACKE_dgeev_work, - LAPACKE_dgeevx, - LAPACKE_dgeevx_work, - LAPACKE_dgehrd, - LAPACKE_dgehrd_work, - LAPACKE_dgejsv, - LAPACKE_dgejsv_work, - LAPACKE_dgelq2, - LAPACKE_dgelq2_work, - LAPACKE_dgelqf, - LAPACKE_dgelqf_work, - LAPACKE_dgels, - LAPACKE_dgels_work, - LAPACKE_dgelsd, - LAPACKE_dgelsd_work, - LAPACKE_dgelss, - LAPACKE_dgelss_work, - LAPACKE_dgelsy, - LAPACKE_dgelsy_work, - LAPACKE_dgemqrt, - LAPACKE_dgemqrt_work, - LAPACKE_dgeqlf, - LAPACKE_dgeqlf_work, - LAPACKE_dgeqp3, - LAPACKE_dgeqp3_work, - LAPACKE_dgeqpf, - LAPACKE_dgeqpf_work, - LAPACKE_dgeqr2, - LAPACKE_dgeqr2_work, - LAPACKE_dgeqrf, - LAPACKE_dgeqrf_work, - LAPACKE_dgeqrfp, - LAPACKE_dgeqrfp_work, - LAPACKE_dgeqrt, - LAPACKE_dgeqrt2, - LAPACKE_dgeqrt2_work, - LAPACKE_dgeqrt3, - LAPACKE_dgeqrt3_work, - LAPACKE_dgeqrt_work, - LAPACKE_dgerfs, - LAPACKE_dgerfs_work, - LAPACKE_dgerqf, - LAPACKE_dgerqf_work, - LAPACKE_dgesdd, - LAPACKE_dgesdd_work, - LAPACKE_dgesv, - LAPACKE_dgesv_work, - LAPACKE_dgesvd, - LAPACKE_dgesvd_work, - LAPACKE_dgesvj, - LAPACKE_dgesvj_work, - LAPACKE_dgesvx, - LAPACKE_dgesvx_work, - LAPACKE_dgetf2, - LAPACKE_dgetf2_work, - LAPACKE_dgetrf, - LAPACKE_dgetrf_work, - LAPACKE_dgetri, - LAPACKE_dgetri_work, - LAPACKE_dgetrs, - LAPACKE_dgetrs_work, - LAPACKE_dggbak, - LAPACKE_dggbak_work, - LAPACKE_dggbal, - LAPACKE_dggbal_work, - LAPACKE_dgges, - LAPACKE_dgges_work, - LAPACKE_dggesx, - LAPACKE_dggesx_work, - LAPACKE_dggev, - LAPACKE_dggev_work, - LAPACKE_dggevx, - LAPACKE_dggevx_work, - LAPACKE_dggglm, - LAPACKE_dggglm_work, - LAPACKE_dgghrd, - LAPACKE_dgghrd_work, - LAPACKE_dgglse, - LAPACKE_dgglse_work, - LAPACKE_dggqrf, - LAPACKE_dggqrf_work, - LAPACKE_dggrqf, - LAPACKE_dggrqf_work, - LAPACKE_dggsvd, - LAPACKE_dggsvd_work, - LAPACKE_dggsvp, - LAPACKE_dggsvp_work, - LAPACKE_dgtcon, - LAPACKE_dgtcon_work, - LAPACKE_dgtrfs, - LAPACKE_dgtrfs_work, - LAPACKE_dgtsv, - LAPACKE_dgtsv_work, - LAPACKE_dgtsvx, - LAPACKE_dgtsvx_work, - LAPACKE_dgttrf, - LAPACKE_dgttrf_work, - LAPACKE_dgttrs, - LAPACKE_dgttrs_work, - LAPACKE_dhgeqz, - LAPACKE_dhgeqz_work, - LAPACKE_dhsein, - LAPACKE_dhsein_work, - LAPACKE_dhseqr, - LAPACKE_dhseqr_work, - LAPACKE_dlacpy, - LAPACKE_dlacpy_work, - LAPACKE_dlag2s, - LAPACKE_dlag2s_work, - LAPACKE_dlamch, - LAPACKE_dlamch_work, - LAPACKE_dlange, - LAPACKE_dlange_work, - LAPACKE_dlansy, - LAPACKE_dlansy_work, - LAPACKE_dlantr, - LAPACKE_dlantr_work, - LAPACKE_dlapmr, - LAPACKE_dlapmr_work, - LAPACKE_dlapy2, - LAPACKE_dlapy2_work, - LAPACKE_dlapy3, - LAPACKE_dlapy3_work, - LAPACKE_dlarfb, - LAPACKE_dlarfb_work, - LAPACKE_dlarfg, - LAPACKE_dlarfg_work, - LAPACKE_dlarft, - LAPACKE_dlarft_work, - LAPACKE_dlarfx, - LAPACKE_dlarfx_work, - LAPACKE_dlarnv, - LAPACKE_dlarnv_work, - LAPACKE_dlartgp, - LAPACKE_dlartgp_work, - LAPACKE_dlartgs, - LAPACKE_dlartgs_work, - LAPACKE_dlaset, - LAPACKE_dlaset_work, - LAPACKE_dlasrt, - LAPACKE_dlasrt_work, - LAPACKE_dlaswp, - LAPACKE_dlaswp_work, - LAPACKE_dlauum, - LAPACKE_dlauum_work, - LAPACKE_dopgtr, - LAPACKE_dopgtr_work, - LAPACKE_dopmtr, - LAPACKE_dopmtr_work, - LAPACKE_dorbdb, - LAPACKE_dorbdb_work, - LAPACKE_dorcsd, - LAPACKE_dorcsd_work, - LAPACKE_dorgbr, - LAPACKE_dorgbr_work, - LAPACKE_dorghr, - LAPACKE_dorghr_work, - LAPACKE_dorglq, - LAPACKE_dorglq_work, - LAPACKE_dorgql, - LAPACKE_dorgql_work, - LAPACKE_dorgqr, - LAPACKE_dorgqr_work, - LAPACKE_dorgrq, - LAPACKE_dorgrq_work, - LAPACKE_dorgtr, - LAPACKE_dorgtr_work, - LAPACKE_dormbr, - LAPACKE_dormbr_work, - LAPACKE_dormhr, - LAPACKE_dormhr_work, - LAPACKE_dormlq, - LAPACKE_dormlq_work, - LAPACKE_dormql, - LAPACKE_dormql_work, - LAPACKE_dormqr, - LAPACKE_dormqr_work, - LAPACKE_dormrq, - LAPACKE_dormrq_work, - LAPACKE_dormrz, - LAPACKE_dormrz_work, - LAPACKE_dormtr, - LAPACKE_dormtr_work, - LAPACKE_dpbcon, - LAPACKE_dpbcon_work, - LAPACKE_dpbequ, - LAPACKE_dpbequ_work, - LAPACKE_dpbrfs, - LAPACKE_dpbrfs_work, - LAPACKE_dpbstf, - LAPACKE_dpbstf_work, - LAPACKE_dpbsv, - LAPACKE_dpbsv_work, - LAPACKE_dpbsvx, - LAPACKE_dpbsvx_work, - LAPACKE_dpbtrf, - LAPACKE_dpbtrf_work, - LAPACKE_dpbtrs, - LAPACKE_dpbtrs_work, - LAPACKE_dpftrf, - LAPACKE_dpftrf_work, - LAPACKE_dpftri, - LAPACKE_dpftri_work, - LAPACKE_dpftrs, - LAPACKE_dpftrs_work, - LAPACKE_dpocon, - LAPACKE_dpocon_work, - LAPACKE_dpoequ, - LAPACKE_dpoequ_work, - LAPACKE_dpoequb, - LAPACKE_dpoequb_work, - LAPACKE_dporfs, - LAPACKE_dporfs_work, - LAPACKE_dposv, - LAPACKE_dposv_work, - LAPACKE_dposvx, - LAPACKE_dposvx_work, - LAPACKE_dpotrf, - LAPACKE_dpotrf_work, - LAPACKE_dpotri, - LAPACKE_dpotri_work, - LAPACKE_dpotrs, - LAPACKE_dpotrs_work, - LAPACKE_dppcon, - LAPACKE_dppcon_work, - LAPACKE_dppequ, - LAPACKE_dppequ_work, - LAPACKE_dpprfs, - LAPACKE_dpprfs_work, - LAPACKE_dppsv, - LAPACKE_dppsv_work, - LAPACKE_dppsvx, - LAPACKE_dppsvx_work, - LAPACKE_dpptrf, - LAPACKE_dpptrf_work, - LAPACKE_dpptri, - LAPACKE_dpptri_work, - LAPACKE_dpptrs, - LAPACKE_dpptrs_work, - LAPACKE_dpstrf, - LAPACKE_dpstrf_work, - LAPACKE_dptcon, - LAPACKE_dptcon_work, - LAPACKE_dpteqr, - LAPACKE_dpteqr_work, - LAPACKE_dptrfs, - LAPACKE_dptrfs_work, - LAPACKE_dptsv, - LAPACKE_dptsv_work, - LAPACKE_dptsvx, - LAPACKE_dptsvx_work, - LAPACKE_dpttrf, - LAPACKE_dpttrf_work, - LAPACKE_dpttrs, - LAPACKE_dpttrs_work, - LAPACKE_dsbev, - LAPACKE_dsbev_work, - LAPACKE_dsbevd, - LAPACKE_dsbevd_work, - LAPACKE_dsbevx, - LAPACKE_dsbevx_work, - LAPACKE_dsbgst, - LAPACKE_dsbgst_work, - LAPACKE_dsbgv, - LAPACKE_dsbgv_work, - LAPACKE_dsbgvd, - LAPACKE_dsbgvd_work, - LAPACKE_dsbgvx, - LAPACKE_dsbgvx_work, - LAPACKE_dsbtrd, - LAPACKE_dsbtrd_work, - LAPACKE_dsfrk, - LAPACKE_dsfrk_work, - LAPACKE_dsgesv, - LAPACKE_dsgesv_work, - LAPACKE_dspcon, - LAPACKE_dspcon_work, - LAPACKE_dspev, - LAPACKE_dspev_work, - LAPACKE_dspevd, - LAPACKE_dspevd_work, - LAPACKE_dspevx, - LAPACKE_dspevx_work, - LAPACKE_dspgst, - LAPACKE_dspgst_work, - LAPACKE_dspgv, - LAPACKE_dspgv_work, - LAPACKE_dspgvd, - LAPACKE_dspgvd_work, - LAPACKE_dspgvx, - LAPACKE_dspgvx_work, - LAPACKE_dsposv, - LAPACKE_dsposv_work, - LAPACKE_dsprfs, - LAPACKE_dsprfs_work, - LAPACKE_dspsv, - LAPACKE_dspsv_work, - LAPACKE_dspsvx, - LAPACKE_dspsvx_work, - LAPACKE_dsptrd, - LAPACKE_dsptrd_work, - LAPACKE_dsptrf, - LAPACKE_dsptrf_work, - LAPACKE_dsptri, - LAPACKE_dsptri_work, - LAPACKE_dsptrs, - LAPACKE_dsptrs_work, - LAPACKE_dstebz, - LAPACKE_dstebz_work, - LAPACKE_dstedc, - LAPACKE_dstedc_work, - LAPACKE_dstegr, - LAPACKE_dstegr_work, - LAPACKE_dstein, - LAPACKE_dstein_work, - LAPACKE_dstemr, - LAPACKE_dstemr_work, - LAPACKE_dsteqr, - LAPACKE_dsteqr_work, - LAPACKE_dsterf, - LAPACKE_dsterf_work, - LAPACKE_dstev, - LAPACKE_dstev_work, - LAPACKE_dstevd, - LAPACKE_dstevd_work, - LAPACKE_dstevr, - LAPACKE_dstevr_work, - LAPACKE_dstevx, - LAPACKE_dstevx_work, - LAPACKE_dsycon, - LAPACKE_dsycon_work, - LAPACKE_dsyconv, - LAPACKE_dsyconv_work, - LAPACKE_dsyequb, - LAPACKE_dsyequb_work, - LAPACKE_dsyev, - LAPACKE_dsyev_work, - LAPACKE_dsyevd, - LAPACKE_dsyevd_work, - LAPACKE_dsyevr, - LAPACKE_dsyevr_work, - LAPACKE_dsyevx, - LAPACKE_dsyevx_work, - LAPACKE_dsygst, - LAPACKE_dsygst_work, - LAPACKE_dsygv, - LAPACKE_dsygv_work, - LAPACKE_dsygvd, - LAPACKE_dsygvd_work, - LAPACKE_dsygvx, - LAPACKE_dsygvx_work, - LAPACKE_dsyrfs, - LAPACKE_dsyrfs_work, - LAPACKE_dsysv, - LAPACKE_dsysv_work, - LAPACKE_dsysvx, - LAPACKE_dsysvx_work, - LAPACKE_dsyswapr, - LAPACKE_dsyswapr_work, - LAPACKE_dsytrd, - LAPACKE_dsytrd_work, - LAPACKE_dsytrf, - LAPACKE_dsytrf_work, - LAPACKE_dsytri, - LAPACKE_dsytri2, - LAPACKE_dsytri2_work, - LAPACKE_dsytri2x, - LAPACKE_dsytri2x_work, - LAPACKE_dsytri_work, - LAPACKE_dsytrs, - LAPACKE_dsytrs2, - LAPACKE_dsytrs2_work, - LAPACKE_dsytrs_work, - LAPACKE_dtbcon, - LAPACKE_dtbcon_work, - LAPACKE_dtbrfs, - LAPACKE_dtbrfs_work, - LAPACKE_dtbtrs, - LAPACKE_dtbtrs_work, - LAPACKE_dtfsm, - LAPACKE_dtfsm_work, - LAPACKE_dtftri, - LAPACKE_dtftri_work, - LAPACKE_dtfttp, - LAPACKE_dtfttp_work, - LAPACKE_dtfttr, - LAPACKE_dtfttr_work, - LAPACKE_dtgevc, - LAPACKE_dtgevc_work, - LAPACKE_dtgexc, - LAPACKE_dtgexc_work, - LAPACKE_dtgsen, - LAPACKE_dtgsen_work, - LAPACKE_dtgsja, - LAPACKE_dtgsja_work, - LAPACKE_dtgsna, - LAPACKE_dtgsna_work, - LAPACKE_dtgsyl, - LAPACKE_dtgsyl_work, - LAPACKE_dtpcon, - LAPACKE_dtpcon_work, - LAPACKE_dtpmqrt, - LAPACKE_dtpmqrt_work, - LAPACKE_dtpqrt, - LAPACKE_dtpqrt2, - LAPACKE_dtpqrt2_work, - LAPACKE_dtpqrt_work, - LAPACKE_dtprfb, - LAPACKE_dtprfb_work, - LAPACKE_dtprfs, - LAPACKE_dtprfs_work, - LAPACKE_dtptri, - LAPACKE_dtptri_work, - LAPACKE_dtptrs, - LAPACKE_dtptrs_work, - LAPACKE_dtpttf, - LAPACKE_dtpttf_work, - LAPACKE_dtpttr, - LAPACKE_dtpttr_work, - LAPACKE_dtrcon, - LAPACKE_dtrcon_work, - LAPACKE_dtrevc, - LAPACKE_dtrevc_work, - LAPACKE_dtrexc, - LAPACKE_dtrexc_work, - LAPACKE_dtrrfs, - LAPACKE_dtrrfs_work, - LAPACKE_dtrsen, - LAPACKE_dtrsen_work, - LAPACKE_dtrsna, - LAPACKE_dtrsna_work, - LAPACKE_dtrsyl, - LAPACKE_dtrsyl_work, - LAPACKE_dtrtri, - LAPACKE_dtrtri_work, - LAPACKE_dtrtrs, - LAPACKE_dtrtrs_work, - LAPACKE_dtrttf, - LAPACKE_dtrttf_work, - LAPACKE_dtrttp, - LAPACKE_dtrttp_work, - LAPACKE_dtzrzf, - LAPACKE_dtzrzf_work, - LAPACKE_sbbcsd, - LAPACKE_sbbcsd_work, - LAPACKE_sbdsdc, - LAPACKE_sbdsdc_work, - LAPACKE_sbdsqr, - LAPACKE_sbdsqr_work, - LAPACKE_sdisna, - LAPACKE_sdisna_work, - LAPACKE_sgbbrd, - LAPACKE_sgbbrd_work, - LAPACKE_sgbcon, - LAPACKE_sgbcon_work, - LAPACKE_sgbequ, - LAPACKE_sgbequ_work, - LAPACKE_sgbequb, - LAPACKE_sgbequb_work, - LAPACKE_sgbrfs, - LAPACKE_sgbrfs_work, - LAPACKE_sgbsv, - LAPACKE_sgbsv_work, - LAPACKE_sgbsvx, - LAPACKE_sgbsvx_work, - LAPACKE_sgbtrf, - LAPACKE_sgbtrf_work, - LAPACKE_sgbtrs, - LAPACKE_sgbtrs_work, - LAPACKE_sgebak, - LAPACKE_sgebak_work, - LAPACKE_sgebal, - LAPACKE_sgebal_work, - LAPACKE_sgebrd, - LAPACKE_sgebrd_work, - LAPACKE_sgecon, - LAPACKE_sgecon_work, - LAPACKE_sgeequ, - LAPACKE_sgeequ_work, - LAPACKE_sgeequb, - LAPACKE_sgeequb_work, - LAPACKE_sgees, - LAPACKE_sgees_work, - LAPACKE_sgeesx, - LAPACKE_sgeesx_work, - LAPACKE_sgeev, - LAPACKE_sgeev_work, - LAPACKE_sgeevx, - LAPACKE_sgeevx_work, - LAPACKE_sgehrd, - LAPACKE_sgehrd_work, - LAPACKE_sgejsv, - LAPACKE_sgejsv_work, - LAPACKE_sgelq2, - LAPACKE_sgelq2_work, - LAPACKE_sgelqf, - LAPACKE_sgelqf_work, - LAPACKE_sgels, - LAPACKE_sgels_work, - LAPACKE_sgelsd, - LAPACKE_sgelsd_work, - LAPACKE_sgelss, - LAPACKE_sgelss_work, - LAPACKE_sgelsy, - LAPACKE_sgelsy_work, - LAPACKE_sgemqrt, - LAPACKE_sgemqrt_work, - LAPACKE_sgeqlf, - LAPACKE_sgeqlf_work, - LAPACKE_sgeqp3, - LAPACKE_sgeqp3_work, - LAPACKE_sgeqpf, - LAPACKE_sgeqpf_work, - LAPACKE_sgeqr2, - LAPACKE_sgeqr2_work, - LAPACKE_sgeqrf, - LAPACKE_sgeqrf_work, - LAPACKE_sgeqrfp, - LAPACKE_sgeqrfp_work, - LAPACKE_sgeqrt, - LAPACKE_sgeqrt2, - LAPACKE_sgeqrt2_work, - LAPACKE_sgeqrt3, - LAPACKE_sgeqrt3_work, - LAPACKE_sgeqrt_work, - LAPACKE_sgerfs, - LAPACKE_sgerfs_work, - LAPACKE_sgerqf, - LAPACKE_sgerqf_work, - LAPACKE_sgesdd, - LAPACKE_sgesdd_work, - LAPACKE_sgesv, - LAPACKE_sgesv_work, - LAPACKE_sgesvd, - LAPACKE_sgesvd_work, - LAPACKE_sgesvj, - LAPACKE_sgesvj_work, - LAPACKE_sgesvx, - LAPACKE_sgesvx_work, - LAPACKE_sgetf2, - LAPACKE_sgetf2_work, - LAPACKE_sgetrf, - LAPACKE_sgetrf_work, - LAPACKE_sgetri, - LAPACKE_sgetri_work, - LAPACKE_sgetrs, - LAPACKE_sgetrs_work, - LAPACKE_sggbak, - LAPACKE_sggbak_work, - LAPACKE_sggbal, - LAPACKE_sggbal_work, - LAPACKE_sgges, - LAPACKE_sgges_work, - LAPACKE_sggesx, - LAPACKE_sggesx_work, - LAPACKE_sggev, - LAPACKE_sggev_work, - LAPACKE_sggevx, - LAPACKE_sggevx_work, - LAPACKE_sggglm, - LAPACKE_sggglm_work, - LAPACKE_sgghrd, - LAPACKE_sgghrd_work, - LAPACKE_sgglse, - LAPACKE_sgglse_work, - LAPACKE_sggqrf, - LAPACKE_sggqrf_work, - LAPACKE_sggrqf, - LAPACKE_sggrqf_work, - LAPACKE_sggsvd, - LAPACKE_sggsvd_work, - LAPACKE_sggsvp, - LAPACKE_sggsvp_work, - LAPACKE_sgtcon, - LAPACKE_sgtcon_work, - LAPACKE_sgtrfs, - LAPACKE_sgtrfs_work, - LAPACKE_sgtsv, - LAPACKE_sgtsv_work, - LAPACKE_sgtsvx, - LAPACKE_sgtsvx_work, - LAPACKE_sgttrf, - LAPACKE_sgttrf_work, - LAPACKE_sgttrs, - LAPACKE_sgttrs_work, - LAPACKE_shgeqz, - LAPACKE_shgeqz_work, - LAPACKE_shsein, - LAPACKE_shsein_work, - LAPACKE_shseqr, - LAPACKE_shseqr_work, - LAPACKE_slacpy, - LAPACKE_slacpy_work, - LAPACKE_slag2d, - LAPACKE_slag2d_work, - LAPACKE_slamch, - LAPACKE_slamch_work, - LAPACKE_slange, - LAPACKE_slange_work, - LAPACKE_slansy, - LAPACKE_slansy_work, - LAPACKE_slantr, - LAPACKE_slantr_work, - LAPACKE_slapmr, - LAPACKE_slapmr_work, - LAPACKE_slapy2, - LAPACKE_slapy2_work, - LAPACKE_slapy3, - LAPACKE_slapy3_work, - LAPACKE_slarfb, - LAPACKE_slarfb_work, - LAPACKE_slarfg, - LAPACKE_slarfg_work, - LAPACKE_slarft, - LAPACKE_slarft_work, - LAPACKE_slarfx, - LAPACKE_slarfx_work, - LAPACKE_slarnv, - LAPACKE_slarnv_work, - LAPACKE_slartgp, - LAPACKE_slartgp_work, - LAPACKE_slartgs, - LAPACKE_slartgs_work, - LAPACKE_slaset, - LAPACKE_slaset_work, - LAPACKE_slasrt, - LAPACKE_slasrt_work, - LAPACKE_slaswp, - LAPACKE_slaswp_work, - LAPACKE_slauum, - LAPACKE_slauum_work, - LAPACKE_sopgtr, - LAPACKE_sopgtr_work, - LAPACKE_sopmtr, - LAPACKE_sopmtr_work, - LAPACKE_sorbdb, - LAPACKE_sorbdb_work, - LAPACKE_sorcsd, - LAPACKE_sorcsd_work, - LAPACKE_sorgbr, - LAPACKE_sorgbr_work, - LAPACKE_sorghr, - LAPACKE_sorghr_work, - LAPACKE_sorglq, - LAPACKE_sorglq_work, - LAPACKE_sorgql, - LAPACKE_sorgql_work, - LAPACKE_sorgqr, - LAPACKE_sorgqr_work, - LAPACKE_sorgrq, - LAPACKE_sorgrq_work, - LAPACKE_sorgtr, - LAPACKE_sorgtr_work, - LAPACKE_sormbr, - LAPACKE_sormbr_work, - LAPACKE_sormhr, - LAPACKE_sormhr_work, - LAPACKE_sormlq, - LAPACKE_sormlq_work, - LAPACKE_sormql, - LAPACKE_sormql_work, - LAPACKE_sormqr, - LAPACKE_sormqr_work, - LAPACKE_sormrq, - LAPACKE_sormrq_work, - LAPACKE_sormrz, - LAPACKE_sormrz_work, - LAPACKE_sormtr, - LAPACKE_sormtr_work, - LAPACKE_spbcon, - LAPACKE_spbcon_work, - LAPACKE_spbequ, - LAPACKE_spbequ_work, - LAPACKE_spbrfs, - LAPACKE_spbrfs_work, - LAPACKE_spbstf, - LAPACKE_spbstf_work, - LAPACKE_spbsv, - LAPACKE_spbsv_work, - LAPACKE_spbsvx, - LAPACKE_spbsvx_work, - LAPACKE_spbtrf, - LAPACKE_spbtrf_work, - LAPACKE_spbtrs, - LAPACKE_spbtrs_work, - LAPACKE_spftrf, - LAPACKE_spftrf_work, - LAPACKE_spftri, - LAPACKE_spftri_work, - LAPACKE_spftrs, - LAPACKE_spftrs_work, - LAPACKE_spocon, - LAPACKE_spocon_work, - LAPACKE_spoequ, - LAPACKE_spoequ_work, - LAPACKE_spoequb, - LAPACKE_spoequb_work, - LAPACKE_sporfs, - LAPACKE_sporfs_work, - LAPACKE_sposv, - LAPACKE_sposv_work, - LAPACKE_sposvx, - LAPACKE_sposvx_work, - LAPACKE_spotrf, - LAPACKE_spotrf_work, - LAPACKE_spotri, - LAPACKE_spotri_work, - LAPACKE_spotrs, - LAPACKE_spotrs_work, - LAPACKE_sppcon, - LAPACKE_sppcon_work, - LAPACKE_sppequ, - LAPACKE_sppequ_work, - LAPACKE_spprfs, - LAPACKE_spprfs_work, - LAPACKE_sppsv, - LAPACKE_sppsv_work, - LAPACKE_sppsvx, - LAPACKE_sppsvx_work, - LAPACKE_spptrf, - LAPACKE_spptrf_work, - LAPACKE_spptri, - LAPACKE_spptri_work, - LAPACKE_spptrs, - LAPACKE_spptrs_work, - LAPACKE_spstrf, - LAPACKE_spstrf_work, - LAPACKE_sptcon, - LAPACKE_sptcon_work, - LAPACKE_spteqr, - LAPACKE_spteqr_work, - LAPACKE_sptrfs, - LAPACKE_sptrfs_work, - LAPACKE_sptsv, - LAPACKE_sptsv_work, - LAPACKE_sptsvx, - LAPACKE_sptsvx_work, - LAPACKE_spttrf, - LAPACKE_spttrf_work, - LAPACKE_spttrs, - LAPACKE_spttrs_work, - LAPACKE_ssbev, - LAPACKE_ssbev_work, - LAPACKE_ssbevd, - LAPACKE_ssbevd_work, - LAPACKE_ssbevx, - LAPACKE_ssbevx_work, - LAPACKE_ssbgst, - LAPACKE_ssbgst_work, - LAPACKE_ssbgv, - LAPACKE_ssbgv_work, - LAPACKE_ssbgvd, - LAPACKE_ssbgvd_work, - LAPACKE_ssbgvx, - LAPACKE_ssbgvx_work, - LAPACKE_ssbtrd, - LAPACKE_ssbtrd_work, - LAPACKE_ssfrk, - LAPACKE_ssfrk_work, - LAPACKE_sspcon, - LAPACKE_sspcon_work, - LAPACKE_sspev, - LAPACKE_sspev_work, - LAPACKE_sspevd, - LAPACKE_sspevd_work, - LAPACKE_sspevx, - LAPACKE_sspevx_work, - LAPACKE_sspgst, - LAPACKE_sspgst_work, - LAPACKE_sspgv, - LAPACKE_sspgv_work, - LAPACKE_sspgvd, - LAPACKE_sspgvd_work, - LAPACKE_sspgvx, - LAPACKE_sspgvx_work, - LAPACKE_ssprfs, - LAPACKE_ssprfs_work, - LAPACKE_sspsv, - LAPACKE_sspsv_work, - LAPACKE_sspsvx, - LAPACKE_sspsvx_work, - LAPACKE_ssptrd, - LAPACKE_ssptrd_work, - LAPACKE_ssptrf, - LAPACKE_ssptrf_work, - LAPACKE_ssptri, - LAPACKE_ssptri_work, - LAPACKE_ssptrs, - LAPACKE_ssptrs_work, - LAPACKE_sstebz, - LAPACKE_sstebz_work, - LAPACKE_sstedc, - LAPACKE_sstedc_work, - LAPACKE_sstegr, - LAPACKE_sstegr_work, - LAPACKE_sstein, - LAPACKE_sstein_work, - LAPACKE_sstemr, - LAPACKE_sstemr_work, - LAPACKE_ssteqr, - LAPACKE_ssteqr_work, - LAPACKE_ssterf, - LAPACKE_ssterf_work, - LAPACKE_sstev, - LAPACKE_sstev_work, - LAPACKE_sstevd, - LAPACKE_sstevd_work, - LAPACKE_sstevr, - LAPACKE_sstevr_work, - LAPACKE_sstevx, - LAPACKE_sstevx_work, - LAPACKE_ssycon, - LAPACKE_ssycon_work, - LAPACKE_ssyconv, - LAPACKE_ssyconv_work, - LAPACKE_ssyequb, - LAPACKE_ssyequb_work, - LAPACKE_ssyev, - LAPACKE_ssyev_work, - LAPACKE_ssyevd, - LAPACKE_ssyevd_work, - LAPACKE_ssyevr, - LAPACKE_ssyevr_work, - LAPACKE_ssyevx, - LAPACKE_ssyevx_work, - LAPACKE_ssygst, - LAPACKE_ssygst_work, - LAPACKE_ssygv, - LAPACKE_ssygv_work, - LAPACKE_ssygvd, - LAPACKE_ssygvd_work, - LAPACKE_ssygvx, - LAPACKE_ssygvx_work, - LAPACKE_ssyrfs, - LAPACKE_ssyrfs_work, - LAPACKE_ssysv, - LAPACKE_ssysv_work, - LAPACKE_ssysvx, - LAPACKE_ssysvx_work, - LAPACKE_ssyswapr, - LAPACKE_ssyswapr_work, - LAPACKE_ssytrd, - LAPACKE_ssytrd_work, - LAPACKE_ssytrf, - LAPACKE_ssytrf_work, - LAPACKE_ssytri, - LAPACKE_ssytri2, - LAPACKE_ssytri2_work, - LAPACKE_ssytri2x, - LAPACKE_ssytri2x_work, - LAPACKE_ssytri_work, - LAPACKE_ssytrs, - LAPACKE_ssytrs2, - LAPACKE_ssytrs2_work, - LAPACKE_ssytrs_work, - LAPACKE_stbcon, - LAPACKE_stbcon_work, - LAPACKE_stbrfs, - LAPACKE_stbrfs_work, - LAPACKE_stbtrs, - LAPACKE_stbtrs_work, - LAPACKE_stfsm, - LAPACKE_stfsm_work, - LAPACKE_stftri, - LAPACKE_stftri_work, - LAPACKE_stfttp, - LAPACKE_stfttp_work, - LAPACKE_stfttr, - LAPACKE_stfttr_work, - LAPACKE_stgevc, - LAPACKE_stgevc_work, - LAPACKE_stgexc, - LAPACKE_stgexc_work, - LAPACKE_stgsen, - LAPACKE_stgsen_work, - LAPACKE_stgsja, - LAPACKE_stgsja_work, - LAPACKE_stgsna, - LAPACKE_stgsna_work, - LAPACKE_stgsyl, - LAPACKE_stgsyl_work, - LAPACKE_stpcon, - LAPACKE_stpcon_work, - LAPACKE_stpmqrt, - LAPACKE_stpmqrt_work, - LAPACKE_stpqrt2, - LAPACKE_stpqrt2_work, - LAPACKE_stprfb, - LAPACKE_stprfb_work, - LAPACKE_stprfs, - LAPACKE_stprfs_work, - LAPACKE_stptri, - LAPACKE_stptri_work, - LAPACKE_stptrs, - LAPACKE_stptrs_work, - LAPACKE_stpttf, - LAPACKE_stpttf_work, - LAPACKE_stpttr, - LAPACKE_stpttr_work, - LAPACKE_strcon, - LAPACKE_strcon_work, - LAPACKE_strevc, - LAPACKE_strevc_work, - LAPACKE_strexc, - LAPACKE_strexc_work, - LAPACKE_strrfs, - LAPACKE_strrfs_work, - LAPACKE_strsen, - LAPACKE_strsen_work, - LAPACKE_strsna, - LAPACKE_strsna_work, - LAPACKE_strsyl, - LAPACKE_strsyl_work, - LAPACKE_strtri, - LAPACKE_strtri_work, - LAPACKE_strtrs, - LAPACKE_strtrs_work, - LAPACKE_strttf, - LAPACKE_strttf_work, - LAPACKE_strttp, - LAPACKE_strttp_work, - LAPACKE_stzrzf, - LAPACKE_stzrzf_work, - LAPACKE_zbbcsd, - LAPACKE_zbbcsd_work, - LAPACKE_zbdsqr, - LAPACKE_zbdsqr_work, - LAPACKE_zcgesv, - LAPACKE_zcgesv_work, - LAPACKE_zcposv, - LAPACKE_zcposv_work, - LAPACKE_zgbbrd, - LAPACKE_zgbbrd_work, - LAPACKE_zgbcon, - LAPACKE_zgbcon_work, - LAPACKE_zgbequ, - LAPACKE_zgbequ_work, - LAPACKE_zgbequb, - LAPACKE_zgbequb_work, - LAPACKE_zgbrfs, - LAPACKE_zgbrfs_work, - LAPACKE_zgbsv, - LAPACKE_zgbsv_work, - LAPACKE_zgbsvx, - LAPACKE_zgbsvx_work, - LAPACKE_zgbtrf, - LAPACKE_zgbtrf_work, - LAPACKE_zgbtrs, - LAPACKE_zgbtrs_work, - LAPACKE_zgebak, - LAPACKE_zgebak_work, - LAPACKE_zgebal, - LAPACKE_zgebal_work, - LAPACKE_zgebrd, - LAPACKE_zgebrd_work, - LAPACKE_zgecon, - LAPACKE_zgecon_work, - LAPACKE_zgeequ, - LAPACKE_zgeequ_work, - LAPACKE_zgeequb, - LAPACKE_zgeequb_work, - LAPACKE_zgees, - LAPACKE_zgees_work, - LAPACKE_zgeesx, - LAPACKE_zgeesx_work, - LAPACKE_zgeev, - LAPACKE_zgeev_work, - LAPACKE_zgeevx, - LAPACKE_zgeevx_work, - LAPACKE_zgehrd, - LAPACKE_zgehrd_work, - LAPACKE_zgelq2, - LAPACKE_zgelq2_work, - LAPACKE_zgelqf, - LAPACKE_zgelqf_work, - LAPACKE_zgels, - LAPACKE_zgels_work, - LAPACKE_zgelsd, - LAPACKE_zgelsd_work, - LAPACKE_zgelss, - LAPACKE_zgelss_work, - LAPACKE_zgelsy, - LAPACKE_zgelsy_work, - LAPACKE_zgemqrt, - LAPACKE_zgemqrt_work, - LAPACKE_zgeqlf, - LAPACKE_zgeqlf_work, - LAPACKE_zgeqp3, - LAPACKE_zgeqp3_work, - LAPACKE_zgeqpf, - LAPACKE_zgeqpf_work, - LAPACKE_zgeqr2, - LAPACKE_zgeqr2_work, - LAPACKE_zgeqrf, - LAPACKE_zgeqrf_work, - LAPACKE_zgeqrfp, - LAPACKE_zgeqrfp_work, - LAPACKE_zgeqrt, - LAPACKE_zgeqrt2, - LAPACKE_zgeqrt2_work, - LAPACKE_zgeqrt3, - LAPACKE_zgeqrt3_work, - LAPACKE_zgeqrt_work, - LAPACKE_zgerfs, - LAPACKE_zgerfs_work, - LAPACKE_zgerqf, - LAPACKE_zgerqf_work, - LAPACKE_zgesdd, - LAPACKE_zgesdd_work, - LAPACKE_zgesv, - LAPACKE_zgesv_work, - LAPACKE_zgesvd, - LAPACKE_zgesvd_work, - LAPACKE_zgesvx, - LAPACKE_zgesvx_work, - LAPACKE_zgetf2, - LAPACKE_zgetf2_work, - LAPACKE_zgetrf, - LAPACKE_zgetrf_work, - LAPACKE_zgetri, - LAPACKE_zgetri_work, - LAPACKE_zgetrs, - LAPACKE_zgetrs_work, - LAPACKE_zggbak, - LAPACKE_zggbak_work, - LAPACKE_zggbal, - LAPACKE_zggbal_work, - LAPACKE_zgges, - LAPACKE_zgges_work, - LAPACKE_zggesx, - LAPACKE_zggesx_work, - LAPACKE_zggev, - LAPACKE_zggev_work, - LAPACKE_zggevx, - LAPACKE_zggevx_work, - LAPACKE_zggglm, - LAPACKE_zggglm_work, - LAPACKE_zgghrd, - LAPACKE_zgghrd_work, - LAPACKE_zgglse, - LAPACKE_zgglse_work, - LAPACKE_zggqrf, - LAPACKE_zggqrf_work, - LAPACKE_zggrqf, - LAPACKE_zggrqf_work, - LAPACKE_zggsvd, - LAPACKE_zggsvd_work, - LAPACKE_zggsvp, - LAPACKE_zggsvp_work, - LAPACKE_zgtcon, - LAPACKE_zgtcon_work, - LAPACKE_zgtrfs, - LAPACKE_zgtrfs_work, - LAPACKE_zgtsv, - LAPACKE_zgtsv_work, - LAPACKE_zgtsvx, - LAPACKE_zgtsvx_work, - LAPACKE_zgttrf, - LAPACKE_zgttrf_work, - LAPACKE_zgttrs, - LAPACKE_zgttrs_work, - LAPACKE_zhbev, - LAPACKE_zhbev_work, - LAPACKE_zhbevd, - LAPACKE_zhbevd_work, - LAPACKE_zhbevx, - LAPACKE_zhbevx_work, - LAPACKE_zhbgst, - LAPACKE_zhbgst_work, - LAPACKE_zhbgv, - LAPACKE_zhbgv_work, - LAPACKE_zhbgvd, - LAPACKE_zhbgvd_work, - LAPACKE_zhbgvx, - LAPACKE_zhbgvx_work, - LAPACKE_zhbtrd, - LAPACKE_zhbtrd_work, - LAPACKE_zhecon, - LAPACKE_zhecon_work, - LAPACKE_zheequb, - LAPACKE_zheequb_work, - LAPACKE_zheev, - LAPACKE_zheev_work, - LAPACKE_zheevd, - LAPACKE_zheevd_work, - LAPACKE_zheevr, - LAPACKE_zheevr_work, - LAPACKE_zheevx, - LAPACKE_zheevx_work, - LAPACKE_zhegst, - LAPACKE_zhegst_work, - LAPACKE_zhegv, - LAPACKE_zhegv_work, - LAPACKE_zhegvd, - LAPACKE_zhegvd_work, - LAPACKE_zhegvx, - LAPACKE_zhegvx_work, - LAPACKE_zherfs, - LAPACKE_zherfs_work, - LAPACKE_zhesv, - LAPACKE_zhesv_work, - LAPACKE_zhesvx, - LAPACKE_zhesvx_work, - LAPACKE_zheswapr, - LAPACKE_zheswapr_work, - LAPACKE_zhetrd, - LAPACKE_zhetrd_work, - LAPACKE_zhetrf, - LAPACKE_zhetrf_work, - LAPACKE_zhetri, - LAPACKE_zhetri2, - LAPACKE_zhetri2_work, - LAPACKE_zhetri2x, - LAPACKE_zhetri2x_work, - LAPACKE_zhetri_work, - LAPACKE_zhetrs, - LAPACKE_zhetrs2, - LAPACKE_zhetrs2_work, - LAPACKE_zhetrs_work, - LAPACKE_zhfrk, - LAPACKE_zhfrk_work, - LAPACKE_zhgeqz, - LAPACKE_zhgeqz_work, - LAPACKE_zhpcon, - LAPACKE_zhpcon_work, - LAPACKE_zhpev, - LAPACKE_zhpev_work, - LAPACKE_zhpevd, - LAPACKE_zhpevd_work, - LAPACKE_zhpevx, - LAPACKE_zhpevx_work, - LAPACKE_zhpgst, - LAPACKE_zhpgst_work, - LAPACKE_zhpgv, - LAPACKE_zhpgv_work, - LAPACKE_zhpgvd, - LAPACKE_zhpgvd_work, - LAPACKE_zhpgvx, - LAPACKE_zhpgvx_work, - LAPACKE_zhprfs, - LAPACKE_zhprfs_work, - LAPACKE_zhpsv, - LAPACKE_zhpsv_work, - LAPACKE_zhpsvx, - LAPACKE_zhpsvx_work, - LAPACKE_zhptrd, - LAPACKE_zhptrd_work, - LAPACKE_zhptrf, - LAPACKE_zhptrf_work, - LAPACKE_zhptri, - LAPACKE_zhptri_work, - LAPACKE_zhptrs, - LAPACKE_zhptrs_work, - LAPACKE_zhsein, - LAPACKE_zhsein_work, - LAPACKE_zhseqr, - LAPACKE_zhseqr_work, - LAPACKE_zlacgv, - LAPACKE_zlacgv_work, - LAPACKE_zlacpy, - LAPACKE_zlacpy_work, - LAPACKE_zlag2c, - LAPACKE_zlag2c_work, - LAPACKE_zlange, - LAPACKE_zlange_work, - LAPACKE_zlanhe, - LAPACKE_zlanhe_work, - LAPACKE_zlansy, - LAPACKE_zlansy_work, - LAPACKE_zlantr, - LAPACKE_zlantr_work, - LAPACKE_zlapmr, - LAPACKE_zlapmr_work, - LAPACKE_zlarfb, - LAPACKE_zlarfb_work, - LAPACKE_zlarfg, - LAPACKE_zlarfg_work, - LAPACKE_zlarft, - LAPACKE_zlarft_work, - LAPACKE_zlarfx, - LAPACKE_zlarfx_work, - LAPACKE_zlarnv, - LAPACKE_zlarnv_work, - LAPACKE_zlaset, - LAPACKE_zlaset_work, - LAPACKE_zlaswp, - LAPACKE_zlaswp_work, - LAPACKE_zlauum, - LAPACKE_zlauum_work, - LAPACKE_zpbcon, - LAPACKE_zpbcon_work, - LAPACKE_zpbequ, - LAPACKE_zpbequ_work, - LAPACKE_zpbrfs, - LAPACKE_zpbrfs_work, - LAPACKE_zpbstf, - LAPACKE_zpbstf_work, - LAPACKE_zpbsv, - LAPACKE_zpbsv_work, - LAPACKE_zpbsvx, - LAPACKE_zpbsvx_work, - LAPACKE_zpbtrf, - LAPACKE_zpbtrf_work, - LAPACKE_zpbtrs, - LAPACKE_zpbtrs_work, - LAPACKE_zpftrf, - LAPACKE_zpftrf_work, - LAPACKE_zpftri, - LAPACKE_zpftri_work, - LAPACKE_zpftrs, - LAPACKE_zpftrs_work, - LAPACKE_zpocon, - LAPACKE_zpocon_work, - LAPACKE_zpoequ, - LAPACKE_zpoequ_work, - LAPACKE_zpoequb, - LAPACKE_zpoequb_work, - LAPACKE_zporfs, - LAPACKE_zporfs_work, - LAPACKE_zposv, - LAPACKE_zposv_work, - LAPACKE_zposvx, - LAPACKE_zposvx_work, - LAPACKE_zpotrf, - LAPACKE_zpotrf_work, - LAPACKE_zpotri, - LAPACKE_zpotri_work, - LAPACKE_zpotrs, - LAPACKE_zpotrs_work, - LAPACKE_zppcon, - LAPACKE_zppcon_work, - LAPACKE_zppequ, - LAPACKE_zppequ_work, - LAPACKE_zpprfs, - LAPACKE_zpprfs_work, - LAPACKE_zppsv, - LAPACKE_zppsv_work, - LAPACKE_zppsvx, - LAPACKE_zppsvx_work, - LAPACKE_zpptrf, - LAPACKE_zpptrf_work, - LAPACKE_zpptri, - LAPACKE_zpptri_work, - LAPACKE_zpptrs, - LAPACKE_zpptrs_work, - LAPACKE_zpstrf, - LAPACKE_zpstrf_work, - LAPACKE_zptcon, - LAPACKE_zptcon_work, - LAPACKE_zpteqr, - LAPACKE_zpteqr_work, - LAPACKE_zptrfs, - LAPACKE_zptrfs_work, - LAPACKE_zptsv, - LAPACKE_zptsv_work, - LAPACKE_zptsvx, - LAPACKE_zptsvx_work, - LAPACKE_zpttrf, - LAPACKE_zpttrf_work, - LAPACKE_zpttrs, - LAPACKE_zpttrs_work, - LAPACKE_zspcon, - LAPACKE_zspcon_work, - LAPACKE_zsprfs, - LAPACKE_zsprfs_work, - LAPACKE_zspsv, - LAPACKE_zspsv_work, - LAPACKE_zspsvx, - LAPACKE_zspsvx_work, - LAPACKE_zsptrf, - LAPACKE_zsptrf_work, - LAPACKE_zsptri, - LAPACKE_zsptri_work, - LAPACKE_zsptrs, - LAPACKE_zsptrs_work, - LAPACKE_zstedc, - LAPACKE_zstedc_work, - LAPACKE_zstegr, - LAPACKE_zstegr_work, - LAPACKE_zstein, - LAPACKE_zstein_work, - LAPACKE_zstemr, - LAPACKE_zstemr_work, - LAPACKE_zsteqr, - LAPACKE_zsteqr_work, - LAPACKE_zsycon, - LAPACKE_zsycon_work, - LAPACKE_zsyconv, - LAPACKE_zsyconv_work, - LAPACKE_zsyequb, - LAPACKE_zsyequb_work, - LAPACKE_zsyrfs, - LAPACKE_zsyrfs_work, - LAPACKE_zsysv, - LAPACKE_zsysv_work, - LAPACKE_zsysvx, - LAPACKE_zsysvx_work, - LAPACKE_zsyswapr, - LAPACKE_zsyswapr_work, - LAPACKE_zsytrf, - LAPACKE_zsytrf_work, - LAPACKE_zsytri, - LAPACKE_zsytri2, - LAPACKE_zsytri2_work, - LAPACKE_zsytri2x, - LAPACKE_zsytri2x_work, - LAPACKE_zsytri_work, - LAPACKE_zsytrs, - LAPACKE_zsytrs2, - LAPACKE_zsytrs2_work, - LAPACKE_zsytrs_work, - LAPACKE_ztbcon, - LAPACKE_ztbcon_work, - LAPACKE_ztbrfs, - LAPACKE_ztbrfs_work, - LAPACKE_ztbtrs, - LAPACKE_ztbtrs_work, - LAPACKE_ztfsm, - LAPACKE_ztfsm_work, - LAPACKE_ztftri, - LAPACKE_ztftri_work, - LAPACKE_ztfttp, - LAPACKE_ztfttp_work, - LAPACKE_ztfttr, - LAPACKE_ztfttr_work, - LAPACKE_ztgevc, - LAPACKE_ztgevc_work, - LAPACKE_ztgexc, - LAPACKE_ztgexc_work, - LAPACKE_ztgsen, - LAPACKE_ztgsen_work, - LAPACKE_ztgsja, - LAPACKE_ztgsja_work, - LAPACKE_ztgsna, - LAPACKE_ztgsna_work, - LAPACKE_ztgsyl, - LAPACKE_ztgsyl_work, - LAPACKE_ztpcon, - LAPACKE_ztpcon_work, - LAPACKE_ztpmqrt, - LAPACKE_ztpmqrt_work, - LAPACKE_ztpqrt, - LAPACKE_ztpqrt2, - LAPACKE_ztpqrt2_work, - LAPACKE_ztpqrt_work, - LAPACKE_ztprfb, - LAPACKE_ztprfb_work, - LAPACKE_ztprfs, - LAPACKE_ztprfs_work, - LAPACKE_ztptri, - LAPACKE_ztptri_work, - LAPACKE_ztptrs, - LAPACKE_ztptrs_work, - LAPACKE_ztpttf, - LAPACKE_ztpttf_work, - LAPACKE_ztpttr, - LAPACKE_ztpttr_work, - LAPACKE_ztrcon, - LAPACKE_ztrcon_work, - LAPACKE_ztrevc, - LAPACKE_ztrevc_work, - LAPACKE_ztrexc, - LAPACKE_ztrexc_work, - LAPACKE_ztrrfs, - LAPACKE_ztrrfs_work, - LAPACKE_ztrsen, - LAPACKE_ztrsen_work, - LAPACKE_ztrsna, - LAPACKE_ztrsna_work, - LAPACKE_ztrsyl, - LAPACKE_ztrsyl_work, - LAPACKE_ztrtri, - LAPACKE_ztrtri_work, - LAPACKE_ztrtrs, - LAPACKE_ztrtrs_work, - LAPACKE_ztrttf, - LAPACKE_ztrttf_work, - LAPACKE_ztrttp, - LAPACKE_ztrttp_work, - LAPACKE_ztzrzf, - LAPACKE_ztzrzf_work, - LAPACKE_zunbdb, - LAPACKE_zunbdb_work, - LAPACKE_zuncsd, - LAPACKE_zuncsd_work, - LAPACKE_zungbr, - LAPACKE_zungbr_work, - LAPACKE_zunghr, - LAPACKE_zunghr_work, - LAPACKE_zunglq, - LAPACKE_zunglq_work, - LAPACKE_zungql, - LAPACKE_zungql_work, - LAPACKE_zungqr, - LAPACKE_zungqr_work, - LAPACKE_zungrq, - LAPACKE_zungrq_work, - LAPACKE_zungtr, - LAPACKE_zungtr_work, - LAPACKE_zunmbr, - LAPACKE_zunmbr_work, - LAPACKE_zunmhr, - LAPACKE_zunmhr_work, - LAPACKE_zunmlq, - LAPACKE_zunmlq_work, - LAPACKE_zunmql, - LAPACKE_zunmql_work, - LAPACKE_zunmqr, - LAPACKE_zunmqr_work, - LAPACKE_zunmrq, - LAPACKE_zunmrq_work, - LAPACKE_zunmrz, - LAPACKE_zunmrz_work, - LAPACKE_zunmtr, - LAPACKE_zunmtr_work, - LAPACKE_zupgtr, - LAPACKE_zupgtr_work, - LAPACKE_zupmtr, - LAPACKE_zupmtr_work, - LAPACKE_zsyr, - LAPACKE_csyr, - LAPACKE_zsyr_work, - LAPACKE_csyr_work, + # @(SRC_OBJ) from `lapack-3.5.0/lapacke/src/Makefile` + LAPACKE_cbbcsd, + LAPACKE_cbbcsd_work, + LAPACKE_cbdsqr, + LAPACKE_cbdsqr_work, + LAPACKE_cgbbrd, + LAPACKE_cgbbrd_work, + LAPACKE_cgbcon, + LAPACKE_cgbcon_work, + LAPACKE_cgbequ, + LAPACKE_cgbequ_work, + LAPACKE_cgbequb, + LAPACKE_cgbequb_work, + LAPACKE_cgbrfs, + LAPACKE_cgbrfs_work, + LAPACKE_cgbsv, + LAPACKE_cgbsv_work, + LAPACKE_cgbsvx, + LAPACKE_cgbsvx_work, + LAPACKE_cgbtrf, + LAPACKE_cgbtrf_work, + LAPACKE_cgbtrs, + LAPACKE_cgbtrs_work, + LAPACKE_cgebak, + LAPACKE_cgebak_work, + LAPACKE_cgebal, + LAPACKE_cgebal_work, + LAPACKE_cgebrd, + LAPACKE_cgebrd_work, + LAPACKE_cgecon, + LAPACKE_cgecon_work, + LAPACKE_cgeequ, + LAPACKE_cgeequ_work, + LAPACKE_cgeequb, + LAPACKE_cgeequb_work, + LAPACKE_cgees, + LAPACKE_cgees_work, + LAPACKE_cgeesx, + LAPACKE_cgeesx_work, + LAPACKE_cgeev, + LAPACKE_cgeev_work, + LAPACKE_cgeevx, + LAPACKE_cgeevx_work, + LAPACKE_cgehrd, + LAPACKE_cgehrd_work, + LAPACKE_cgelq2, + LAPACKE_cgelq2_work, + LAPACKE_cgelqf, + LAPACKE_cgelqf_work, + LAPACKE_cgels, + LAPACKE_cgels_work, + LAPACKE_cgelsd, + LAPACKE_cgelsd_work, + LAPACKE_cgelss, + LAPACKE_cgelss_work, + LAPACKE_cgelsy, + LAPACKE_cgelsy_work, + LAPACKE_cgemqrt, + LAPACKE_cgemqrt_work, + LAPACKE_cgeqlf, + LAPACKE_cgeqlf_work, + LAPACKE_cgeqp3, + LAPACKE_cgeqp3_work, + LAPACKE_cgeqpf, + LAPACKE_cgeqpf_work, + LAPACKE_cgeqr2, + LAPACKE_cgeqr2_work, + LAPACKE_cgeqrf, + LAPACKE_cgeqrf_work, + LAPACKE_cgeqrfp, + LAPACKE_cgeqrfp_work, + LAPACKE_cgeqrt, + LAPACKE_cgeqrt2, + LAPACKE_cgeqrt2_work, + LAPACKE_cgeqrt3, + LAPACKE_cgeqrt3_work, + LAPACKE_cgeqrt_work, + LAPACKE_cgerfs, + LAPACKE_cgerfs_work, + LAPACKE_cgerqf, + LAPACKE_cgerqf_work, + LAPACKE_cgesdd, + LAPACKE_cgesdd_work, + LAPACKE_cgesv, + LAPACKE_cgesv_work, + LAPACKE_cgesvd, + LAPACKE_cgesvd_work, + LAPACKE_cgesvx, + LAPACKE_cgesvx_work, + LAPACKE_cgetf2, + LAPACKE_cgetf2_work, + LAPACKE_cgetrf, + LAPACKE_cgetrf_work, + LAPACKE_cgetri, + LAPACKE_cgetri_work, + LAPACKE_cgetrs, + LAPACKE_cgetrs_work, + LAPACKE_cggbak, + LAPACKE_cggbak_work, + LAPACKE_cggbal, + LAPACKE_cggbal_work, + LAPACKE_cgges, + LAPACKE_cgges_work, + LAPACKE_cggesx, + LAPACKE_cggesx_work, + LAPACKE_cggev, + LAPACKE_cggev_work, + LAPACKE_cggevx, + LAPACKE_cggevx_work, + LAPACKE_cggglm, + LAPACKE_cggglm_work, + LAPACKE_cgghrd, + LAPACKE_cgghrd_work, + LAPACKE_cgglse, + LAPACKE_cgglse_work, + LAPACKE_cggqrf, + LAPACKE_cggqrf_work, + LAPACKE_cggrqf, + LAPACKE_cggrqf_work, + LAPACKE_cggsvd, + LAPACKE_cggsvd_work, + LAPACKE_cggsvp, + LAPACKE_cggsvp_work, + LAPACKE_cgtcon, + LAPACKE_cgtcon_work, + LAPACKE_cgtrfs, + LAPACKE_cgtrfs_work, + LAPACKE_cgtsv, + LAPACKE_cgtsv_work, + LAPACKE_cgtsvx, + LAPACKE_cgtsvx_work, + LAPACKE_cgttrf, + LAPACKE_cgttrf_work, + LAPACKE_cgttrs, + LAPACKE_cgttrs_work, + LAPACKE_chbev, + LAPACKE_chbev_work, + LAPACKE_chbevd, + LAPACKE_chbevd_work, + LAPACKE_chbevx, + LAPACKE_chbevx_work, + LAPACKE_chbgst, + LAPACKE_chbgst_work, + LAPACKE_chbgv, + LAPACKE_chbgv_work, + LAPACKE_chbgvd, + LAPACKE_chbgvd_work, + LAPACKE_chbgvx, + LAPACKE_chbgvx_work, + LAPACKE_chbtrd, + LAPACKE_chbtrd_work, + LAPACKE_checon, + LAPACKE_checon_work, + LAPACKE_cheequb, + LAPACKE_cheequb_work, + LAPACKE_cheev, + LAPACKE_cheev_work, + LAPACKE_cheevd, + LAPACKE_cheevd_work, + LAPACKE_cheevr, + LAPACKE_cheevr_work, + LAPACKE_cheevx, + LAPACKE_cheevx_work, + LAPACKE_chegst, + LAPACKE_chegst_work, + LAPACKE_chegv, + LAPACKE_chegv_work, + LAPACKE_chegvd, + LAPACKE_chegvd_work, + LAPACKE_chegvx, + LAPACKE_chegvx_work, + LAPACKE_cherfs, + LAPACKE_cherfs_work, + LAPACKE_chesv, + LAPACKE_chesv_work, + LAPACKE_chesvx, + LAPACKE_chesvx_work, + LAPACKE_cheswapr, + LAPACKE_cheswapr_work, + LAPACKE_chetrd, + LAPACKE_chetrd_work, + LAPACKE_chetrf, + LAPACKE_chetrf_work, + LAPACKE_chetri, + LAPACKE_chetri2, + LAPACKE_chetri2_work, + LAPACKE_chetri2x, + LAPACKE_chetri2x_work, + LAPACKE_chetri_work, + LAPACKE_chetrs, + LAPACKE_chetrs2, + LAPACKE_chetrs2_work, + LAPACKE_chetrs_work, + LAPACKE_chfrk, + LAPACKE_chfrk_work, + LAPACKE_chgeqz, + LAPACKE_chgeqz_work, + LAPACKE_chpcon, + LAPACKE_chpcon_work, + LAPACKE_chpev, + LAPACKE_chpev_work, + LAPACKE_chpevd, + LAPACKE_chpevd_work, + LAPACKE_chpevx, + LAPACKE_chpevx_work, + LAPACKE_chpgst, + LAPACKE_chpgst_work, + LAPACKE_chpgv, + LAPACKE_chpgv_work, + LAPACKE_chpgvd, + LAPACKE_chpgvd_work, + LAPACKE_chpgvx, + LAPACKE_chpgvx_work, + LAPACKE_chprfs, + LAPACKE_chprfs_work, + LAPACKE_chpsv, + LAPACKE_chpsv_work, + LAPACKE_chpsvx, + LAPACKE_chpsvx_work, + LAPACKE_chptrd, + LAPACKE_chptrd_work, + LAPACKE_chptrf, + LAPACKE_chptrf_work, + LAPACKE_chptri, + LAPACKE_chptri_work, + LAPACKE_chptrs, + LAPACKE_chptrs_work, + LAPACKE_chsein, + LAPACKE_chsein_work, + LAPACKE_chseqr, + LAPACKE_chseqr_work, + LAPACKE_clacgv, + LAPACKE_clacgv_work, + LAPACKE_clacn2, + LAPACKE_clacn2_work, + LAPACKE_clacp2, + LAPACKE_clacp2_work, + LAPACKE_clacpy, + LAPACKE_clacpy_work, + LAPACKE_clag2z, + LAPACKE_clag2z_work, + LAPACKE_clange, + LAPACKE_clange_work, + LAPACKE_clanhe, + LAPACKE_clanhe_work, + LAPACKE_clansy, + LAPACKE_clansy_work, + LAPACKE_clantr, + LAPACKE_clantr_work, + LAPACKE_clapmr, + LAPACKE_clapmr_work, + LAPACKE_clarfb, + LAPACKE_clarfb_work, + LAPACKE_clarfg, + LAPACKE_clarfg_work, + LAPACKE_clarft, + LAPACKE_clarft_work, + LAPACKE_clarfx, + LAPACKE_clarfx_work, + LAPACKE_clarnv, + LAPACKE_clarnv_work, + LAPACKE_claset, + LAPACKE_claset_work, + LAPACKE_claswp, + LAPACKE_claswp_work, + LAPACKE_clauum, + LAPACKE_clauum_work, + LAPACKE_cpbcon, + LAPACKE_cpbcon_work, + LAPACKE_cpbequ, + LAPACKE_cpbequ_work, + LAPACKE_cpbrfs, + LAPACKE_cpbrfs_work, + LAPACKE_cpbstf, + LAPACKE_cpbstf_work, + LAPACKE_cpbsv, + LAPACKE_cpbsv_work, + LAPACKE_cpbsvx, + LAPACKE_cpbsvx_work, + LAPACKE_cpbtrf, + LAPACKE_cpbtrf_work, + LAPACKE_cpbtrs, + LAPACKE_cpbtrs_work, + LAPACKE_cpftrf, + LAPACKE_cpftrf_work, + LAPACKE_cpftri, + LAPACKE_cpftri_work, + LAPACKE_cpftrs, + LAPACKE_cpftrs_work, + LAPACKE_cpocon, + LAPACKE_cpocon_work, + LAPACKE_cpoequ, + LAPACKE_cpoequ_work, + LAPACKE_cpoequb, + LAPACKE_cpoequb_work, + LAPACKE_cporfs, + LAPACKE_cporfs_work, + LAPACKE_cposv, + LAPACKE_cposv_work, + LAPACKE_cposvx, + LAPACKE_cposvx_work, + LAPACKE_cpotrf, + LAPACKE_cpotrf_work, + LAPACKE_cpotri, + LAPACKE_cpotri_work, + LAPACKE_cpotrs, + LAPACKE_cpotrs_work, + LAPACKE_cppcon, + LAPACKE_cppcon_work, + LAPACKE_cppequ, + LAPACKE_cppequ_work, + LAPACKE_cpprfs, + LAPACKE_cpprfs_work, + LAPACKE_cppsv, + LAPACKE_cppsv_work, + LAPACKE_cppsvx, + LAPACKE_cppsvx_work, + LAPACKE_cpptrf, + LAPACKE_cpptrf_work, + LAPACKE_cpptri, + LAPACKE_cpptri_work, + LAPACKE_cpptrs, + LAPACKE_cpptrs_work, + LAPACKE_cpstrf, + LAPACKE_cpstrf_work, + LAPACKE_cptcon, + LAPACKE_cptcon_work, + LAPACKE_cpteqr, + LAPACKE_cpteqr_work, + LAPACKE_cptrfs, + LAPACKE_cptrfs_work, + LAPACKE_cptsv, + LAPACKE_cptsv_work, + LAPACKE_cptsvx, + LAPACKE_cptsvx_work, + LAPACKE_cpttrf, + LAPACKE_cpttrf_work, + LAPACKE_cpttrs, + LAPACKE_cpttrs_work, + LAPACKE_cspcon, + LAPACKE_cspcon_work, + LAPACKE_csprfs, + LAPACKE_csprfs_work, + LAPACKE_cspsv, + LAPACKE_cspsv_work, + LAPACKE_cspsvx, + LAPACKE_cspsvx_work, + LAPACKE_csptrf, + LAPACKE_csptrf_work, + LAPACKE_csptri, + LAPACKE_csptri_work, + LAPACKE_csptrs, + LAPACKE_csptrs_work, + LAPACKE_cstedc, + LAPACKE_cstedc_work, + LAPACKE_cstegr, + LAPACKE_cstegr_work, + LAPACKE_cstein, + LAPACKE_cstein_work, + LAPACKE_cstemr, + LAPACKE_cstemr_work, + LAPACKE_csteqr, + LAPACKE_csteqr_work, + LAPACKE_csycon, + LAPACKE_csycon_work, + LAPACKE_csyconv, + LAPACKE_csyconv_work, + LAPACKE_csyequb, + LAPACKE_csyequb_work, + LAPACKE_csyrfs, + LAPACKE_csyrfs_work, + LAPACKE_csysv, + LAPACKE_csysv_rook, + LAPACKE_csysv_rook_work, + LAPACKE_csysv_work, + LAPACKE_csysvx, + LAPACKE_csysvx_work, + LAPACKE_csyswapr, + LAPACKE_csyswapr_work, + LAPACKE_csytrf, + LAPACKE_csytrf_work, + LAPACKE_csytri, + LAPACKE_csytri2, + LAPACKE_csytri2_work, + LAPACKE_csytri2x, + LAPACKE_csytri2x_work, + LAPACKE_csytri_work, + LAPACKE_csytrs, + LAPACKE_csytrs2, + LAPACKE_csytrs2_work, + LAPACKE_csytrs_work, + LAPACKE_ctbcon, + LAPACKE_ctbcon_work, + LAPACKE_ctbrfs, + LAPACKE_ctbrfs_work, + LAPACKE_ctbtrs, + LAPACKE_ctbtrs_work, + LAPACKE_ctfsm, + LAPACKE_ctfsm_work, + LAPACKE_ctftri, + LAPACKE_ctftri_work, + LAPACKE_ctfttp, + LAPACKE_ctfttp_work, + LAPACKE_ctfttr, + LAPACKE_ctfttr_work, + LAPACKE_ctgevc, + LAPACKE_ctgevc_work, + LAPACKE_ctgexc, + LAPACKE_ctgexc_work, + LAPACKE_ctgsen, + LAPACKE_ctgsen_work, + LAPACKE_ctgsja, + LAPACKE_ctgsja_work, + LAPACKE_ctgsna, + LAPACKE_ctgsna_work, + LAPACKE_ctgsyl, + LAPACKE_ctgsyl_work, + LAPACKE_ctpcon, + LAPACKE_ctpcon_work, + LAPACKE_ctpmqrt, + LAPACKE_ctpmqrt_work, + LAPACKE_ctpqrt, + LAPACKE_ctpqrt2, + LAPACKE_ctpqrt2_work, + LAPACKE_ctpqrt_work, + LAPACKE_ctprfb, + LAPACKE_ctprfb_work, + LAPACKE_ctprfs, + LAPACKE_ctprfs_work, + LAPACKE_ctptri, + LAPACKE_ctptri_work, + LAPACKE_ctptrs, + LAPACKE_ctptrs_work, + LAPACKE_ctpttf, + LAPACKE_ctpttf_work, + LAPACKE_ctpttr, + LAPACKE_ctpttr_work, + LAPACKE_ctrcon, + LAPACKE_ctrcon_work, + LAPACKE_ctrevc, + LAPACKE_ctrevc_work, + LAPACKE_ctrexc, + LAPACKE_ctrexc_work, + LAPACKE_ctrrfs, + LAPACKE_ctrrfs_work, + LAPACKE_ctrsen, + LAPACKE_ctrsen_work, + LAPACKE_ctrsna, + LAPACKE_ctrsna_work, + LAPACKE_ctrsyl, + LAPACKE_ctrsyl_work, + LAPACKE_ctrtri, + LAPACKE_ctrtri_work, + LAPACKE_ctrtrs, + LAPACKE_ctrtrs_work, + LAPACKE_ctrttf, + LAPACKE_ctrttf_work, + LAPACKE_ctrttp, + LAPACKE_ctrttp_work, + LAPACKE_ctzrzf, + LAPACKE_ctzrzf_work, + LAPACKE_cunbdb, + LAPACKE_cunbdb_work, + LAPACKE_cuncsd, + LAPACKE_cuncsd_work, + LAPACKE_cungbr, + LAPACKE_cungbr_work, + LAPACKE_cunghr, + LAPACKE_cunghr_work, + LAPACKE_cunglq, + LAPACKE_cunglq_work, + LAPACKE_cungql, + LAPACKE_cungql_work, + LAPACKE_cungqr, + LAPACKE_cungqr_work, + LAPACKE_cungrq, + LAPACKE_cungrq_work, + LAPACKE_cungtr, + LAPACKE_cungtr_work, + LAPACKE_cunmbr, + LAPACKE_cunmbr_work, + LAPACKE_cunmhr, + LAPACKE_cunmhr_work, + LAPACKE_cunmlq, + LAPACKE_cunmlq_work, + LAPACKE_cunmql, + LAPACKE_cunmql_work, + LAPACKE_cunmqr, + LAPACKE_cunmqr_work, + LAPACKE_cunmrq, + LAPACKE_cunmrq_work, + LAPACKE_cunmrz, + LAPACKE_cunmrz_work, + LAPACKE_cunmtr, + LAPACKE_cunmtr_work, + LAPACKE_cupgtr, + LAPACKE_cupgtr_work, + LAPACKE_cupmtr, + LAPACKE_cupmtr_work, + LAPACKE_dbbcsd, + LAPACKE_dbbcsd_work, + LAPACKE_dbdsdc, + LAPACKE_dbdsdc_work, + LAPACKE_dbdsqr, + LAPACKE_dbdsqr_work, + LAPACKE_ddisna, + LAPACKE_ddisna_work, + LAPACKE_dgbbrd, + LAPACKE_dgbbrd_work, + LAPACKE_dgbcon, + LAPACKE_dgbcon_work, + LAPACKE_dgbequ, + LAPACKE_dgbequ_work, + LAPACKE_dgbequb, + LAPACKE_dgbequb_work, + LAPACKE_dgbrfs, + LAPACKE_dgbrfs_work, + LAPACKE_dgbsv, + LAPACKE_dgbsv_work, + LAPACKE_dgbsvx, + LAPACKE_dgbsvx_work, + LAPACKE_dgbtrf, + LAPACKE_dgbtrf_work, + LAPACKE_dgbtrs, + LAPACKE_dgbtrs_work, + LAPACKE_dgebak, + LAPACKE_dgebak_work, + LAPACKE_dgebal, + LAPACKE_dgebal_work, + LAPACKE_dgebrd, + LAPACKE_dgebrd_work, + LAPACKE_dgecon, + LAPACKE_dgecon_work, + LAPACKE_dgeequ, + LAPACKE_dgeequ_work, + LAPACKE_dgeequb, + LAPACKE_dgeequb_work, + LAPACKE_dgees, + LAPACKE_dgees_work, + LAPACKE_dgeesx, + LAPACKE_dgeesx_work, + LAPACKE_dgeev, + LAPACKE_dgeev_work, + LAPACKE_dgeevx, + LAPACKE_dgeevx_work, + LAPACKE_dgehrd, + LAPACKE_dgehrd_work, + LAPACKE_dgejsv, + LAPACKE_dgejsv_work, + LAPACKE_dgelq2, + LAPACKE_dgelq2_work, + LAPACKE_dgelqf, + LAPACKE_dgelqf_work, + LAPACKE_dgels, + LAPACKE_dgels_work, + LAPACKE_dgelsd, + LAPACKE_dgelsd_work, + LAPACKE_dgelss, + LAPACKE_dgelss_work, + LAPACKE_dgelsy, + LAPACKE_dgelsy_work, + LAPACKE_dgemqrt, + LAPACKE_dgemqrt_work, + LAPACKE_dgeqlf, + LAPACKE_dgeqlf_work, + LAPACKE_dgeqp3, + LAPACKE_dgeqp3_work, + LAPACKE_dgeqpf, + LAPACKE_dgeqpf_work, + LAPACKE_dgeqr2, + LAPACKE_dgeqr2_work, + LAPACKE_dgeqrf, + LAPACKE_dgeqrf_work, + LAPACKE_dgeqrfp, + LAPACKE_dgeqrfp_work, + LAPACKE_dgeqrt, + LAPACKE_dgeqrt2, + LAPACKE_dgeqrt2_work, + LAPACKE_dgeqrt3, + LAPACKE_dgeqrt3_work, + LAPACKE_dgeqrt_work, + LAPACKE_dgerfs, + LAPACKE_dgerfs_work, + LAPACKE_dgerqf, + LAPACKE_dgerqf_work, + LAPACKE_dgesdd, + LAPACKE_dgesdd_work, + LAPACKE_dgesv, + LAPACKE_dgesv_work, + LAPACKE_dgesvd, + LAPACKE_dgesvd_work, + LAPACKE_dgesvj, + LAPACKE_dgesvj_work, + LAPACKE_dgesvx, + LAPACKE_dgesvx_work, + LAPACKE_dgetf2, + LAPACKE_dgetf2_work, + LAPACKE_dgetrf, + LAPACKE_dgetrf_work, + LAPACKE_dgetri, + LAPACKE_dgetri_work, + LAPACKE_dgetrs, + LAPACKE_dgetrs_work, + LAPACKE_dggbak, + LAPACKE_dggbak_work, + LAPACKE_dggbal, + LAPACKE_dggbal_work, + LAPACKE_dgges, + LAPACKE_dgges_work, + LAPACKE_dggesx, + LAPACKE_dggesx_work, + LAPACKE_dggev, + LAPACKE_dggev_work, + LAPACKE_dggevx, + LAPACKE_dggevx_work, + LAPACKE_dggglm, + LAPACKE_dggglm_work, + LAPACKE_dgghrd, + LAPACKE_dgghrd_work, + LAPACKE_dgglse, + LAPACKE_dgglse_work, + LAPACKE_dggqrf, + LAPACKE_dggqrf_work, + LAPACKE_dggrqf, + LAPACKE_dggrqf_work, + LAPACKE_dggsvd, + LAPACKE_dggsvd_work, + LAPACKE_dggsvp, + LAPACKE_dggsvp_work, + LAPACKE_dgtcon, + LAPACKE_dgtcon_work, + LAPACKE_dgtrfs, + LAPACKE_dgtrfs_work, + LAPACKE_dgtsv, + LAPACKE_dgtsv_work, + LAPACKE_dgtsvx, + LAPACKE_dgtsvx_work, + LAPACKE_dgttrf, + LAPACKE_dgttrf_work, + LAPACKE_dgttrs, + LAPACKE_dgttrs_work, + LAPACKE_dhgeqz, + LAPACKE_dhgeqz_work, + LAPACKE_dhsein, + LAPACKE_dhsein_work, + LAPACKE_dhseqr, + LAPACKE_dhseqr_work, + LAPACKE_dlacn2, + LAPACKE_dlacn2_work, + LAPACKE_dlacpy, + LAPACKE_dlacpy_work, + LAPACKE_dlag2s, + LAPACKE_dlag2s_work, + LAPACKE_dlamch, + LAPACKE_dlamch_work, + LAPACKE_dlange, + LAPACKE_dlange_work, + LAPACKE_dlansy, + LAPACKE_dlansy_work, + LAPACKE_dlantr, + LAPACKE_dlantr_work, + LAPACKE_dlapmr, + LAPACKE_dlapmr_work, + LAPACKE_dlapy2, + LAPACKE_dlapy2_work, + LAPACKE_dlapy3, + LAPACKE_dlapy3_work, + LAPACKE_dlarfb, + LAPACKE_dlarfb_work, + LAPACKE_dlarfg, + LAPACKE_dlarfg_work, + LAPACKE_dlarft, + LAPACKE_dlarft_work, + LAPACKE_dlarfx, + LAPACKE_dlarfx_work, + LAPACKE_dlarnv, + LAPACKE_dlarnv_work, + LAPACKE_dlartgp, + LAPACKE_dlartgp_work, + LAPACKE_dlartgs, + LAPACKE_dlartgs_work, + LAPACKE_dlaset, + LAPACKE_dlaset_work, + LAPACKE_dlasrt, + LAPACKE_dlasrt_work, + LAPACKE_dlaswp, + LAPACKE_dlaswp_work, + LAPACKE_dlauum, + LAPACKE_dlauum_work, + LAPACKE_dopgtr, + LAPACKE_dopgtr_work, + LAPACKE_dopmtr, + LAPACKE_dopmtr_work, + LAPACKE_dorbdb, + LAPACKE_dorbdb_work, + LAPACKE_dorcsd, + LAPACKE_dorcsd_work, + LAPACKE_dorgbr, + LAPACKE_dorgbr_work, + LAPACKE_dorghr, + LAPACKE_dorghr_work, + LAPACKE_dorglq, + LAPACKE_dorglq_work, + LAPACKE_dorgql, + LAPACKE_dorgql_work, + LAPACKE_dorgqr, + LAPACKE_dorgqr_work, + LAPACKE_dorgrq, + LAPACKE_dorgrq_work, + LAPACKE_dorgtr, + LAPACKE_dorgtr_work, + LAPACKE_dormbr, + LAPACKE_dormbr_work, + LAPACKE_dormhr, + LAPACKE_dormhr_work, + LAPACKE_dormlq, + LAPACKE_dormlq_work, + LAPACKE_dormql, + LAPACKE_dormql_work, + LAPACKE_dormqr, + LAPACKE_dormqr_work, + LAPACKE_dormrq, + LAPACKE_dormrq_work, + LAPACKE_dormrz, + LAPACKE_dormrz_work, + LAPACKE_dormtr, + LAPACKE_dormtr_work, + LAPACKE_dpbcon, + LAPACKE_dpbcon_work, + LAPACKE_dpbequ, + LAPACKE_dpbequ_work, + LAPACKE_dpbrfs, + LAPACKE_dpbrfs_work, + LAPACKE_dpbstf, + LAPACKE_dpbstf_work, + LAPACKE_dpbsv, + LAPACKE_dpbsv_work, + LAPACKE_dpbsvx, + LAPACKE_dpbsvx_work, + LAPACKE_dpbtrf, + LAPACKE_dpbtrf_work, + LAPACKE_dpbtrs, + LAPACKE_dpbtrs_work, + LAPACKE_dpftrf, + LAPACKE_dpftrf_work, + LAPACKE_dpftri, + LAPACKE_dpftri_work, + LAPACKE_dpftrs, + LAPACKE_dpftrs_work, + LAPACKE_dpocon, + LAPACKE_dpocon_work, + LAPACKE_dpoequ, + LAPACKE_dpoequ_work, + LAPACKE_dpoequb, + LAPACKE_dpoequb_work, + LAPACKE_dporfs, + LAPACKE_dporfs_work, + LAPACKE_dposv, + LAPACKE_dposv_work, + LAPACKE_dposvx, + LAPACKE_dposvx_work, + LAPACKE_dpotrf, + LAPACKE_dpotrf_work, + LAPACKE_dpotri, + LAPACKE_dpotri_work, + LAPACKE_dpotrs, + LAPACKE_dpotrs_work, + LAPACKE_dppcon, + LAPACKE_dppcon_work, + LAPACKE_dppequ, + LAPACKE_dppequ_work, + LAPACKE_dpprfs, + LAPACKE_dpprfs_work, + LAPACKE_dppsv, + LAPACKE_dppsv_work, + LAPACKE_dppsvx, + LAPACKE_dppsvx_work, + LAPACKE_dpptrf, + LAPACKE_dpptrf_work, + LAPACKE_dpptri, + LAPACKE_dpptri_work, + LAPACKE_dpptrs, + LAPACKE_dpptrs_work, + LAPACKE_dpstrf, + LAPACKE_dpstrf_work, + LAPACKE_dptcon, + LAPACKE_dptcon_work, + LAPACKE_dpteqr, + LAPACKE_dpteqr_work, + LAPACKE_dptrfs, + LAPACKE_dptrfs_work, + LAPACKE_dptsv, + LAPACKE_dptsv_work, + LAPACKE_dptsvx, + LAPACKE_dptsvx_work, + LAPACKE_dpttrf, + LAPACKE_dpttrf_work, + LAPACKE_dpttrs, + LAPACKE_dpttrs_work, + LAPACKE_dsbev, + LAPACKE_dsbev_work, + LAPACKE_dsbevd, + LAPACKE_dsbevd_work, + LAPACKE_dsbevx, + LAPACKE_dsbevx_work, + LAPACKE_dsbgst, + LAPACKE_dsbgst_work, + LAPACKE_dsbgv, + LAPACKE_dsbgv_work, + LAPACKE_dsbgvd, + LAPACKE_dsbgvd_work, + LAPACKE_dsbgvx, + LAPACKE_dsbgvx_work, + LAPACKE_dsbtrd, + LAPACKE_dsbtrd_work, + LAPACKE_dsfrk, + LAPACKE_dsfrk_work, + LAPACKE_dsgesv, + LAPACKE_dsgesv_work, + LAPACKE_dspcon, + LAPACKE_dspcon_work, + LAPACKE_dspev, + LAPACKE_dspev_work, + LAPACKE_dspevd, + LAPACKE_dspevd_work, + LAPACKE_dspevx, + LAPACKE_dspevx_work, + LAPACKE_dspgst, + LAPACKE_dspgst_work, + LAPACKE_dspgv, + LAPACKE_dspgv_work, + LAPACKE_dspgvd, + LAPACKE_dspgvd_work, + LAPACKE_dspgvx, + LAPACKE_dspgvx_work, + LAPACKE_dsposv, + LAPACKE_dsposv_work, + LAPACKE_dsprfs, + LAPACKE_dsprfs_work, + LAPACKE_dspsv, + LAPACKE_dspsv_work, + LAPACKE_dspsvx, + LAPACKE_dspsvx_work, + LAPACKE_dsptrd, + LAPACKE_dsptrd_work, + LAPACKE_dsptrf, + LAPACKE_dsptrf_work, + LAPACKE_dsptri, + LAPACKE_dsptri_work, + LAPACKE_dsptrs, + LAPACKE_dsptrs_work, + LAPACKE_dstebz, + LAPACKE_dstebz_work, + LAPACKE_dstedc, + LAPACKE_dstedc_work, + LAPACKE_dstegr, + LAPACKE_dstegr_work, + LAPACKE_dstein, + LAPACKE_dstein_work, + LAPACKE_dstemr, + LAPACKE_dstemr_work, + LAPACKE_dsteqr, + LAPACKE_dsteqr_work, + LAPACKE_dsterf, + LAPACKE_dsterf_work, + LAPACKE_dstev, + LAPACKE_dstev_work, + LAPACKE_dstevd, + LAPACKE_dstevd_work, + LAPACKE_dstevr, + LAPACKE_dstevr_work, + LAPACKE_dstevx, + LAPACKE_dstevx_work, + LAPACKE_dsycon, + LAPACKE_dsycon_work, + LAPACKE_dsyconv, + LAPACKE_dsyconv_work, + LAPACKE_dsyequb, + LAPACKE_dsyequb_work, + LAPACKE_dsyev, + LAPACKE_dsyev_work, + LAPACKE_dsyevd, + LAPACKE_dsyevd_work, + LAPACKE_dsyevr, + LAPACKE_dsyevr_work, + LAPACKE_dsyevx, + LAPACKE_dsyevx_work, + LAPACKE_dsygst, + LAPACKE_dsygst_work, + LAPACKE_dsygv, + LAPACKE_dsygv_work, + LAPACKE_dsygvd, + LAPACKE_dsygvd_work, + LAPACKE_dsygvx, + LAPACKE_dsygvx_work, + LAPACKE_dsyrfs, + LAPACKE_dsyrfs_work, + LAPACKE_dsysv, + LAPACKE_dsysv_rook, + LAPACKE_dsysv_rook_work, + LAPACKE_dsysv_work, + LAPACKE_dsysvx, + LAPACKE_dsysvx_work, + LAPACKE_dsyswapr, + LAPACKE_dsyswapr_work, + LAPACKE_dsytrd, + LAPACKE_dsytrd_work, + LAPACKE_dsytrf, + LAPACKE_dsytrf_work, + LAPACKE_dsytri, + LAPACKE_dsytri2, + LAPACKE_dsytri2_work, + LAPACKE_dsytri2x, + LAPACKE_dsytri2x_work, + LAPACKE_dsytri_work, + LAPACKE_dsytrs, + LAPACKE_dsytrs2, + LAPACKE_dsytrs2_work, + LAPACKE_dsytrs_work, + LAPACKE_dtbcon, + LAPACKE_dtbcon_work, + LAPACKE_dtbrfs, + LAPACKE_dtbrfs_work, + LAPACKE_dtbtrs, + LAPACKE_dtbtrs_work, + LAPACKE_dtfsm, + LAPACKE_dtfsm_work, + LAPACKE_dtftri, + LAPACKE_dtftri_work, + LAPACKE_dtfttp, + LAPACKE_dtfttp_work, + LAPACKE_dtfttr, + LAPACKE_dtfttr_work, + LAPACKE_dtgevc, + LAPACKE_dtgevc_work, + LAPACKE_dtgexc, + LAPACKE_dtgexc_work, + LAPACKE_dtgsen, + LAPACKE_dtgsen_work, + LAPACKE_dtgsja, + LAPACKE_dtgsja_work, + LAPACKE_dtgsna, + LAPACKE_dtgsna_work, + LAPACKE_dtgsyl, + LAPACKE_dtgsyl_work, + LAPACKE_dtpcon, + LAPACKE_dtpcon_work, + LAPACKE_dtpmqrt, + LAPACKE_dtpmqrt_work, + LAPACKE_dtpqrt, + LAPACKE_dtpqrt2, + LAPACKE_dtpqrt2_work, + LAPACKE_dtpqrt_work, + LAPACKE_dtprfb, + LAPACKE_dtprfb_work, + LAPACKE_dtprfs, + LAPACKE_dtprfs_work, + LAPACKE_dtptri, + LAPACKE_dtptri_work, + LAPACKE_dtptrs, + LAPACKE_dtptrs_work, + LAPACKE_dtpttf, + LAPACKE_dtpttf_work, + LAPACKE_dtpttr, + LAPACKE_dtpttr_work, + LAPACKE_dtrcon, + LAPACKE_dtrcon_work, + LAPACKE_dtrevc, + LAPACKE_dtrevc_work, + LAPACKE_dtrexc, + LAPACKE_dtrexc_work, + LAPACKE_dtrrfs, + LAPACKE_dtrrfs_work, + LAPACKE_dtrsen, + LAPACKE_dtrsen_work, + LAPACKE_dtrsna, + LAPACKE_dtrsna_work, + LAPACKE_dtrsyl, + LAPACKE_dtrsyl_work, + LAPACKE_dtrtri, + LAPACKE_dtrtri_work, + LAPACKE_dtrtrs, + LAPACKE_dtrtrs_work, + LAPACKE_dtrttf, + LAPACKE_dtrttf_work, + LAPACKE_dtrttp, + LAPACKE_dtrttp_work, + LAPACKE_dtzrzf, + LAPACKE_dtzrzf_work, + LAPACKE_sbbcsd, + LAPACKE_sbbcsd_work, + LAPACKE_sbdsdc, + LAPACKE_sbdsdc_work, + LAPACKE_sbdsqr, + LAPACKE_sbdsqr_work, + LAPACKE_sdisna, + LAPACKE_sdisna_work, + LAPACKE_sgbbrd, + LAPACKE_sgbbrd_work, + LAPACKE_sgbcon, + LAPACKE_sgbcon_work, + LAPACKE_sgbequ, + LAPACKE_sgbequ_work, + LAPACKE_sgbequb, + LAPACKE_sgbequb_work, + LAPACKE_sgbrfs, + LAPACKE_sgbrfs_work, + LAPACKE_sgbsv, + LAPACKE_sgbsv_work, + LAPACKE_sgbsvx, + LAPACKE_sgbsvx_work, + LAPACKE_sgbtrf, + LAPACKE_sgbtrf_work, + LAPACKE_sgbtrs, + LAPACKE_sgbtrs_work, + LAPACKE_sgebak, + LAPACKE_sgebak_work, + LAPACKE_sgebal, + LAPACKE_sgebal_work, + LAPACKE_sgebrd, + LAPACKE_sgebrd_work, + LAPACKE_sgecon, + LAPACKE_sgecon_work, + LAPACKE_sgeequ, + LAPACKE_sgeequ_work, + LAPACKE_sgeequb, + LAPACKE_sgeequb_work, + LAPACKE_sgees, + LAPACKE_sgees_work, + LAPACKE_sgeesx, + LAPACKE_sgeesx_work, + LAPACKE_sgeev, + LAPACKE_sgeev_work, + LAPACKE_sgeevx, + LAPACKE_sgeevx_work, + LAPACKE_sgehrd, + LAPACKE_sgehrd_work, + LAPACKE_sgejsv, + LAPACKE_sgejsv_work, + LAPACKE_sgelq2, + LAPACKE_sgelq2_work, + LAPACKE_sgelqf, + LAPACKE_sgelqf_work, + LAPACKE_sgels, + LAPACKE_sgels_work, + LAPACKE_sgelsd, + LAPACKE_sgelsd_work, + LAPACKE_sgelss, + LAPACKE_sgelss_work, + LAPACKE_sgelsy, + LAPACKE_sgelsy_work, + LAPACKE_sgemqrt, + LAPACKE_sgemqrt_work, + LAPACKE_sgeqlf, + LAPACKE_sgeqlf_work, + LAPACKE_sgeqp3, + LAPACKE_sgeqp3_work, + LAPACKE_sgeqpf, + LAPACKE_sgeqpf_work, + LAPACKE_sgeqr2, + LAPACKE_sgeqr2_work, + LAPACKE_sgeqrf, + LAPACKE_sgeqrf_work, + LAPACKE_sgeqrfp, + LAPACKE_sgeqrfp_work, + LAPACKE_sgeqrt, + LAPACKE_sgeqrt2, + LAPACKE_sgeqrt2_work, + LAPACKE_sgeqrt3, + LAPACKE_sgeqrt3_work, + LAPACKE_sgeqrt_work, + LAPACKE_sgerfs, + LAPACKE_sgerfs_work, + LAPACKE_sgerqf, + LAPACKE_sgerqf_work, + LAPACKE_sgesdd, + LAPACKE_sgesdd_work, + LAPACKE_sgesv, + LAPACKE_sgesv_work, + LAPACKE_sgesvd, + LAPACKE_sgesvd_work, + LAPACKE_sgesvj, + LAPACKE_sgesvj_work, + LAPACKE_sgesvx, + LAPACKE_sgesvx_work, + LAPACKE_sgetf2, + LAPACKE_sgetf2_work, + LAPACKE_sgetrf, + LAPACKE_sgetrf_work, + LAPACKE_sgetri, + LAPACKE_sgetri_work, + LAPACKE_sgetrs, + LAPACKE_sgetrs_work, + LAPACKE_sggbak, + LAPACKE_sggbak_work, + LAPACKE_sggbal, + LAPACKE_sggbal_work, + LAPACKE_sgges, + LAPACKE_sgges_work, + LAPACKE_sggesx, + LAPACKE_sggesx_work, + LAPACKE_sggev, + LAPACKE_sggev_work, + LAPACKE_sggevx, + LAPACKE_sggevx_work, + LAPACKE_sggglm, + LAPACKE_sggglm_work, + LAPACKE_sgghrd, + LAPACKE_sgghrd_work, + LAPACKE_sgglse, + LAPACKE_sgglse_work, + LAPACKE_sggqrf, + LAPACKE_sggqrf_work, + LAPACKE_sggrqf, + LAPACKE_sggrqf_work, + LAPACKE_sggsvd, + LAPACKE_sggsvd_work, + LAPACKE_sggsvp, + LAPACKE_sggsvp_work, + LAPACKE_sgtcon, + LAPACKE_sgtcon_work, + LAPACKE_sgtrfs, + LAPACKE_sgtrfs_work, + LAPACKE_sgtsv, + LAPACKE_sgtsv_work, + LAPACKE_sgtsvx, + LAPACKE_sgtsvx_work, + LAPACKE_sgttrf, + LAPACKE_sgttrf_work, + LAPACKE_sgttrs, + LAPACKE_sgttrs_work, + LAPACKE_shgeqz, + LAPACKE_shgeqz_work, + LAPACKE_shsein, + LAPACKE_shsein_work, + LAPACKE_shseqr, + LAPACKE_shseqr_work, + LAPACKE_slacn2, + LAPACKE_slacn2_work, + LAPACKE_slacpy, + LAPACKE_slacpy_work, + LAPACKE_slag2d, + LAPACKE_slag2d_work, + LAPACKE_slamch, + LAPACKE_slamch_work, + LAPACKE_slange, + LAPACKE_slange_work, + LAPACKE_slansy, + LAPACKE_slansy_work, + LAPACKE_slantr, + LAPACKE_slantr_work, + LAPACKE_slapmr, + LAPACKE_slapmr_work, + LAPACKE_slapy2, + LAPACKE_slapy2_work, + LAPACKE_slapy3, + LAPACKE_slapy3_work, + LAPACKE_slarfb, + LAPACKE_slarfb_work, + LAPACKE_slarfg, + LAPACKE_slarfg_work, + LAPACKE_slarft, + LAPACKE_slarft_work, + LAPACKE_slarfx, + LAPACKE_slarfx_work, + LAPACKE_slarnv, + LAPACKE_slarnv_work, + LAPACKE_slartgp, + LAPACKE_slartgp_work, + LAPACKE_slartgs, + LAPACKE_slartgs_work, + LAPACKE_slaset, + LAPACKE_slaset_work, + LAPACKE_slasrt, + LAPACKE_slasrt_work, + LAPACKE_slaswp, + LAPACKE_slaswp_work, + LAPACKE_slauum, + LAPACKE_slauum_work, + LAPACKE_sopgtr, + LAPACKE_sopgtr_work, + LAPACKE_sopmtr, + LAPACKE_sopmtr_work, + LAPACKE_sorbdb, + LAPACKE_sorbdb_work, + LAPACKE_sorcsd, + LAPACKE_sorcsd_work, + LAPACKE_sorgbr, + LAPACKE_sorgbr_work, + LAPACKE_sorghr, + LAPACKE_sorghr_work, + LAPACKE_sorglq, + LAPACKE_sorglq_work, + LAPACKE_sorgql, + LAPACKE_sorgql_work, + LAPACKE_sorgqr, + LAPACKE_sorgqr_work, + LAPACKE_sorgrq, + LAPACKE_sorgrq_work, + LAPACKE_sorgtr, + LAPACKE_sorgtr_work, + LAPACKE_sormbr, + LAPACKE_sormbr_work, + LAPACKE_sormhr, + LAPACKE_sormhr_work, + LAPACKE_sormlq, + LAPACKE_sormlq_work, + LAPACKE_sormql, + LAPACKE_sormql_work, + LAPACKE_sormqr, + LAPACKE_sormqr_work, + LAPACKE_sormrq, + LAPACKE_sormrq_work, + LAPACKE_sormrz, + LAPACKE_sormrz_work, + LAPACKE_sormtr, + LAPACKE_sormtr_work, + LAPACKE_spbcon, + LAPACKE_spbcon_work, + LAPACKE_spbequ, + LAPACKE_spbequ_work, + LAPACKE_spbrfs, + LAPACKE_spbrfs_work, + LAPACKE_spbstf, + LAPACKE_spbstf_work, + LAPACKE_spbsv, + LAPACKE_spbsv_work, + LAPACKE_spbsvx, + LAPACKE_spbsvx_work, + LAPACKE_spbtrf, + LAPACKE_spbtrf_work, + LAPACKE_spbtrs, + LAPACKE_spbtrs_work, + LAPACKE_spftrf, + LAPACKE_spftrf_work, + LAPACKE_spftri, + LAPACKE_spftri_work, + LAPACKE_spftrs, + LAPACKE_spftrs_work, + LAPACKE_spocon, + LAPACKE_spocon_work, + LAPACKE_spoequ, + LAPACKE_spoequ_work, + LAPACKE_spoequb, + LAPACKE_spoequb_work, + LAPACKE_sporfs, + LAPACKE_sporfs_work, + LAPACKE_sposv, + LAPACKE_sposv_work, + LAPACKE_sposvx, + LAPACKE_sposvx_work, + LAPACKE_spotrf, + LAPACKE_spotrf_work, + LAPACKE_spotri, + LAPACKE_spotri_work, + LAPACKE_spotrs, + LAPACKE_spotrs_work, + LAPACKE_sppcon, + LAPACKE_sppcon_work, + LAPACKE_sppequ, + LAPACKE_sppequ_work, + LAPACKE_spprfs, + LAPACKE_spprfs_work, + LAPACKE_sppsv, + LAPACKE_sppsv_work, + LAPACKE_sppsvx, + LAPACKE_sppsvx_work, + LAPACKE_spptrf, + LAPACKE_spptrf_work, + LAPACKE_spptri, + LAPACKE_spptri_work, + LAPACKE_spptrs, + LAPACKE_spptrs_work, + LAPACKE_spstrf, + LAPACKE_spstrf_work, + LAPACKE_sptcon, + LAPACKE_sptcon_work, + LAPACKE_spteqr, + LAPACKE_spteqr_work, + LAPACKE_sptrfs, + LAPACKE_sptrfs_work, + LAPACKE_sptsv, + LAPACKE_sptsv_work, + LAPACKE_sptsvx, + LAPACKE_sptsvx_work, + LAPACKE_spttrf, + LAPACKE_spttrf_work, + LAPACKE_spttrs, + LAPACKE_spttrs_work, + LAPACKE_ssbev, + LAPACKE_ssbev_work, + LAPACKE_ssbevd, + LAPACKE_ssbevd_work, + LAPACKE_ssbevx, + LAPACKE_ssbevx_work, + LAPACKE_ssbgst, + LAPACKE_ssbgst_work, + LAPACKE_ssbgv, + LAPACKE_ssbgv_work, + LAPACKE_ssbgvd, + LAPACKE_ssbgvd_work, + LAPACKE_ssbgvx, + LAPACKE_ssbgvx_work, + LAPACKE_ssbtrd, + LAPACKE_ssbtrd_work, + LAPACKE_ssfrk, + LAPACKE_ssfrk_work, + LAPACKE_sspcon, + LAPACKE_sspcon_work, + LAPACKE_sspev, + LAPACKE_sspev_work, + LAPACKE_sspevd, + LAPACKE_sspevd_work, + LAPACKE_sspevx, + LAPACKE_sspevx_work, + LAPACKE_sspgst, + LAPACKE_sspgst_work, + LAPACKE_sspgv, + LAPACKE_sspgv_work, + LAPACKE_sspgvd, + LAPACKE_sspgvd_work, + LAPACKE_sspgvx, + LAPACKE_sspgvx_work, + LAPACKE_ssprfs, + LAPACKE_ssprfs_work, + LAPACKE_sspsv, + LAPACKE_sspsv_work, + LAPACKE_sspsvx, + LAPACKE_sspsvx_work, + LAPACKE_ssptrd, + LAPACKE_ssptrd_work, + LAPACKE_ssptrf, + LAPACKE_ssptrf_work, + LAPACKE_ssptri, + LAPACKE_ssptri_work, + LAPACKE_ssptrs, + LAPACKE_ssptrs_work, + LAPACKE_sstebz, + LAPACKE_sstebz_work, + LAPACKE_sstedc, + LAPACKE_sstedc_work, + LAPACKE_sstegr, + LAPACKE_sstegr_work, + LAPACKE_sstein, + LAPACKE_sstein_work, + LAPACKE_sstemr, + LAPACKE_sstemr_work, + LAPACKE_ssteqr, + LAPACKE_ssteqr_work, + LAPACKE_ssterf, + LAPACKE_ssterf_work, + LAPACKE_sstev, + LAPACKE_sstev_work, + LAPACKE_sstevd, + LAPACKE_sstevd_work, + LAPACKE_sstevr, + LAPACKE_sstevr_work, + LAPACKE_sstevx, + LAPACKE_sstevx_work, + LAPACKE_ssycon, + LAPACKE_ssycon_work, + LAPACKE_ssyconv, + LAPACKE_ssyconv_work, + LAPACKE_ssyequb, + LAPACKE_ssyequb_work, + LAPACKE_ssyev, + LAPACKE_ssyev_work, + LAPACKE_ssyevd, + LAPACKE_ssyevd_work, + LAPACKE_ssyevr, + LAPACKE_ssyevr_work, + LAPACKE_ssyevx, + LAPACKE_ssyevx_work, + LAPACKE_ssygst, + LAPACKE_ssygst_work, + LAPACKE_ssygv, + LAPACKE_ssygv_work, + LAPACKE_ssygvd, + LAPACKE_ssygvd_work, + LAPACKE_ssygvx, + LAPACKE_ssygvx_work, + LAPACKE_ssyrfs, + LAPACKE_ssyrfs_work, + LAPACKE_ssysv, + LAPACKE_ssysv_rook, + LAPACKE_ssysv_rook_work, + LAPACKE_ssysv_work, + LAPACKE_ssysvx, + LAPACKE_ssysvx_work, + LAPACKE_ssyswapr, + LAPACKE_ssyswapr_work, + LAPACKE_ssytrd, + LAPACKE_ssytrd_work, + LAPACKE_ssytrf, + LAPACKE_ssytrf_work, + LAPACKE_ssytri, + LAPACKE_ssytri2, + LAPACKE_ssytri2_work, + LAPACKE_ssytri2x, + LAPACKE_ssytri2x_work, + LAPACKE_ssytri_work, + LAPACKE_ssytrs, + LAPACKE_ssytrs2, + LAPACKE_ssytrs2_work, + LAPACKE_ssytrs_work, + LAPACKE_stbcon, + LAPACKE_stbcon_work, + LAPACKE_stbrfs, + LAPACKE_stbrfs_work, + LAPACKE_stbtrs, + LAPACKE_stbtrs_work, + LAPACKE_stfsm, + LAPACKE_stfsm_work, + LAPACKE_stftri, + LAPACKE_stftri_work, + LAPACKE_stfttp, + LAPACKE_stfttp_work, + LAPACKE_stfttr, + LAPACKE_stfttr_work, + LAPACKE_stgevc, + LAPACKE_stgevc_work, + LAPACKE_stgexc, + LAPACKE_stgexc_work, + LAPACKE_stgsen, + LAPACKE_stgsen_work, + LAPACKE_stgsja, + LAPACKE_stgsja_work, + LAPACKE_stgsna, + LAPACKE_stgsna_work, + LAPACKE_stgsyl, + LAPACKE_stgsyl_work, + LAPACKE_stpcon, + LAPACKE_stpcon_work, + LAPACKE_stpmqrt, + LAPACKE_stpmqrt_work, + LAPACKE_stpqrt2, + LAPACKE_stpqrt2_work, + LAPACKE_stprfb, + LAPACKE_stprfb_work, + LAPACKE_stprfs, + LAPACKE_stprfs_work, + LAPACKE_stptri, + LAPACKE_stptri_work, + LAPACKE_stptrs, + LAPACKE_stptrs_work, + LAPACKE_stpttf, + LAPACKE_stpttf_work, + LAPACKE_stpttr, + LAPACKE_stpttr_work, + LAPACKE_strcon, + LAPACKE_strcon_work, + LAPACKE_strevc, + LAPACKE_strevc_work, + LAPACKE_strexc, + LAPACKE_strexc_work, + LAPACKE_strrfs, + LAPACKE_strrfs_work, + LAPACKE_strsen, + LAPACKE_strsen_work, + LAPACKE_strsna, + LAPACKE_strsna_work, + LAPACKE_strsyl, + LAPACKE_strsyl_work, + LAPACKE_strtri, + LAPACKE_strtri_work, + LAPACKE_strtrs, + LAPACKE_strtrs_work, + LAPACKE_strttf, + LAPACKE_strttf_work, + LAPACKE_strttp, + LAPACKE_strttp_work, + LAPACKE_stzrzf, + LAPACKE_stzrzf_work, + LAPACKE_zbbcsd, + LAPACKE_zbbcsd_work, + LAPACKE_zbdsqr, + LAPACKE_zbdsqr_work, + LAPACKE_zcgesv, + LAPACKE_zcgesv_work, + LAPACKE_zcposv, + LAPACKE_zcposv_work, + LAPACKE_zgbbrd, + LAPACKE_zgbbrd_work, + LAPACKE_zgbcon, + LAPACKE_zgbcon_work, + LAPACKE_zgbequ, + LAPACKE_zgbequ_work, + LAPACKE_zgbequb, + LAPACKE_zgbequb_work, + LAPACKE_zgbrfs, + LAPACKE_zgbrfs_work, + LAPACKE_zgbsv, + LAPACKE_zgbsv_work, + LAPACKE_zgbsvx, + LAPACKE_zgbsvx_work, + LAPACKE_zgbtrf, + LAPACKE_zgbtrf_work, + LAPACKE_zgbtrs, + LAPACKE_zgbtrs_work, + LAPACKE_zgebak, + LAPACKE_zgebak_work, + LAPACKE_zgebal, + LAPACKE_zgebal_work, + LAPACKE_zgebrd, + LAPACKE_zgebrd_work, + LAPACKE_zgecon, + LAPACKE_zgecon_work, + LAPACKE_zgeequ, + LAPACKE_zgeequ_work, + LAPACKE_zgeequb, + LAPACKE_zgeequb_work, + LAPACKE_zgees, + LAPACKE_zgees_work, + LAPACKE_zgeesx, + LAPACKE_zgeesx_work, + LAPACKE_zgeev, + LAPACKE_zgeev_work, + LAPACKE_zgeevx, + LAPACKE_zgeevx_work, + LAPACKE_zgehrd, + LAPACKE_zgehrd_work, + LAPACKE_zgelq2, + LAPACKE_zgelq2_work, + LAPACKE_zgelqf, + LAPACKE_zgelqf_work, + LAPACKE_zgels, + LAPACKE_zgels_work, + LAPACKE_zgelsd, + LAPACKE_zgelsd_work, + LAPACKE_zgelss, + LAPACKE_zgelss_work, + LAPACKE_zgelsy, + LAPACKE_zgelsy_work, + LAPACKE_zgemqrt, + LAPACKE_zgemqrt_work, + LAPACKE_zgeqlf, + LAPACKE_zgeqlf_work, + LAPACKE_zgeqp3, + LAPACKE_zgeqp3_work, + LAPACKE_zgeqpf, + LAPACKE_zgeqpf_work, + LAPACKE_zgeqr2, + LAPACKE_zgeqr2_work, + LAPACKE_zgeqrf, + LAPACKE_zgeqrf_work, + LAPACKE_zgeqrfp, + LAPACKE_zgeqrfp_work, + LAPACKE_zgeqrt, + LAPACKE_zgeqrt2, + LAPACKE_zgeqrt2_work, + LAPACKE_zgeqrt3, + LAPACKE_zgeqrt3_work, + LAPACKE_zgeqrt_work, + LAPACKE_zgerfs, + LAPACKE_zgerfs_work, + LAPACKE_zgerqf, + LAPACKE_zgerqf_work, + LAPACKE_zgesdd, + LAPACKE_zgesdd_work, + LAPACKE_zgesv, + LAPACKE_zgesv_work, + LAPACKE_zgesvd, + LAPACKE_zgesvd_work, + LAPACKE_zgesvx, + LAPACKE_zgesvx_work, + LAPACKE_zgetf2, + LAPACKE_zgetf2_work, + LAPACKE_zgetrf, + LAPACKE_zgetrf_work, + LAPACKE_zgetri, + LAPACKE_zgetri_work, + LAPACKE_zgetrs, + LAPACKE_zgetrs_work, + LAPACKE_zggbak, + LAPACKE_zggbak_work, + LAPACKE_zggbal, + LAPACKE_zggbal_work, + LAPACKE_zgges, + LAPACKE_zgges_work, + LAPACKE_zggesx, + LAPACKE_zggesx_work, + LAPACKE_zggev, + LAPACKE_zggev_work, + LAPACKE_zggevx, + LAPACKE_zggevx_work, + LAPACKE_zggglm, + LAPACKE_zggglm_work, + LAPACKE_zgghrd, + LAPACKE_zgghrd_work, + LAPACKE_zgglse, + LAPACKE_zgglse_work, + LAPACKE_zggqrf, + LAPACKE_zggqrf_work, + LAPACKE_zggrqf, + LAPACKE_zggrqf_work, + LAPACKE_zggsvd, + LAPACKE_zggsvd_work, + LAPACKE_zggsvp, + LAPACKE_zggsvp_work, + LAPACKE_zgtcon, + LAPACKE_zgtcon_work, + LAPACKE_zgtrfs, + LAPACKE_zgtrfs_work, + LAPACKE_zgtsv, + LAPACKE_zgtsv_work, + LAPACKE_zgtsvx, + LAPACKE_zgtsvx_work, + LAPACKE_zgttrf, + LAPACKE_zgttrf_work, + LAPACKE_zgttrs, + LAPACKE_zgttrs_work, + LAPACKE_zhbev, + LAPACKE_zhbev_work, + LAPACKE_zhbevd, + LAPACKE_zhbevd_work, + LAPACKE_zhbevx, + LAPACKE_zhbevx_work, + LAPACKE_zhbgst, + LAPACKE_zhbgst_work, + LAPACKE_zhbgv, + LAPACKE_zhbgv_work, + LAPACKE_zhbgvd, + LAPACKE_zhbgvd_work, + LAPACKE_zhbgvx, + LAPACKE_zhbgvx_work, + LAPACKE_zhbtrd, + LAPACKE_zhbtrd_work, + LAPACKE_zhecon, + LAPACKE_zhecon_work, + LAPACKE_zheequb, + LAPACKE_zheequb_work, + LAPACKE_zheev, + LAPACKE_zheev_work, + LAPACKE_zheevd, + LAPACKE_zheevd_work, + LAPACKE_zheevr, + LAPACKE_zheevr_work, + LAPACKE_zheevx, + LAPACKE_zheevx_work, + LAPACKE_zhegst, + LAPACKE_zhegst_work, + LAPACKE_zhegv, + LAPACKE_zhegv_work, + LAPACKE_zhegvd, + LAPACKE_zhegvd_work, + LAPACKE_zhegvx, + LAPACKE_zhegvx_work, + LAPACKE_zherfs, + LAPACKE_zherfs_work, + LAPACKE_zhesv, + LAPACKE_zhesv_work, + LAPACKE_zhesvx, + LAPACKE_zhesvx_work, + LAPACKE_zheswapr, + LAPACKE_zheswapr_work, + LAPACKE_zhetrd, + LAPACKE_zhetrd_work, + LAPACKE_zhetrf, + LAPACKE_zhetrf_work, + LAPACKE_zhetri, + LAPACKE_zhetri2, + LAPACKE_zhetri2_work, + LAPACKE_zhetri2x, + LAPACKE_zhetri2x_work, + LAPACKE_zhetri_work, + LAPACKE_zhetrs, + LAPACKE_zhetrs2, + LAPACKE_zhetrs2_work, + LAPACKE_zhetrs_work, + LAPACKE_zhfrk, + LAPACKE_zhfrk_work, + LAPACKE_zhgeqz, + LAPACKE_zhgeqz_work, + LAPACKE_zhpcon, + LAPACKE_zhpcon_work, + LAPACKE_zhpev, + LAPACKE_zhpev_work, + LAPACKE_zhpevd, + LAPACKE_zhpevd_work, + LAPACKE_zhpevx, + LAPACKE_zhpevx_work, + LAPACKE_zhpgst, + LAPACKE_zhpgst_work, + LAPACKE_zhpgv, + LAPACKE_zhpgv_work, + LAPACKE_zhpgvd, + LAPACKE_zhpgvd_work, + LAPACKE_zhpgvx, + LAPACKE_zhpgvx_work, + LAPACKE_zhprfs, + LAPACKE_zhprfs_work, + LAPACKE_zhpsv, + LAPACKE_zhpsv_work, + LAPACKE_zhpsvx, + LAPACKE_zhpsvx_work, + LAPACKE_zhptrd, + LAPACKE_zhptrd_work, + LAPACKE_zhptrf, + LAPACKE_zhptrf_work, + LAPACKE_zhptri, + LAPACKE_zhptri_work, + LAPACKE_zhptrs, + LAPACKE_zhptrs_work, + LAPACKE_zhsein, + LAPACKE_zhsein_work, + LAPACKE_zhseqr, + LAPACKE_zhseqr_work, + LAPACKE_zlacgv, + LAPACKE_zlacgv_work, + LAPACKE_zlacn2, + LAPACKE_zlacn2_work, + LAPACKE_zlacp2, + LAPACKE_zlacp2_work, + LAPACKE_zlacpy, + LAPACKE_zlacpy_work, + LAPACKE_zlag2c, + LAPACKE_zlag2c_work, + LAPACKE_zlange, + LAPACKE_zlange_work, + LAPACKE_zlanhe, + LAPACKE_zlanhe_work, + LAPACKE_zlansy, + LAPACKE_zlansy_work, + LAPACKE_zlantr, + LAPACKE_zlantr_work, + LAPACKE_zlapmr, + LAPACKE_zlapmr_work, + LAPACKE_zlarfb, + LAPACKE_zlarfb_work, + LAPACKE_zlarfg, + LAPACKE_zlarfg_work, + LAPACKE_zlarft, + LAPACKE_zlarft_work, + LAPACKE_zlarfx, + LAPACKE_zlarfx_work, + LAPACKE_zlarnv, + LAPACKE_zlarnv_work, + LAPACKE_zlaset, + LAPACKE_zlaset_work, + LAPACKE_zlaswp, + LAPACKE_zlaswp_work, + LAPACKE_zlauum, + LAPACKE_zlauum_work, + LAPACKE_zpbcon, + LAPACKE_zpbcon_work, + LAPACKE_zpbequ, + LAPACKE_zpbequ_work, + LAPACKE_zpbrfs, + LAPACKE_zpbrfs_work, + LAPACKE_zpbstf, + LAPACKE_zpbstf_work, + LAPACKE_zpbsv, + LAPACKE_zpbsv_work, + LAPACKE_zpbsvx, + LAPACKE_zpbsvx_work, + LAPACKE_zpbtrf, + LAPACKE_zpbtrf_work, + LAPACKE_zpbtrs, + LAPACKE_zpbtrs_work, + LAPACKE_zpftrf, + LAPACKE_zpftrf_work, + LAPACKE_zpftri, + LAPACKE_zpftri_work, + LAPACKE_zpftrs, + LAPACKE_zpftrs_work, + LAPACKE_zpocon, + LAPACKE_zpocon_work, + LAPACKE_zpoequ, + LAPACKE_zpoequ_work, + LAPACKE_zpoequb, + LAPACKE_zpoequb_work, + LAPACKE_zporfs, + LAPACKE_zporfs_work, + LAPACKE_zposv, + LAPACKE_zposv_work, + LAPACKE_zposvx, + LAPACKE_zposvx_work, + LAPACKE_zpotrf, + LAPACKE_zpotrf_work, + LAPACKE_zpotri, + LAPACKE_zpotri_work, + LAPACKE_zpotrs, + LAPACKE_zpotrs_work, + LAPACKE_zppcon, + LAPACKE_zppcon_work, + LAPACKE_zppequ, + LAPACKE_zppequ_work, + LAPACKE_zpprfs, + LAPACKE_zpprfs_work, + LAPACKE_zppsv, + LAPACKE_zppsv_work, + LAPACKE_zppsvx, + LAPACKE_zppsvx_work, + LAPACKE_zpptrf, + LAPACKE_zpptrf_work, + LAPACKE_zpptri, + LAPACKE_zpptri_work, + LAPACKE_zpptrs, + LAPACKE_zpptrs_work, + LAPACKE_zpstrf, + LAPACKE_zpstrf_work, + LAPACKE_zptcon, + LAPACKE_zptcon_work, + LAPACKE_zpteqr, + LAPACKE_zpteqr_work, + LAPACKE_zptrfs, + LAPACKE_zptrfs_work, + LAPACKE_zptsv, + LAPACKE_zptsv_work, + LAPACKE_zptsvx, + LAPACKE_zptsvx_work, + LAPACKE_zpttrf, + LAPACKE_zpttrf_work, + LAPACKE_zpttrs, + LAPACKE_zpttrs_work, + LAPACKE_zspcon, + LAPACKE_zspcon_work, + LAPACKE_zsprfs, + LAPACKE_zsprfs_work, + LAPACKE_zspsv, + LAPACKE_zspsv_work, + LAPACKE_zspsvx, + LAPACKE_zspsvx_work, + LAPACKE_zsptrf, + LAPACKE_zsptrf_work, + LAPACKE_zsptri, + LAPACKE_zsptri_work, + LAPACKE_zsptrs, + LAPACKE_zsptrs_work, + LAPACKE_zstedc, + LAPACKE_zstedc_work, + LAPACKE_zstegr, + LAPACKE_zstegr_work, + LAPACKE_zstein, + LAPACKE_zstein_work, + LAPACKE_zstemr, + LAPACKE_zstemr_work, + LAPACKE_zsteqr, + LAPACKE_zsteqr_work, + LAPACKE_zsycon, + LAPACKE_zsycon_work, + LAPACKE_zsyconv, + LAPACKE_zsyconv_work, + LAPACKE_zsyequb, + LAPACKE_zsyequb_work, + LAPACKE_zsyrfs, + LAPACKE_zsyrfs_work, + LAPACKE_zsysv, + LAPACKE_zsysv_rook, + LAPACKE_zsysv_rook_work, + LAPACKE_zsysv_work, + LAPACKE_zsysvx, + LAPACKE_zsysvx_work, + LAPACKE_zsyswapr, + LAPACKE_zsyswapr_work, + LAPACKE_zsytrf, + LAPACKE_zsytrf_work, + LAPACKE_zsytri, + LAPACKE_zsytri2, + LAPACKE_zsytri2_work, + LAPACKE_zsytri2x, + LAPACKE_zsytri2x_work, + LAPACKE_zsytri_work, + LAPACKE_zsytrs, + LAPACKE_zsytrs2, + LAPACKE_zsytrs2_work, + LAPACKE_zsytrs_work, + LAPACKE_ztbcon, + LAPACKE_ztbcon_work, + LAPACKE_ztbrfs, + LAPACKE_ztbrfs_work, + LAPACKE_ztbtrs, + LAPACKE_ztbtrs_work, + LAPACKE_ztfsm, + LAPACKE_ztfsm_work, + LAPACKE_ztftri, + LAPACKE_ztftri_work, + LAPACKE_ztfttp, + LAPACKE_ztfttp_work, + LAPACKE_ztfttr, + LAPACKE_ztfttr_work, + LAPACKE_ztgevc, + LAPACKE_ztgevc_work, + LAPACKE_ztgexc, + LAPACKE_ztgexc_work, + LAPACKE_ztgsen, + LAPACKE_ztgsen_work, + LAPACKE_ztgsja, + LAPACKE_ztgsja_work, + LAPACKE_ztgsna, + LAPACKE_ztgsna_work, + LAPACKE_ztgsyl, + LAPACKE_ztgsyl_work, + LAPACKE_ztpcon, + LAPACKE_ztpcon_work, + LAPACKE_ztpmqrt, + LAPACKE_ztpmqrt_work, + LAPACKE_ztpqrt, + LAPACKE_ztpqrt2, + LAPACKE_ztpqrt2_work, + LAPACKE_ztpqrt_work, + LAPACKE_ztprfb, + LAPACKE_ztprfb_work, + LAPACKE_ztprfs, + LAPACKE_ztprfs_work, + LAPACKE_ztptri, + LAPACKE_ztptri_work, + LAPACKE_ztptrs, + LAPACKE_ztptrs_work, + LAPACKE_ztpttf, + LAPACKE_ztpttf_work, + LAPACKE_ztpttr, + LAPACKE_ztpttr_work, + LAPACKE_ztrcon, + LAPACKE_ztrcon_work, + LAPACKE_ztrevc, + LAPACKE_ztrevc_work, + LAPACKE_ztrexc, + LAPACKE_ztrexc_work, + LAPACKE_ztrrfs, + LAPACKE_ztrrfs_work, + LAPACKE_ztrsen, + LAPACKE_ztrsen_work, + LAPACKE_ztrsna, + LAPACKE_ztrsna_work, + LAPACKE_ztrsyl, + LAPACKE_ztrsyl_work, + LAPACKE_ztrtri, + LAPACKE_ztrtri_work, + LAPACKE_ztrtrs, + LAPACKE_ztrtrs_work, + LAPACKE_ztrttf, + LAPACKE_ztrttf_work, + LAPACKE_ztrttp, + LAPACKE_ztrttp_work, + LAPACKE_ztzrzf, + LAPACKE_ztzrzf_work, + LAPACKE_zunbdb, + LAPACKE_zunbdb_work, + LAPACKE_zuncsd, + LAPACKE_zuncsd_work, + LAPACKE_zungbr, + LAPACKE_zungbr_work, + LAPACKE_zunghr, + LAPACKE_zunghr_work, + LAPACKE_zunglq, + LAPACKE_zunglq_work, + LAPACKE_zungql, + LAPACKE_zungql_work, + LAPACKE_zungqr, + LAPACKE_zungqr_work, + LAPACKE_zungrq, + LAPACKE_zungrq_work, + LAPACKE_zungtr, + LAPACKE_zungtr_work, + LAPACKE_zunmbr, + LAPACKE_zunmbr_work, + LAPACKE_zunmhr, + LAPACKE_zunmhr_work, + LAPACKE_zunmlq, + LAPACKE_zunmlq_work, + LAPACKE_zunmql, + LAPACKE_zunmql_work, + LAPACKE_zunmqr, + LAPACKE_zunmqr_work, + LAPACKE_zunmrq, + LAPACKE_zunmrq_work, + LAPACKE_zunmrz, + LAPACKE_zunmrz_work, + LAPACKE_zunmtr, + LAPACKE_zunmtr_work, + LAPACKE_zupgtr, + LAPACKE_zupgtr_work, + LAPACKE_zupmtr, + LAPACKE_zupmtr_work, + LAPACKE_zsyr, + LAPACKE_csyr, + LAPACKE_zsyr_work, + LAPACKE_csyr_work, + LAPACKE_ilaver, ## @(SRCX_OBJ) from `lapack-3.4.1/lapacke/src/Makefile` ## Not exported: requires LAPACKE_EXTENDED to be set and depends on the @@ -2673,7 +2698,26 @@ ); #These function may need 2 underscores. -@lapack_embeded_underscore_objs=(xerbla_array, chla_transtype,); +@lapack_embeded_underscore_objs=(xerbla_array, chla_transtype, slasyf_rook, + ssytf2_rook, ssytrf_rook, ssytrs_rook, + ssytri_rook, ssycon_rook, ssysv_rook, + chetf2_rook, chetrf_rook, chetri_rook, + chetrs_rook, checon_rook, chesv_rook, + clahef_rook, clasyf_rook, + csytf2_rook, csytrf_rook, csytrs_rook, + csytri_rook, csycon_rook, csysv_rook, + dlasyf_rook, + dsytf2_rook, dsytrf_rook, dsytrs_rook, + dsytri_rook, dsycon_rook, dsysv_rook, + zhetf2_rook, zhetrf_rook, zhetri_rook, + zhetrs_rook, zhecon_rook, zhesv_rook, + zlahef_rook, zlasyf_rook, + zsytf2_rook, zsytrf_rook, zsytrs_rook, + zsytri_rook, zsycon_rook, zsysv_rook, + + + + ); if ($ARGV[8] == 1) { #ONLY_CBLAS=1 diff --git a/lapack-netlib/CMakeLists.txt b/lapack-netlib/CMakeLists.txt index 31f4d6c2c..56ecd2e61 100644 --- a/lapack-netlib/CMakeLists.txt +++ b/lapack-netlib/CMakeLists.txt @@ -188,6 +188,7 @@ else() CACHE STRING "Linker flags for shared libs" FORCE) endif( NOT LATESTLAPACK_FOUND ) +message(STATUS "BUILD TESTING : ${BUILD_TESTING}" ) if(BUILD_TESTING) add_subdirectory(TESTING) endif(BUILD_TESTING) @@ -200,7 +201,7 @@ option(LAPACKE "Build LAPACKE" OFF) # if LAPACKE_WITH_TMG is selected, we need to add those routines to LAPACKE option(LAPACKE_WITH_TMG "Build LAPACKE with tmglib routines" OFF) if (LAPACKE_WITH_TMG) - option(LAPACKE "Build LAPACKE" ON) + set(LAPACKE ON) if(NOT BUILD_TESTING) add_subdirectory(TESTING/MATGEN) endif(NOT BUILD_TESTING) diff --git a/lapack-netlib/DOCS/Doxyfile b/lapack-netlib/DOCS/Doxyfile index 9098aa87f..0925c3180 100644 --- a/lapack-netlib/DOCS/Doxyfile +++ b/lapack-netlib/DOCS/Doxyfile @@ -647,7 +647,7 @@ INPUT_ENCODING = UTF-8 # *.hxx *.hpp *.h++ *.idl *.odl *.cs *.php *.php3 *.inc *.m *.mm *.dox *.py # *.f90 *.f *.for *.vhd *.vhdl -FILE_PATTERNS = *.f +FILE_PATTERNS = * # The RECURSIVE tag can be used to turn specify whether or not subdirectories # should be searched for input files as well. Possible values are YES and NO. diff --git a/lapack-netlib/DOCS/psfig.tex b/lapack-netlib/DOCS/psfig.tex deleted file mode 100644 index e1e65a92c..000000000 --- a/lapack-netlib/DOCS/psfig.tex +++ /dev/null @@ -1,391 +0,0 @@ -% Psfig/TeX Release 1.2 -% dvi2ps-li version -% -% All software, documentation, and related files in this distribution of -% psfig/tex are Copyright 1987, 1988 Trevor J. Darrell -% -% Permission is granted for use and non-profit distribution of psfig/tex -% providing that this notice be clearly maintained, but the right to -% distribute any portion of psfig/tex for profit or as part of any commercial -% product is specifically reserved for the author. -% -% $Header$ -% $Source$ -% -% Thanks to Greg Hager (GDH) and Ned Batchelder for their contributions -% to this project. -% -\catcode`\@=11\relax -\newwrite\@unused -\def\typeout#1{{\let\protect\string\immediate\write\@unused{#1}}} -\typeout{psfig/tex 1.2-dvi2ps-li} - -%% Here's how you define your figure path. Should be set up with null -%% default and a user useable definition. - -\def\figurepath{./} -\def\psfigurepath#1{\edef\figurepath{#1}} - -% -% @psdo control structure -- similar to Latex @for. -% I redefined these with different names so that psfig can -% be used with TeX as well as LaTeX, and so that it will not -% be vunerable to future changes in LaTeX's internal -% control structure, -% -\def\@nnil{\@nil} -\def\@empty{} -\def\@psdonoop#1\@@#2#3{} -\def\@psdo#1:=#2\do#3{\edef\@psdotmp{#2}\ifx\@psdotmp\@empty \else - \expandafter\@psdoloop#2,\@nil,\@nil\@@#1{#3}\fi} -\def\@psdoloop#1,#2,#3\@@#4#5{\def#4{#1}\ifx #4\@nnil \else - #5\def#4{#2}\ifx #4\@nnil \else#5\@ipsdoloop #3\@@#4{#5}\fi\fi} -\def\@ipsdoloop#1,#2\@@#3#4{\def#3{#1}\ifx #3\@nnil - \let\@nextwhile=\@psdonoop \else - #4\relax\let\@nextwhile=\@ipsdoloop\fi\@nextwhile#2\@@#3{#4}} -\def\@tpsdo#1:=#2\do#3{\xdef\@psdotmp{#2}\ifx\@psdotmp\@empty \else - \@tpsdoloop#2\@nil\@nil\@@#1{#3}\fi} -\def\@tpsdoloop#1#2\@@#3#4{\def#3{#1}\ifx #3\@nnil - \let\@nextwhile=\@psdonoop \else - #4\relax\let\@nextwhile=\@tpsdoloop\fi\@nextwhile#2\@@#3{#4}} -% -% -\def\psdraft{ - \def\@psdraft{0} - %\typeout{draft level now is \@psdraft \space . } -} -\def\psfull{ - \def\@psdraft{100} - %\typeout{draft level now is \@psdraft \space . } -} -\psfull -\newif\if@prologfile -\newif\if@postlogfile -\newif\if@noisy -\def\pssilent{ - \@noisyfalse -} -\def\psnoisy{ - \@noisytrue -} -\psnoisy -%%% These are for the option list. -%%% A specification of the form a = b maps to calling \@p@@sa{b} -\newif\if@bbllx -\newif\if@bblly -\newif\if@bburx -\newif\if@bbury -\newif\if@height -\newif\if@width -\newif\if@rheight -\newif\if@rwidth -\newif\if@clip -\newif\if@verbose -\def\@p@@sclip#1{\@cliptrue} - -%%% GDH 7/26/87 -- changed so that it first looks in the local directory, -%%% then in a specified global directory for the ps file. - -\def\@p@@sfile#1{\def\@p@sfile{null}% - \openin1=#1 - \ifeof1\closein1% - \openin1=\figurepath#1 - \ifeof1\typeout{Error, File #1 not found} - \else\closein1 - \edef\@p@sfile{\figurepath#1}% - \fi% - \else\closein1% - \def\@p@sfile{#1}% - \fi} -\def\@p@@sfigure#1{\def\@p@sfile{null}% - \openin1=#1 - \ifeof1\closein1% - \openin1=\figurepath#1 - \ifeof1\typeout{Error, File #1 not found} - \else\closein1 - \def\@p@sfile{\figurepath#1}% - \fi% - \else\closein1% - \def\@p@sfile{#1}% - \fi} - -\def\@p@@sbbllx#1{ - %\typeout{bbllx is #1} - \@bbllxtrue - \dimen100=#1 - \edef\@p@sbbllx{\number\dimen100} -} -\def\@p@@sbblly#1{ - %\typeout{bblly is #1} - \@bbllytrue - \dimen100=#1 - \edef\@p@sbblly{\number\dimen100} -} -\def\@p@@sbburx#1{ - %\typeout{bburx is #1} - \@bburxtrue - \dimen100=#1 - \edef\@p@sbburx{\number\dimen100} -} -\def\@p@@sbbury#1{ - %\typeout{bbury is #1} - \@bburytrue - \dimen100=#1 - \edef\@p@sbbury{\number\dimen100} -} -\def\@p@@sheight#1{ - \@heighttrue - \dimen100=#1 - \edef\@p@sheight{\number\dimen100} - %\typeout{Height is \@p@sheight} -} -\def\@p@@swidth#1{ - %\typeout{Width is #1} - \@widthtrue - \dimen100=#1 - \edef\@p@swidth{\number\dimen100} -} -\def\@p@@srheight#1{ - %\typeout{Reserved height is #1} - \@rheighttrue - \dimen100=#1 - \edef\@p@srheight{\number\dimen100} -} -\def\@p@@srwidth#1{ - %\typeout{Reserved width is #1} - \@rwidthtrue - \dimen100=#1 - \edef\@p@srwidth{\number\dimen100} -} -\def\@p@@ssilent#1{ - \@verbosefalse -} -\def\@p@@sprolog#1{\@prologfiletrue\def\@prologfileval{#1}} -\def\@p@@spostlog#1{\@postlogfiletrue\def\@postlogfileval{#1}} -\def\@cs@name#1{\csname #1\endcsname} -\def\@setparms#1=#2,{\@cs@name{@p@@s#1}{#2}} -% -% initialize the defaults (size the size of the figure) -% -\def\ps@init@parms{ - \@bbllxfalse \@bbllyfalse - \@bburxfalse \@bburyfalse - \@heightfalse \@widthfalse - \@rheightfalse \@rwidthfalse - \def\@p@sbbllx{}\def\@p@sbblly{} - \def\@p@sbburx{}\def\@p@sbbury{} - \def\@p@sheight{}\def\@p@swidth{} - \def\@p@srheight{}\def\@p@srwidth{} - \def\@p@sfile{} - \def\@p@scost{10} - \def\@sc{} - \@prologfilefalse - \@postlogfilefalse - \@clipfalse - \if@noisy - \@verbosetrue - \else - \@verbosefalse - \fi - -} -% -% Go through the options setting things up. -% -\def\parse@ps@parms#1{ - \@psdo\@psfiga:=#1\do - {\expandafter\@setparms\@psfiga,}} -% -% Compute bb height and width -% -\newif\ifno@bb -\newif\ifnot@eof -\newread\ps@stream -\def\bb@missing{ - \if@verbose{ - \typeout{psfig: searching \@p@sfile \space for bounding box} - }\fi - \openin\ps@stream=\@p@sfile - \no@bbtrue - \not@eoftrue - \catcode`\%=12 - \loop - \read\ps@stream to \line@in - \global\toks200=\expandafter{\line@in} - \ifeof\ps@stream \not@eoffalse \fi - %\typeout{ looking at :: \the\toks200 } - \@bbtest{\toks200} - \if@bbmatch\not@eoffalse\expandafter\bb@cull\the\toks200\fi - \ifnot@eof \repeat - \catcode`\%=14 -} -\catcode`\%=12 -\newif\if@bbmatch -\def\@bbtest#1{\expandafter\@a@\the#1%%BoundingBox:\@bbtest\@a@} -\long\def\@a@#1%%BoundingBox:#2#3\@a@{\ifx\@bbtest#2\@bbmatchfalse\else\@bbmatchtrue\fi} -\long\def\bb@cull#1 #2 #3 #4 #5 { - \dimen100=#2 bp\edef\@p@sbbllx{\number\dimen100} - \dimen100=#3 bp\edef\@p@sbblly{\number\dimen100} - \dimen100=#4 bp\edef\@p@sbburx{\number\dimen100} - \dimen100=#5 bp\edef\@p@sbbury{\number\dimen100} - \no@bbfalse -} -\catcode`\%=14 -% -\def\compute@bb{ - \no@bbfalse - \if@bbllx \else \no@bbtrue \fi - \if@bblly \else \no@bbtrue \fi - \if@bburx \else \no@bbtrue \fi - \if@bbury \else \no@bbtrue \fi - \ifno@bb \bb@missing \fi - \ifno@bb \typeout{FATAL ERROR: no bb supplied or found} - \no-bb-error - \fi - % - \count203=\@p@sbburx - \count204=\@p@sbbury - \advance\count203 by -\@p@sbbllx - \advance\count204 by -\@p@sbblly - \edef\@bbw{\number\count203} - \edef\@bbh{\number\count204} - %\typeout{ bbh = \@bbh, bbw = \@bbw } -} -% -% \in@hundreds performs #1 * (#2 / #3) correct to the hundreds, -% then leaves the result in @result -% -\def\in@hundreds#1#2#3{\count240=#2 \count241=#3 - \count100=\count240 % 100 is first digit #2/#3 - \divide\count100 by \count241 - \count101=\count100 - \multiply\count101 by \count241 - \advance\count240 by -\count101 - \multiply\count240 by 10 - \count101=\count240 %101 is second digit of #2/#3 - \divide\count101 by \count241 - \count102=\count101 - \multiply\count102 by \count241 - \advance\count240 by -\count102 - \multiply\count240 by 10 - \count102=\count240 % 102 is the third digit - \divide\count102 by \count241 - \count200=#1\count205=0 - \count201=\count200 - \multiply\count201 by \count100 - \advance\count205 by \count201 - \count201=\count200 - \divide\count201 by 10 - \multiply\count201 by \count101 - \advance\count205 by \count201 - % - \count201=\count200 - \divide\count201 by 100 - \multiply\count201 by \count102 - \advance\count205 by \count201 - % - \edef\@result{\number\count205} -} -\def\compute@wfromh{ - % computing : width = height * (bbw / bbh) - \in@hundreds{\@p@sheight}{\@bbw}{\@bbh} - %\typeout{ \@p@sheight * \@bbw / \@bbh, = \@result } - \edef\@p@swidth{\@result} - %\typeout{w from h: width is \@p@swidth} -} -\def\compute@hfromw{ - % computing : height = width * (bbh / bbw) - \in@hundreds{\@p@swidth}{\@bbh}{\@bbw} - %\typeout{ \@p@swidth * \@bbh / \@bbw = \@result } - \edef\@p@sheight{\@result} - %\typeout{h from w : height is \@p@sheight} -} -\def\compute@handw{ - \if@height - \if@width - \else - \compute@wfromh - \fi - \else - \if@width - \compute@hfromw - \else - \edef\@p@sheight{\@bbh} - \edef\@p@swidth{\@bbw} - \fi - \fi -} -\def\compute@resv{ - \if@rheight \else \edef\@p@srheight{\@p@sheight} \fi - \if@rwidth \else \edef\@p@srwidth{\@p@swidth} \fi -} -% -% Compute any missing values -\def\compute@sizes{ - \compute@bb - \compute@handw - \compute@resv -} -% -% \psfig -% usage : \psfig{file=, height=, width=, bbllx=, bblly=, bburx=, bbury=, -% rheight=, rwidth=, clip=} -% -% "clip=" is a switch and takes no value, but the `=' must be present. -\def\psfig#1{\vbox { - % do a zero width hard space so that a single - % \psfig in a centering enviornment will behave nicely - %{\setbox0=\hbox{\ }\ \hskip-\wd0} - % - \ps@init@parms - \parse@ps@parms{#1} - \compute@sizes - % - \ifnum\@p@scost<\@psdraft{ - \if@verbose{ - \typeout{psfig: including \@p@sfile \space } - }\fi - % - \special{ pstext="\@p@swidth \space - \@p@sheight \space - \@p@sbbllx \space \@p@sbblly \space - \@p@sbburx \space - \@p@sbbury \space startTexFig" \space} - \if@clip{ - \if@verbose{ - \typeout{(clip)} - }\fi - \special{ pstext="doclip \space"} - }\fi - \if@prologfile - \special{psfile=\@prologfileval \space } \fi - \special{psfile=\@p@sfile \space } - \if@postlogfile - \special{psfile=\@postlogfileval \space } \fi - \special{pstext=endTexFig \space } - % Create the vbox to reserve the space for the figure - \vbox to \@p@srheight true sp{ - \hbox to \@p@srwidth true sp{ - \hss - } - \vss - } - }\else{ - % draft figure, just reserve the space and print the - % path name. - \vbox to \@p@srheight true sp{ - \vss - \hbox to \@p@srwidth true sp{ - \hss - \if@verbose{ - \@p@sfile - }\fi - \hss - } - \vss - } - }\fi -}} -\def\psglobal{\typeout{psfig: PSGLOBAL is OBSOLETE; use psprint -m instead}} -\catcode`\@=12\relax - diff --git a/lapack-netlib/INSTALL/dlamch.f b/lapack-netlib/INSTALL/dlamch.f index eb307e5e1..25c2c8e6e 100644 --- a/lapack-netlib/INSTALL/dlamch.f +++ b/lapack-netlib/INSTALL/dlamch.f @@ -72,6 +72,10 @@ CHARACTER CMACH * .. * +* .. Scalar Arguments .. + DOUBLE PRECISION A, B +* .. +* * ===================================================================== * * .. Parameters .. diff --git a/lapack-netlib/INSTALL/ilaver.f b/lapack-netlib/INSTALL/ilaver.f index a00cbbccf..c33fef7c5 100644 --- a/lapack-netlib/INSTALL/ilaver.f +++ b/lapack-netlib/INSTALL/ilaver.f @@ -41,14 +41,14 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup auxOTHERauxiliary * * ===================================================================== SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * September 2012 @@ -58,8 +58,8 @@ INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH * ===================================================================== VERS_MAJOR = 3 - VERS_MINOR = 4 - VERS_PATCH = 2 + VERS_MINOR = 5 + VERS_PATCH = 0 * ===================================================================== * RETURN diff --git a/lapack-netlib/INSTALL/make.inc.ALPHA b/lapack-netlib/INSTALL/make.inc.ALPHA index f38aa8934..0a3f468ce 100644 --- a/lapack-netlib/INSTALL/make.inc.ALPHA +++ b/lapack-netlib/INSTALL/make.inc.ALPHA @@ -1,7 +1,7 @@ #################################################################### # LAPACK make include file. # -# LAPACK, Version 3.4.1 # -# April 2012 # +# LAPACK, Version 3.5.0 # +# November 2013 # #################################################################### # SHELL = /bin/sh diff --git a/lapack-netlib/INSTALL/make.inc.HPPA b/lapack-netlib/INSTALL/make.inc.HPPA index aee46d068..396d62275 100644 --- a/lapack-netlib/INSTALL/make.inc.HPPA +++ b/lapack-netlib/INSTALL/make.inc.HPPA @@ -1,7 +1,7 @@ #################################################################### # LAPACK make include file. # -# LAPACK, Version 3.4.1 # -# April 2012 # +# LAPACK, Version 3.5.0 # +# November 2013 # #################################################################### # SHELL = /bin/sh diff --git a/lapack-netlib/INSTALL/make.inc.IRIX64 b/lapack-netlib/INSTALL/make.inc.IRIX64 index 00d7a20fc..20925374a 100644 --- a/lapack-netlib/INSTALL/make.inc.IRIX64 +++ b/lapack-netlib/INSTALL/make.inc.IRIX64 @@ -1,7 +1,7 @@ #################################################################### # LAPACK make include file. # -# LAPACK, Version 3.4.1 # -# April 2012 # +# LAPACK, Version 3.5.0 # +# November 2013 # #################################################################### # SHELL = /sbin/sh diff --git a/lapack-netlib/INSTALL/make.inc.O2K b/lapack-netlib/INSTALL/make.inc.O2K index 48a45a713..c3ab2bdca 100644 --- a/lapack-netlib/INSTALL/make.inc.O2K +++ b/lapack-netlib/INSTALL/make.inc.O2K @@ -1,7 +1,7 @@ #################################################################### # LAPACK make include file. # -# LAPACK, Version 3.4.1 # -# April 2012 # +# LAPACK, Version 3.5.0 # +# November 2013 # #################################################################### # SHELL = /sbin/sh diff --git a/lapack-netlib/INSTALL/make.inc.SGI5 b/lapack-netlib/INSTALL/make.inc.SGI5 index d57c1e287..def1b8099 100644 --- a/lapack-netlib/INSTALL/make.inc.SGI5 +++ b/lapack-netlib/INSTALL/make.inc.SGI5 @@ -1,7 +1,7 @@ #################################################################### # LAPACK make include file. # -# LAPACK, Version 3.4.1 # -# April 2012 # +# LAPACK, Version 3.5.0 # +# November 2013 # #################################################################### # SHELL = /sbin/sh diff --git a/lapack-netlib/INSTALL/make.inc.SUN4 b/lapack-netlib/INSTALL/make.inc.SUN4 index d8513d393..b2c0239bb 100644 --- a/lapack-netlib/INSTALL/make.inc.SUN4 +++ b/lapack-netlib/INSTALL/make.inc.SUN4 @@ -1,7 +1,7 @@ #################################################################### # LAPACK make include file. # -# LAPACK, Version 3.4.1 # -# April 2012 # +# LAPACK, Version 3.5.0 # +# November 2013 # #################################################################### # SHELL = /bin/sh diff --git a/lapack-netlib/INSTALL/make.inc.SUN4SOL2 b/lapack-netlib/INSTALL/make.inc.SUN4SOL2 index 9b690c375..3302a38d8 100644 --- a/lapack-netlib/INSTALL/make.inc.SUN4SOL2 +++ b/lapack-netlib/INSTALL/make.inc.SUN4SOL2 @@ -1,7 +1,7 @@ #################################################################### # LAPACK make include file. # -# LAPACK, Version 3.4.1 # -# April 2012 # +# LAPACK, Version 3.5.0 # +# November 2013 # #################################################################### # SHELL = /bin/sh diff --git a/lapack-netlib/INSTALL/make.inc.XLF b/lapack-netlib/INSTALL/make.inc.XLF index 903dc2fe2..5b854b659 100644 --- a/lapack-netlib/INSTALL/make.inc.XLF +++ b/lapack-netlib/INSTALL/make.inc.XLF @@ -1,7 +1,7 @@ #################################################################### # LAPACK make include file. # -# LAPACK, Version 3.4.1 # -# April 2012 # +# LAPACK, Version 3.5.0 # +# November 2013 # #################################################################### # SHELL = /bin/sh diff --git a/lapack-netlib/INSTALL/make.inc.gfortran b/lapack-netlib/INSTALL/make.inc.gfortran index 94b5d178c..a9e5c34d5 100644 --- a/lapack-netlib/INSTALL/make.inc.gfortran +++ b/lapack-netlib/INSTALL/make.inc.gfortran @@ -1,7 +1,7 @@ #################################################################### # LAPACK make include file. # -# LAPACK, Version 3.4.1 # -# April 2012 # +# LAPACK, Version 3.5.0 # +# November 2013 # #################################################################### # SHELL = /bin/sh @@ -13,9 +13,9 @@ SHELL = /bin/sh # desired load options for your machine. # FORTRAN = gfortran -OPTS = -O2 +OPTS = -O2 -frecursive DRVOPTS = $(OPTS) -NOOPT = -O0 +NOOPT = -O0 -frecursive LOADER = gfortran LOADOPTS = # diff --git a/lapack-netlib/INSTALL/make.inc.gfortran_debug b/lapack-netlib/INSTALL/make.inc.gfortran_debug index edf812a1a..79ffddf14 100644 --- a/lapack-netlib/INSTALL/make.inc.gfortran_debug +++ b/lapack-netlib/INSTALL/make.inc.gfortran_debug @@ -1,7 +1,7 @@ #################################################################### # LAPACK make include file. # -# LAPACK, Version 3.4.1 # -# April 2012 # +# LAPACK, Version 3.5.0 # +# November 2013 # #################################################################### # SHELL = /bin/sh @@ -12,10 +12,10 @@ SHELL = /bin/sh # selected. Define LOADER and LOADOPTS to refer to the loader # and desired load options for your machine. # -FORTRAN = gfortran -fimplicit-none -g +FORTRAN = gfortran -fimplicit-none -g -frecursive OPTS = DRVOPTS = $(OPTS) -NOOPT = -g -O0 +NOOPT = -g -O0 -frecursive LOADER = gfortran -g LOADOPTS = # diff --git a/lapack-netlib/INSTALL/make.inc.ifort b/lapack-netlib/INSTALL/make.inc.ifort index 9d476d859..962689f59 100644 --- a/lapack-netlib/INSTALL/make.inc.ifort +++ b/lapack-netlib/INSTALL/make.inc.ifort @@ -1,7 +1,7 @@ #################################################################### # LAPACK make include file. # -# LAPACK, Version 3.4.1 # -# April 2012 # +# LAPACK, Version 3.5.0 # +# November 2013 # #################################################################### # SHELL = /bin/sh diff --git a/lapack-netlib/INSTALL/make.inc.pgf95 b/lapack-netlib/INSTALL/make.inc.pgf95 index bdf371ca1..95ba49f36 100644 --- a/lapack-netlib/INSTALL/make.inc.pgf95 +++ b/lapack-netlib/INSTALL/make.inc.pgf95 @@ -1,7 +1,7 @@ #################################################################### # LAPACK make include file. # -# LAPACK, Version 3.4.1 # -# April 2012 # +# LAPACK, Version 3.5.0 # +# November 2013 # #################################################################### # SHELL = /bin/sh diff --git a/lapack-netlib/INSTALL/make.inc.pghpf b/lapack-netlib/INSTALL/make.inc.pghpf index 08c5cceef..6c8b48633 100644 --- a/lapack-netlib/INSTALL/make.inc.pghpf +++ b/lapack-netlib/INSTALL/make.inc.pghpf @@ -1,7 +1,7 @@ #################################################################### # LAPACK make include file. # -# LAPACK, Version 3.4.1 # -# April 2012 # +# LAPACK, Version 3.5.0 # +# November 2013 # #################################################################### # SHELL = /bin/sh diff --git a/lapack-netlib/README b/lapack-netlib/README index c236f6adf..f3fbab1f6 100644 --- a/lapack-netlib/README +++ b/lapack-netlib/README @@ -20,6 +20,7 @@ VERSION 3.3.1 : April 2011 VERSION 3.4.0 : November 2011 VERSION 3.4.1 : April 2012 VERSION 3.4.2 : September 2012 +VERSION 3.5.0 : November 2013 LAPACK is a library of Fortran 90 with subroutines for solving the most commonly occurring problems in numerical linear algebra. @@ -40,8 +41,8 @@ very much on the efficiency of the BLAS. ================= LAPACK INSTALLATION: - - LAPACK can be installed with make. Configuration haev to be set in the - make.inc file. A make.inc.example for a Linux mahcine running GNU compilers + - LAPACK can be installed with make. Configuration have to be set in the + make.inc file. A make.inc.example for a Linux machine running GNU compilers is given in the main directory. Some specific make.inc are also available in the INSTALL directory - LAPACK includes also the CMAKE build. You will need to have CMAKE installed diff --git a/lapack-netlib/SRC/CMakeLists.txt b/lapack-netlib/SRC/CMakeLists.txt index 0150ccc0f..d618d6e01 100644 --- a/lapack-netlib/SRC/CMakeLists.txt +++ b/lapack-netlib/SRC/CMakeLists.txt @@ -113,7 +113,7 @@ set(SLASRC slaqtr.f slar1v.f slar2v.f ilaslr.f ilaslc.f slarf.f slarfb.f slarfg.f slarfgp.f slarft.f slarfx.f slargv.f slarrv.f slartv.f - slarz.f slarzb.f slarzt.f slaswp.f slasy2.f slasyf.f + slarz.f slarzb.f slarzt.f slaswp.f slasy2.f slasyf.f slasyf_rook.f slatbs.f slatdf.f slatps.f slatrd.f slatrs.f slatrz.f slatzm.f slauu2.f slauum.f sopgtr.f sopmtr.f sorg2l.f sorg2r.f sorgbr.f sorghr.f sorgl2.f sorglq.f sorgql.f sorgqr.f sorgr2.f @@ -134,6 +134,8 @@ set(SLASRC ssygst.f ssygv.f ssygvd.f ssygvx.f ssyrfs.f ssysv.f ssysvx.f ssytd2.f ssytf2.f ssytrd.f ssytrf.f ssytri.f ssytri2.f ssytri2x.f ssyswapr.f ssytrs.f ssytrs2.f ssyconv.f + ssytf2_rook.f ssytrf_rook.f ssytrs_rook.f + ssytri_rook.f ssycon_rook.f ssysv_rook.f stbcon.f stbrfs.f stbtrs.f stgevc.f stgex2.f stgexc.f stgsen.f stgsja.f stgsna.f stgsy2.f stgsyl.f stpcon.f stprfs.f stptri.f @@ -144,7 +146,8 @@ set(SLASRC stfttr.f stpttf.f stpttr.f strttf.f strttp.f sgejsv.f sgesvj.f sgsvj0.f sgsvj1.f sgeequb.f ssyequb.f spoequb.f sgbequb.f - sbbcsd.f slapmr.f sorbdb.f sorcsd.f + sbbcsd.f slapmr.f sorbdb.f sorbdb1.f sorbdb2.f sorbdb3.f sorbdb4.f + sorbdb5.f sorbdb6.f sorcsd.f sorcsd2by1.f sgeqrt.f sgeqrt2.f sgeqrt3.f sgemqrt.f stpqrt.f stpqrt2.f stpmqrt.f stprfb.f ) @@ -176,15 +179,17 @@ set(CLASRC checon.f cheev.f cheevd.f cheevr.f cheevx.f chegs2.f chegst.f chegv.f chegvd.f chegvx.f cherfs.f chesv.f chesvx.f chetd2.f chetf2.f chetrd.f - chetrf.f chetri.f chetri2.f chetri2x.f cheswapr.f - chetrs.f chetrs2.f chgeqz.f chpcon.f chpev.f chpevd.f + chetrf.f chetri.f chetri2.f chetri2x.f cheswapr.f + chetrs.f chetrs2.f + chetf2_rook.f chetrf_rook.f chetri_rook.f chetrs_rook.f checon_rook.f chesv_rook.f + chgeqz.f chpcon.f chpev.f chpevd.f chpevx.f chpgst.f chpgv.f chpgvd.f chpgvx.f chprfs.f chpsv.f chpsvx.f chptrd.f chptrf.f chptri.f chptrs.f chsein.f chseqr.f clabrd.f clacgv.f clacon.f clacn2.f clacp2.f clacpy.f clacrm.f clacrt.f cladiv.f claed0.f claed7.f claed8.f claein.f claesy.f claev2.f clags2.f clagtm.f - clahef.f clahqr.f + clahef.f clahef_rook.f clahqr.f clahrd.f clahr2.f claic1.f clals0.f clalsa.f clalsd.f clangb.f clange.f clangt.f clanhb.f clanhe.f clanhp.f clanhs.f clanht.f clansb.f clansp.f clansy.f clantb.f @@ -195,7 +200,7 @@ set(CLASRC clarf.f clarfb.f clarfg.f clarfgp.f clarft.f clarfx.f clargv.f clarnv.f clarrv.f clartg.f clartv.f clarz.f clarzb.f clarzt.f clascl.f claset.f clasr.f classq.f - claswp.f clasyf.f clatbs.f clatdf.f clatps.f clatrd.f clatrs.f clatrz.f + claswp.f clasyf.f clasyf_rook.f clatbs.f clatdf.f clatps.f clatrd.f clatrs.f clatrz.f clatzm.f clauu2.f clauum.f cpbcon.f cpbequ.f cpbrfs.f cpbstf.f cpbsv.f cpbsvx.f cpbtf2.f cpbtrf.f cpbtrs.f cpocon.f cpoequ.f cporfs.f cposv.f cposvx.f cpotf2.f cpotrf.f cpotri.f cpotrs.f cpstrf.f cpstf2.f @@ -207,6 +212,8 @@ set(CLASRC csyr.f csyrfs.f csysv.f csysvx.f csytf2.f csytrf.f csytri.f csytri2.f csytri2x.f csyswapr.f csytrs.f csytrs2.f csyconv.f + csytf2_rook.f csytrf_rook.f csytrs_rook.f + csytri_rook.f csycon_rook.f csysv_rook.f ctbcon.f ctbrfs.f ctbtrs.f ctgevc.f ctgex2.f ctgexc.f ctgsen.f ctgsja.f ctgsna.f ctgsy2.f ctgsyl.f ctpcon.f ctprfs.f ctptri.f @@ -219,7 +226,8 @@ set(CLASRC chfrk.f ctfttp.f clanhf.f cpftrf.f cpftri.f cpftrs.f ctfsm.f ctftri.f ctfttr.f ctpttf.f ctpttr.f ctrttf.f ctrttp.f cgeequb.f cgbequb.f csyequb.f cpoequb.f cheequb.f - cbbcsd.f clapmr.f cunbdb.f cuncsd.f + cbbcsd.f clapmr.f cunbdb.f cunbdb1.f cunbdb2.f cunbdb3.f cunbdb4.f + cunbdb5.f cunbdb6.f cuncsd.f cuncsd2by1.f cgeqrt.f cgeqrt2.f cgeqrt3.f cgemqrt.f ctpqrt.f ctpqrt2.f ctpmqrt.f ctprfb.f) @@ -261,7 +269,7 @@ set(DLASRC dlaqtr.f dlar1v.f dlar2v.f iladlr.f iladlc.f dlarf.f dlarfb.f dlarfg.f dlarfgp.f dlarft.f dlarfx.f dlargv.f dlarrv.f dlartv.f - dlarz.f dlarzb.f dlarzt.f dlaswp.f dlasy2.f dlasyf.f + dlarz.f dlarzb.f dlarzt.f dlaswp.f dlasy2.f dlasyf.f dlasyf_rook.f dlatbs.f dlatdf.f dlatps.f dlatrd.f dlatrs.f dlatrz.f dlatzm.f dlauu2.f dlauum.f dopgtr.f dopmtr.f dorg2l.f dorg2r.f dorgbr.f dorghr.f dorgl2.f dorglq.f dorgql.f dorgqr.f dorgr2.f @@ -283,6 +291,8 @@ set(DLASRC dsysv.f dsysvx.f dsytd2.f dsytf2.f dsytrd.f dsytrf.f dsytri.f dsytrs.f dsytrs2.f dsytri2.f dsytri2x.f dsyswapr.f dsyconv.f + dsytf2_rook.f dsytrf_rook.f dsytrs_rook.f + dsytri_rook.f dsycon_rook.f dsysv_rook.f dtbcon.f dtbrfs.f dtbtrs.f dtgevc.f dtgex2.f dtgexc.f dtgsen.f dtgsja.f dtgsna.f dtgsy2.f dtgsyl.f dtpcon.f dtprfs.f dtptri.f @@ -294,7 +304,8 @@ set(DLASRC dtfttr.f dtpttf.f dtpttr.f dtrttf.f dtrttp.f dgejsv.f dgesvj.f dgsvj0.f dgsvj1.f dgeequb.f dsyequb.f dpoequb.f dgbequb.f - dbbcsd.f dlapmr.f dorbdb.f dorcsd.f + dbbcsd.f dlapmr.f dorbdb.f dorbdb1.f dorbdb2.f dorbdb3.f dorbdb4.f + dorbdb5.f dorbdb6.f dorcsd.f dorcsd2by1.f dgeqrt.f dgeqrt2.f dgeqrt3.f dgemqrt.f dtpqrt.f dtpqrt2.f dtpmqrt.f dtprfb.f ) @@ -324,14 +335,16 @@ set(ZLASRC zhegv.f zhegvd.f zhegvx.f zherfs.f zhesv.f zhesvx.f zhetd2.f zhetf2.f zhetrd.f zhetrf.f zhetri.f zhetri2.f zhetri2x.f zheswapr.f - zhetrs.f zhetrs2.f zhgeqz.f zhpcon.f zhpev.f zhpevd.f + zhetrs.f zhetrs2.f + zhetf2_rook.f zhetrf_rook.f zhetri_rook.f zhetrs_rook.f zhecon_rook.f zhesv_rook.f + zhgeqz.f zhpcon.f zhpev.f zhpevd.f zhpevx.f zhpgst.f zhpgv.f zhpgvd.f zhpgvx.f zhprfs.f zhpsv.f zhpsvx.f zhptrd.f zhptrf.f zhptri.f zhptrs.f zhsein.f zhseqr.f zlabrd.f zlacgv.f zlacon.f zlacn2.f zlacp2.f zlacpy.f zlacrm.f zlacrt.f zladiv.f zlaed0.f zlaed7.f zlaed8.f zlaein.f zlaesy.f zlaev2.f zlags2.f zlagtm.f - zlahef.f zlahqr.f + zlahef.f zlahef_rook.f zlahqr.f zlahrd.f zlahr2.f zlaic1.f zlals0.f zlalsa.f zlalsd.f zlangb.f zlange.f zlangt.f zlanhb.f zlanhe.f @@ -344,7 +357,7 @@ set(ZLASRC zlarfg.f zlarfgp.f zlarft.f zlarfx.f zlargv.f zlarnv.f zlarrv.f zlartg.f zlartv.f zlarz.f zlarzb.f zlarzt.f zlascl.f zlaset.f zlasr.f - zlassq.f zlaswp.f zlasyf.f + zlassq.f zlaswp.f zlasyf.f zlasyf_rook.f zlatbs.f zlatdf.f zlatps.f zlatrd.f zlatrs.f zlatrz.f zlatzm.f zlauu2.f zlauum.f zpbcon.f zpbequ.f zpbrfs.f zpbstf.f zpbsv.f zpbsvx.f zpbtf2.f zpbtrf.f zpbtrs.f zpocon.f zpoequ.f zporfs.f @@ -357,6 +370,8 @@ set(ZLASRC zsyr.f zsyrfs.f zsysv.f zsysvx.f zsytf2.f zsytrf.f zsytri.f zsytri2.f zsytri2x.f zsyswapr.f zsytrs.f zsytrs2.f zsyconv.f + zsytf2_rook.f zsytrf_rook.f zsytrs_rook.f + zsytri_rook.f zsycon_rook.f zsysv_rook.f ztbcon.f ztbrfs.f ztbtrs.f ztgevc.f ztgex2.f ztgexc.f ztgsen.f ztgsja.f ztgsna.f ztgsy2.f ztgsyl.f ztpcon.f ztprfs.f ztptri.f @@ -371,7 +386,8 @@ set(ZLASRC zhfrk.f ztfttp.f zlanhf.f zpftrf.f zpftri.f zpftrs.f ztfsm.f ztftri.f ztfttr.f ztpttf.f ztpttr.f ztrttf.f ztrttp.f zgeequb.f zgbequb.f zsyequb.f zpoequb.f zheequb.f - zbbcsd.f zlapmr.f zunbdb.f zuncsd.f + zbbcsd.f zlapmr.f zunbdb.f zunbdb1.f zunbdb2.f zunbdb3.f zunbdb4.f + zunbdb5.f zunbdb6.f zuncsd.f zuncsd2by1.f zgeqrt.f zgeqrt2.f zgeqrt3.f zgemqrt.f ztpqrt.f ztpqrt2.f ztpmqrt.f ztprfb.f) diff --git a/lapack-netlib/SRC/Makefile b/lapack-netlib/SRC/Makefile index 92dffdd5f..85154280f 100644 --- a/lapack-netlib/SRC/Makefile +++ b/lapack-netlib/SRC/Makefile @@ -118,7 +118,7 @@ SLASRC = \ slaqtr.o slar1v.o slar2v.o ilaslr.o ilaslc.o \ slarf.o slarfb.o slarfg.o slarfgp.o slarft.o slarfx.o slargv.o \ slarrv.o slartv.o \ - slarz.o slarzb.o slarzt.o slasy2.o slasyf.o \ + slarz.o slarzb.o slarzt.o slasy2.o slasyf.o slasyf_rook.o \ slatbs.o slatdf.o slatps.o slatrd.o slatrs.o slatrz.o slatzm.o \ sopgtr.o sopmtr.o sorg2l.o sorg2r.o \ sorgbr.o sorghr.o sorgl2.o sorglq.o sorgql.o sorgqr.o sorgr2.o \ @@ -140,6 +140,8 @@ SLASRC = \ ssygst.o ssygv.o ssygvd.o ssygvx.o ssyrfs.o ssysv.o ssysvx.o \ ssytd2.o ssytf2.o ssytrd.o ssytrf.o ssytri.o ssytri2.o ssytri2x.o \ ssyswapr.o ssytrs.o ssytrs2.o ssyconv.o \ + ssytf2_rook.o ssytrf_rook.o ssytrs_rook.o \ + ssytri_rook.o ssycon_rook.o ssysv_rook.o \ stbcon.o \ stbrfs.o stbtrs.o stgevc.o stgex2.o stgexc.o stgsen.o \ stgsja.o stgsna.o stgsy2.o stgsyl.o stpcon.o stprfs.o stptri.o \ @@ -150,7 +152,8 @@ SLASRC = \ stfttr.o stpttf.o stpttr.o strttf.o strttp.o \ sgejsv.o sgesvj.o sgsvj0.o sgsvj1.o \ sgeequb.o ssyequb.o spoequb.o sgbequb.o \ - sbbcsd.o slapmr.o sorbdb.o sorcsd.o \ + sbbcsd.o slapmr.o sorbdb.o sorbdb1.o sorbdb2.o sorbdb3.o sorbdb4.o \ + sorbdb5.o sorbdb6.o sorcsd.o sorcsd2by1.o \ sgeqrt.o sgeqrt2.o sgeqrt3.o sgemqrt.o \ stpqrt.o stpqrt2.o stpmqrt.o stprfb.o @@ -184,14 +187,16 @@ CLASRC = \ chegv.o chegvd.o chegvx.o cherfs.o chesv.o chesvx.o chetd2.o \ chetf2.o chetrd.o \ chetrf.o chetri.o chetri2.o chetri2x.o cheswapr.o \ - chetrs.o chetrs2.o chgeqz.o chpcon.o chpev.o chpevd.o \ + chetrs.o chetrs2.o \ + chetf2_rook.o chetrf_rook.o chetri_rook.o chetrs_rook.o checon_rook.o chesv_rook.o \ + chgeqz.o chpcon.o chpev.o chpevd.o \ chpevx.o chpgst.o chpgv.o chpgvd.o chpgvx.o chprfs.o chpsv.o \ chpsvx.o \ chptrd.o chptrf.o chptri.o chptrs.o chsein.o chseqr.o clabrd.o \ clacgv.o clacon.o clacn2.o clacp2.o clacpy.o clacrm.o clacrt.o cladiv.o \ claed0.o claed7.o claed8.o \ claein.o claesy.o claev2.o clags2.o clagtm.o \ - clahef.o clahqr.o \ + clahef.o clahef_rook.o clahqr.o \ clahrd.o clahr2.o claic1.o clals0.o clalsa.o clalsd.o clangb.o clange.o clangt.o \ clanhb.o clanhe.o \ clanhp.o clanhs.o clanht.o clansb.o clansp.o clansy.o clantb.o \ @@ -202,7 +207,7 @@ CLASRC = \ clarf.o clarfb.o clarfg.o clarft.o clarfgp.o \ clarfx.o clargv.o clarnv.o clarrv.o clartg.o clartv.o \ clarz.o clarzb.o clarzt.o clascl.o claset.o clasr.o classq.o \ - clasyf.o clatbs.o clatdf.o clatps.o clatrd.o clatrs.o clatrz.o \ + clasyf.o clasyf_rook.o clatbs.o clatdf.o clatps.o clatrd.o clatrs.o clatrz.o \ clatzm.o cpbcon.o cpbequ.o cpbrfs.o cpbstf.o cpbsv.o \ cpbsvx.o cpbtf2.o cpbtrf.o cpbtrs.o cpocon.o cpoequ.o cporfs.o \ cposv.o cposvx.o cpotri.o cpstrf.o cpstf2.o \ @@ -214,6 +219,8 @@ CLASRC = \ csycon.o csymv.o \ csyr.o csyrfs.o csysv.o csysvx.o csytf2.o csytrf.o csytri.o csytri2.o csytri2x.o \ csyswapr.o csytrs.o csytrs2.o csyconv.o \ + csytf2_rook.o csytrf_rook.o csytrs_rook.o \ + csytri_rook.o csycon_rook.o csysv_rook.o \ ctbcon.o ctbrfs.o ctbtrs.o ctgevc.o ctgex2.o \ ctgexc.o ctgsen.o ctgsja.o ctgsna.o ctgsy2.o ctgsyl.o ctpcon.o \ ctprfs.o ctptri.o \ @@ -226,7 +233,8 @@ CLASRC = \ chfrk.o ctfttp.o clanhf.o cpftrf.o cpftri.o cpftrs.o ctfsm.o ctftri.o \ ctfttr.o ctpttf.o ctpttr.o ctrttf.o ctrttp.o \ cgeequb.o cgbequb.o csyequb.o cpoequb.o cheequb.o \ - cbbcsd.o clapmr.o cunbdb.o cuncsd.o \ + cbbcsd.o clapmr.o cunbdb.o cunbdb1.o cunbdb2.o cunbdb3.o cunbdb4.o \ + cunbdb5.o cunbdb6.o cuncsd.o cuncsd2by1.o \ cgeqrt.o cgeqrt2.o cgeqrt3.o cgemqrt.o \ ctpqrt.o ctpqrt2.o ctpmqrt.o ctprfb.o @@ -270,7 +278,7 @@ DLASRC = \ dlaqtr.o dlar1v.o dlar2v.o iladlr.o iladlc.o \ dlarf.o dlarfb.o dlarfg.o dlarfgp.o dlarft.o dlarfx.o \ dlargv.o dlarrv.o dlartv.o \ - dlarz.o dlarzb.o dlarzt.o dlasy2.o dlasyf.o \ + dlarz.o dlarzb.o dlarzt.o dlasy2.o dlasyf.o dlasyf_rook.o \ dlatbs.o dlatdf.o dlatps.o dlatrd.o dlatrs.o dlatrz.o dlatzm.o \ dopgtr.o dopmtr.o dorg2l.o dorg2r.o \ dorgbr.o dorghr.o dorgl2.o dorglq.o dorgql.o dorgqr.o dorgr2.o \ @@ -293,6 +301,8 @@ DLASRC = \ dsysv.o dsysvx.o \ dsytd2.o dsytf2.o dsytrd.o dsytrf.o dsytri.o dsytri2.o dsytri2x.o \ dsyswapr.o dsytrs.o dsytrs2.o dsyconv.o \ + dsytf2_rook.o dsytrf_rook.o dsytrs_rook.o \ + dsytri_rook.o dsycon_rook.o dsysv_rook.o \ dtbcon.o dtbrfs.o dtbtrs.o dtgevc.o dtgex2.o dtgexc.o dtgsen.o \ dtgsja.o dtgsna.o dtgsy2.o dtgsyl.o dtpcon.o dtprfs.o dtptri.o \ dtptrs.o \ @@ -303,7 +313,8 @@ DLASRC = \ dtfttr.o dtpttf.o dtpttr.o dtrttf.o dtrttp.o \ dgejsv.o dgesvj.o dgsvj0.o dgsvj1.o \ dgeequb.o dsyequb.o dpoequb.o dgbequb.o \ - dbbcsd.o dlapmr.o dorbdb.o dorcsd.o \ + dbbcsd.o dlapmr.o dorbdb.o dorbdb1.o dorbdb2.o dorbdb3.o dorbdb4.o \ + dorbdb5.o dorbdb6.o dorcsd.o dorcsd2by1.o \ dgeqrt.o dgeqrt2.o dgeqrt3.o dgemqrt.o \ dtpqrt.o dtpqrt2.o dtpmqrt.o dtprfb.o @@ -335,14 +346,16 @@ ZLASRC = \ zhegv.o zhegvd.o zhegvx.o zherfs.o zhesv.o zhesvx.o zhetd2.o \ zhetf2.o zhetrd.o \ zhetrf.o zhetri.o zhetri2.o zhetri2x.o zheswapr.o \ - zhetrs.o zhetrs2.o zhgeqz.o zhpcon.o zhpev.o zhpevd.o \ + zhetrs.o zhetrs2.o \ + zhetf2_rook.o zhetrf_rook.o zhetri_rook.o zhetrs_rook.o zhecon_rook.o zhesv_rook.o \ + zhgeqz.o zhpcon.o zhpev.o zhpevd.o \ zhpevx.o zhpgst.o zhpgv.o zhpgvd.o zhpgvx.o zhprfs.o zhpsv.o \ zhpsvx.o \ zhptrd.o zhptrf.o zhptri.o zhptrs.o zhsein.o zhseqr.o zlabrd.o \ zlacgv.o zlacon.o zlacn2.o zlacp2.o zlacpy.o zlacrm.o zlacrt.o zladiv.o \ zlaed0.o zlaed7.o zlaed8.o \ zlaein.o zlaesy.o zlaev2.o zlags2.o zlagtm.o \ - zlahef.o zlahqr.o \ + zlahef.o zlahef_rook.o zlahqr.o \ zlahrd.o zlahr2.o zlaic1.o zlals0.o zlalsa.o zlalsd.o zlangb.o zlange.o \ zlangt.o zlanhb.o \ zlanhe.o \ @@ -355,7 +368,7 @@ ZLASRC = \ zlarfg.o zlarft.o zlarfgp.o \ zlarfx.o zlargv.o zlarnv.o zlarrv.o zlartg.o zlartv.o \ zlarz.o zlarzb.o zlarzt.o zlascl.o zlaset.o zlasr.o \ - zlassq.o zlasyf.o \ + zlassq.o zlasyf.o zlasyf_rook.o \ zlatbs.o zlatdf.o zlatps.o zlatrd.o zlatrs.o zlatrz.o zlatzm.o zlauu2.o \ zpbcon.o zpbequ.o zpbrfs.o zpbstf.o zpbsv.o \ zpbsvx.o zpbtf2.o zpbtrf.o zpbtrs.o zpocon.o zpoequ.o zporfs.o \ @@ -368,6 +381,8 @@ ZLASRC = \ zsycon.o zsymv.o \ zsyr.o zsyrfs.o zsysv.o zsysvx.o zsytf2.o zsytrf.o zsytri.o zsytri2.o zsytri2x.o \ zsyswapr.o zsytrs.o zsytrs2.o zsyconv.o \ + zsytf2_rook.o zsytrf_rook.o zsytrs_rook.o \ + zsytri_rook.o zsycon_rook.o zsysv_rook.o \ ztbcon.o ztbrfs.o ztbtrs.o ztgevc.o ztgex2.o \ ztgexc.o ztgsen.o ztgsja.o ztgsna.o ztgsy2.o ztgsyl.o ztpcon.o \ ztprfs.o ztptri.o \ @@ -382,7 +397,8 @@ ZLASRC = \ zhfrk.o ztfttp.o zlanhf.o zpftrf.o zpftri.o zpftrs.o ztfsm.o ztftri.o \ ztfttr.o ztpttf.o ztpttr.o ztrttf.o ztrttp.o \ zgeequb.o zgbequb.o zsyequb.o zpoequb.o zheequb.o \ - zbbcsd.o zlapmr.o zunbdb.o zuncsd.o \ + zbbcsd.o zlapmr.o zunbdb.o zunbdb1.o zunbdb2.o zunbdb3.o zunbdb4.o \ + zunbdb5.o zunbdb6.o zuncsd.o zuncsd2by1.o \ zgeqrt.o zgeqrt2.o zgeqrt3.o zgemqrt.o \ ztpqrt.o ztpqrt2.o ztpmqrt.o ztprfb.o diff --git a/lapack-netlib/SRC/cbbcsd.f b/lapack-netlib/SRC/cbbcsd.f index d60f532c1..2d619cde1 100644 --- a/lapack-netlib/SRC/cbbcsd.f +++ b/lapack-netlib/SRC/cbbcsd.f @@ -322,7 +322,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complexOTHERcomputational * @@ -332,10 +332,10 @@ $ V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, $ B22D, B22E, RWORK, LRWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS @@ -477,7 +477,10 @@ * Initial deflation * IMAX = Q - DO WHILE( ( IMAX .GT. 1 ) .AND. ( PHI(IMAX-1) .EQ. ZERO ) ) + DO WHILE( IMAX .GT. 1 ) + IF( PHI(IMAX-1) .NE. ZERO ) THEN + EXIT + END IF IMAX = IMAX - 1 END DO IMIN = IMAX - 1 diff --git a/lapack-netlib/SRC/cgebal.f b/lapack-netlib/SRC/cgebal.f index 4bb5a2f0b..bcd9f516f 100644 --- a/lapack-netlib/SRC/cgebal.f +++ b/lapack-netlib/SRC/cgebal.f @@ -122,7 +122,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complexGEcomputational * @@ -161,10 +161,10 @@ * ===================================================================== SUBROUTINE CGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER JOB @@ -195,8 +195,8 @@ * .. External Functions .. LOGICAL SISNAN, LSAME INTEGER ICAMAX - REAL SLAMCH - EXTERNAL SISNAN, LSAME, ICAMAX, SLAMCH + REAL SLAMCH, SCNRM2 + EXTERNAL SISNAN, LSAME, ICAMAX, SLAMCH, SCNRM2 * .. * .. External Subroutines .. EXTERNAL CSSCAL, CSWAP, XERBLA @@ -325,15 +325,9 @@ NOCONV = .FALSE. * DO 200 I = K, L - C = ZERO - R = ZERO -* - DO 150 J = K, L - IF( J.EQ.I ) - $ GO TO 150 - C = C + CABS1( A( J, I ) ) - R = R + CABS1( A( I, J ) ) - 150 CONTINUE +* + C = SCNRM2( L-K+1, A( K, I ), 1 ) + R = SCNRM2( L-K+1, A( I , K ), LDA ) ICA = ICAMAX( L, A( 1, I ), 1 ) CA = ABS( A( ICA, I ) ) IRA = ICAMAX( N-K+1, A( I, K ), LDA ) diff --git a/lapack-netlib/SRC/cgemqrt.f b/lapack-netlib/SRC/cgemqrt.f index 76f345cca..ae6f8c7a6 100644 --- a/lapack-netlib/SRC/cgemqrt.f +++ b/lapack-netlib/SRC/cgemqrt.f @@ -160,7 +160,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complexGEcomputational * @@ -168,10 +168,10 @@ SUBROUTINE CGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, $ C, LDC, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -225,7 +225,7 @@ INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.Q ) THEN INFO = -5 - ELSE IF( NB.LT.1 .OR. NB.GT.K ) THEN + ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0)) THEN INFO = -6 ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN INFO = -8 diff --git a/lapack-netlib/SRC/cgeqrt.f b/lapack-netlib/SRC/cgeqrt.f index e1ee0011a..a84916820 100644 --- a/lapack-netlib/SRC/cgeqrt.f +++ b/lapack-netlib/SRC/cgeqrt.f @@ -108,7 +108,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complexGEcomputational * @@ -141,10 +141,10 @@ * ===================================================================== SUBROUTINE CGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDT, M, N, NB @@ -173,7 +173,7 @@ INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 - ELSE IF( NB.LT.1 .OR. NB.GT.MIN(M,N) ) THEN + ELSE IF( NB.LT.1 .OR. ( NB.GT.MIN(M,N) .AND. MIN(M,N).GT.0 ) )THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 diff --git a/lapack-netlib/SRC/cgetc2.f b/lapack-netlib/SRC/cgetc2.f index e67ea9694..fac6b56820 100644 --- a/lapack-netlib/SRC/cgetc2.f +++ b/lapack-netlib/SRC/cgetc2.f @@ -98,7 +98,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup complexGEauxiliary * @@ -111,10 +111,10 @@ * ===================================================================== SUBROUTINE CGETC2( N, A, LDA, IPIV, JPIV, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. INTEGER INFO, LDA, N @@ -203,6 +203,12 @@ INFO = N A( N, N ) = CMPLX( SMIN, ZERO ) END IF +* +* Set last pivots to N +* + IPIV( N ) = N + JPIV( N ) = N +* RETURN * * End of CGETC2 diff --git a/lapack-netlib/SRC/checon_rook.f b/lapack-netlib/SRC/checon_rook.f new file mode 100644 index 000000000..b986387b6 --- /dev/null +++ b/lapack-netlib/SRC/checon_rook.f @@ -0,0 +1,253 @@ +*> \brief \b CHECON_ROOK estimates the reciprocal of the condition number fort HE matrices using factorization obtained with one of the bounded diagonal pivoting methods (max 2 interchanges) +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHECON_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHECON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* REAL ANORM, RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHECON_ROOK estimates the reciprocal of the condition number of a complex +*> Hermitian matrix A using the factorization A = U*D*U**H or +*> A = L*D*L**H computed by CHETRF_ROOK. +*> +*> An estimate is obtained for norm(inv(A)), and the reciprocal of the +*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**H; +*> = 'L': Lower triangular, form is A = L*D*L**H. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by CHETRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by CHETRF_ROOK. +*> \endverbatim +*> +*> \param[in] ANORM +*> \verbatim +*> ANORM is REAL +*> The 1-norm of the original matrix A. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is REAL +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an +*> estimate of the 1-norm of inv(A) computed in this routine. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complexHEcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CHECON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N + REAL ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, KASE + REAL AINVNM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CHETRS_ROOK, CLACN2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( ANORM.LT.ZERO ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHECON_ROOK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + RCOND = ZERO + IF( N.EQ.0 ) THEN + RCOND = ONE + RETURN + ELSE IF( ANORM.LE.ZERO ) THEN + RETURN + END IF +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO 10 I = N, 1, -1 + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) + $ RETURN + 10 CONTINUE + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO 20 I = 1, N + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) + $ RETURN + 20 CONTINUE + END IF +* +* Estimate the 1-norm of the inverse. +* + KASE = 0 + 30 CONTINUE + CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN +* +* Multiply by inv(L*D*L**H) or inv(U*D*U**H). +* + CALL CHETRS_ROOK( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO ) + GO TO 30 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM.NE.ZERO ) + $ RCOND = ( ONE / AINVNM ) / ANORM +* + RETURN +* +* End of CHECON_ROOK +* + END diff --git a/lapack-netlib/SRC/chesv_rook.f b/lapack-netlib/SRC/chesv_rook.f new file mode 100644 index 000000000..76a6f5e3c --- /dev/null +++ b/lapack-netlib/SRC/chesv_rook.f @@ -0,0 +1,295 @@ +*> \brief \b CHESV_ROOK computes the solution to a system of linear equations A * X = B for HE matrices using the bounded Bunch-Kaufman ("rook") diagonal pivoting method +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHESV_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHESV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHESV_ROOK computes the solution to a complex system of linear equations +*> A * X = B, +*> where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS +*> matrices. +*> +*> The bounded Bunch-Kaufman ("rook") diagonal pivoting method is used +*> to factor A as +*> A = U * D * U**T, if UPLO = 'U', or +*> A = L * D * L**T, if UPLO = 'L', +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and D is Hermitian and block diagonal with +*> 1-by-1 and 2-by-2 diagonal blocks. +*> +*> CHETRF_ROOK is called to compute the factorization of a complex +*> Hermition matrix A using the bounded Bunch-Kaufman ("rook") diagonal +*> pivoting method. +*> +*> The factored form of A is then used to solve the system +*> of equations A * X = B by calling CHETRS_ROOK (uses BLAS 2). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, the block diagonal matrix D and the +*> multipliers used to obtain the factor U or L from the +*> factorization A = U*D*U**H or A = L*D*L**H as computed by +*> CHETRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> Only the last KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> Only the first KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= 1, and for best performance +*> LWORK >= max(1,N*NB), where NB is the optimal blocksize for +*> CHETRF_ROOK. +*> for LWORK < N, TRS will be done with Level BLAS 2 +*> for LWORK >= N, TRS will be done with Level BLAS 3 +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, so the solution could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complexHEsolve +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* +* ===================================================================== + SUBROUTINE CHESV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CHETRF_ROOK, CHETRS_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + NB = ILAENV( 1, 'CHETRF_ROOK', UPLO, N, -1, -1, -1 ) + LWKOPT = N*NB + END IF + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHESV_ROOK ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = U*D*U**H or A = L*D*L**H. +* + CALL CHETRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* +* Solve with TRS ( Use Level BLAS 2) +* + CALL CHETRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of CHESV_ROOK +* + END diff --git a/lapack-netlib/SRC/chetf2.f b/lapack-netlib/SRC/chetf2.f index 101bc1ee7..6f7fa3214 100644 --- a/lapack-netlib/SRC/chetf2.f +++ b/lapack-netlib/SRC/chetf2.f @@ -1,4 +1,4 @@ -*> \brief \b CHETF2 computes the factorization of a complex Hermitian matrix, using the diagonal pivoting method (unblocked algorithm). +*> \brief \b CHETF2 computes the factorization of a complex Hermitian matrix, using the diagonal pivoting method (unblocked algorithm calling Level 2 BLAS). * * =========== DOCUMENTATION =========== * @@ -90,13 +90,22 @@ *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D. -*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were -*> interchanged and D(k,k) is a 1-by-1 diagonal block. -*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and -*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) -*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = -*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were -*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns +*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) +*> is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns +*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1) +*> is a 2-by-2 diagonal block. *> \endverbatim *> *> \param[out] INFO @@ -118,7 +127,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup complexHEcomputational * @@ -177,10 +186,10 @@ * ===================================================================== SUBROUTINE CHETF2( UPLO, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER UPLO @@ -268,7 +277,8 @@ ABSAKK = ABS( REAL( A( K, K ) ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. * IF( K.GT.1 ) THEN IMAX = ICAMAX( K-1, A( 1, K ), 1 ) @@ -279,7 +289,8 @@ * IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN * -* Column K is zero or contains a NaN: set INFO and continue +* Column K is or underflow, or contains a NaN: +* set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K @@ -450,7 +461,8 @@ ABSAKK = ABS( REAL( A( K, K ) ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. * IF( K.LT.N ) THEN IMAX = K + ICAMAX( N-K, A( K+1, K ), 1 ) @@ -461,7 +473,8 @@ * IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN * -* Column K is zero or contains a NaN: set INFO and continue +* Column K is zero or underflow, contains a NaN: +* set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K diff --git a/lapack-netlib/SRC/chetf2_rook.f b/lapack-netlib/SRC/chetf2_rook.f new file mode 100644 index 000000000..ccd6a7f84 --- /dev/null +++ b/lapack-netlib/SRC/chetf2_rook.f @@ -0,0 +1,910 @@ +*> \brief \b CHETF2_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHETF2_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHETF2_ROOK computes the factorization of a complex Hermitian matrix A +*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method: +*> +*> A = U*D*U**H or A = L*D*L**H +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, U**H is the conjugate transpose of U, and D is +*> Hermitian and block diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the unblocked version of the algorithm, calling Level 2 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> Hermitian matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading +*> n-by-n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading n-by-n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, the block diagonal matrix D and the multipliers used +*> to obtain the factor U or L (see below for further details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complexHEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', then A = U*D*U**H, where +*> U = P(n)*U(n)* ... *P(k)U(k)* ..., +*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to +*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I v 0 ) k-s +*> U(k) = ( 0 I 0 ) s +*> ( 0 0 I ) n-k +*> k-s s n-k +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). +*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), +*> and A(k,k), and v overwrites A(1:k-2,k-1:k). +*> +*> If UPLO = 'L', then A = L*D*L**H, where +*> L = P(1)*L(1)* ... *P(k)*L(k)* ..., +*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to +*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I 0 0 ) k-1 +*> L(k) = ( 0 I 0 ) s +*> ( 0 v I ) n-k-s+1 +*> k-1 s n-k-s+1 +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). +*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), +*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> 01-01-96 - Based on modifications by +*> J. Lewis, Boeing Computer Services Company +*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ) +* .. +* +* ====================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL DONE, UPPER + INTEGER I, II, IMAX, ITEMP, J, JMAX, K, KK, KP, KSTEP, + $ P + REAL ABSAKK, ALPHA, COLMAX, D, D11, D22, R1, STEMP, + $ ROWMAX, TT, SFMIN + COMPLEX D12, D21, T, WK, WKM1, WKP1, Z +* .. +* .. External Functions .. +* + LOGICAL LSAME + INTEGER ICAMAX + REAL SLAMCH, SLAPY2 + EXTERNAL LSAME, ICAMAX, SLAMCH, SLAPY2 +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CSSCAL, CHER, CSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, AIMAG, CMPLX, CONJG, MAX, REAL, SQRT +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function definitions .. + CABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHETF2_ROOK', -INFO ) + RETURN + END IF +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = SLAMCH( 'S' ) +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**H using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2 +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 70 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( REAL( A( K, K ) ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = ICAMAX( K-1, A( 1, K ), 1 ) + COLMAX = CABS1( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + A( K, K ) = REAL( A( K, K ) ) + ELSE +* +* ============================================================ +* +* BEGIN pivot search +* +* Case(1) +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* BEGIN pivot search loop body +* +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + ICAMAX( K-IMAX, A( IMAX, IMAX+1 ), + $ LDA ) + ROWMAX = CABS1( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = ICAMAX( IMAX-1, A( 1, IMAX ), 1 ) + STEMP = CABS1( A( ITEMP, IMAX ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Case(2) +* Equivalent to testing for +* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABS( REAL( A( IMAX, IMAX ) ) ) + $ .LT.ALPHA*ROWMAX ) ) THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Case(3) +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K-1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. +* +* Case(4) + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* END pivot search loop body +* + IF( .NOT.DONE ) GOTO 12 +* + END IF +* +* END pivot search +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped +* + KK = K - KSTEP + 1 +* +* For only a 2x2 pivot, interchange rows and columns K and P +* in the leading submatrix A(1:k,1:k) +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* (1) Swap columnar parts + IF( P.GT.1 ) + $ CALL CSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 ) +* (2) Swap and conjugate middle parts + DO 14 J = P + 1, K - 1 + T = CONJG( A( J, K ) ) + A( J, K ) = CONJG( A( P, J ) ) + A( P, J ) = T + 14 CONTINUE +* (3) Swap and conjugate corner elements at row-col interserction + A( P, K ) = CONJG( A( P, K ) ) +* (4) Swap diagonal elements at row-col intersection + R1 = REAL( A( K, K ) ) + A( K, K ) = REAL( A( P, P ) ) + A( P, P ) = R1 + END IF +* +* For both 1x1 and 2x2 pivots, interchange rows and +* columns KK and KP in the leading submatrix A(1:k,1:k) +* + IF( KP.NE.KK ) THEN +* (1) Swap columnar parts + IF( KP.GT.1 ) + $ CALL CSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) +* (2) Swap and conjugate middle parts + DO 15 J = KP + 1, KK - 1 + T = CONJG( A( J, KK ) ) + A( J, KK ) = CONJG( A( KP, J ) ) + A( KP, J ) = T + 15 CONTINUE +* (3) Swap and conjugate corner elements at row-col interserction + A( KP, KK ) = CONJG( A( KP, KK ) ) +* (4) Swap diagonal elements at row-col intersection + R1 = REAL( A( KK, KK ) ) + A( KK, KK ) = REAL( A( KP, KP ) ) + A( KP, KP ) = R1 +* + IF( KSTEP.EQ.2 ) THEN +* (*) Make sure that diagonal element of pivot is real + A( K, K ) = REAL( A( K, K ) ) +* (5) Swap row elements + T = A( K-1, K ) + A( K-1, K ) = A( KP, K ) + A( KP, K ) = T + END IF + ELSE +* (*) Make sure that diagonal element of pivot is real + A( K, K ) = REAL( A( K, K ) ) + IF( KSTEP.EQ.2 ) + $ A( K-1, K-1 ) = REAL( A( K-1, K-1 ) ) + END IF +* +* Update the leading submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* + IF( K.GT.1 ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) and +* store U(k) in column k +* + IF( ABS( REAL( A( K, K ) ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*1/D(k)*W(k)**T +* + D11 = ONE / REAL( A( K, K ) ) + CALL CHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) +* +* Store U(k) in column k +* + CALL CSSCAL( K-1, D11, A( 1, K ), 1 ) + ELSE +* +* Store L(k) in column K +* + D11 = REAL( A( K, K ) ) + DO 16 II = 1, K - 1 + A( II, K ) = A( II, K ) / D11 + 16 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL CHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k-1 now hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* +* Perform a rank-2 update of A(1:k-2,1:k-2) as +* +* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T +* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.GT.2 ) THEN +* D = |A12| + D = SLAPY2( REAL( A( K-1, K ) ), + $ AIMAG( A( K-1, K ) ) ) + D11 = A( K, K ) / D + D22 = A( K-1, K-1 ) / D + D12 = A( K-1, K ) / D + TT = ONE / ( D11*D22-ONE ) +* + DO 30 J = K - 2, 1, -1 +* +* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* + WKM1 = TT*( D11*A( J, K-1 )-CONJG( D12 )* + $ A( J, K ) ) + WK = TT*( D22*A( J, K )-D12*A( J, K-1 ) ) +* +* Perform a rank-2 update of A(1:k-2,1:k-2) +* + DO 20 I = J, 1, -1 + A( I, J ) = A( I, J ) - + $ ( A( I, K ) / D )*CONJG( WK ) - + $ ( A( I, K-1 ) / D )*CONJG( WKM1 ) + 20 CONTINUE +* +* Store U(k) and U(k-1) in cols k and k-1 for row J +* + A( J, K ) = WK / D + A( J, K-1 ) = WKM1 / D +* (*) Make sure that diagonal element of pivot is real + A( J, J ) = CMPLX( REAL( A( J, J ) ), ZERO ) +* + 30 CONTINUE +* + END IF +* + END IF +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + ELSE +* +* Factorize A as L*D*L**H using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2 +* + K = 1 + 40 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 70 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( REAL( A( K, K ) ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + ICAMAX( N-K, A( K+1, K ), 1 ) + COLMAX = CABS1( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + A( K, K ) = REAL( A( K, K ) ) + ELSE +* +* ============================================================ +* +* BEGIN pivot search +* +* Case(1) +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 42 CONTINUE +* +* BEGIN pivot search loop body +* +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + ICAMAX( IMAX-K, A( IMAX, K ), LDA ) + ROWMAX = CABS1( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + ICAMAX( N-IMAX, A( IMAX+1, IMAX ), + $ 1 ) + STEMP = CABS1( A( ITEMP, IMAX ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Case(2) +* Equivalent to testing for +* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABS( REAL( A( IMAX, IMAX ) ) ) + $ .LT.ALPHA*ROWMAX ) ) THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Case(3) +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. +* +* Case(4) + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* +* END pivot search loop body +* + IF( .NOT.DONE ) GOTO 42 +* + END IF +* +* END pivot search +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped +* + KK = K + KSTEP - 1 +* +* For only a 2x2 pivot, interchange rows and columns K and P +* in the trailing submatrix A(k:n,k:n) +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* (1) Swap columnar parts + IF( P.LT.N ) + $ CALL CSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) +* (2) Swap and conjugate middle parts + DO 44 J = K + 1, P - 1 + T = CONJG( A( J, K ) ) + A( J, K ) = CONJG( A( P, J ) ) + A( P, J ) = T + 44 CONTINUE +* (3) Swap and conjugate corner elements at row-col interserction + A( P, K ) = CONJG( A( P, K ) ) +* (4) Swap diagonal elements at row-col intersection + R1 = REAL( A( K, K ) ) + A( K, K ) = REAL( A( P, P ) ) + A( P, P ) = R1 + END IF +* +* For both 1x1 and 2x2 pivots, interchange rows and +* columns KK and KP in the trailing submatrix A(k:n,k:n) +* + IF( KP.NE.KK ) THEN +* (1) Swap columnar parts + IF( KP.LT.N ) + $ CALL CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) +* (2) Swap and conjugate middle parts + DO 45 J = KK + 1, KP - 1 + T = CONJG( A( J, KK ) ) + A( J, KK ) = CONJG( A( KP, J ) ) + A( KP, J ) = T + 45 CONTINUE +* (3) Swap and conjugate corner elements at row-col interserction + A( KP, KK ) = CONJG( A( KP, KK ) ) +* (4) Swap diagonal elements at row-col intersection + R1 = REAL( A( KK, KK ) ) + A( KK, KK ) = REAL( A( KP, KP ) ) + A( KP, KP ) = R1 +* + IF( KSTEP.EQ.2 ) THEN +* (*) Make sure that diagonal element of pivot is real + A( K, K ) = REAL( A( K, K ) ) +* (5) Swap row elements + T = A( K+1, K ) + A( K+1, K ) = A( KP, K ) + A( KP, K ) = T + END IF + ELSE +* (*) Make sure that diagonal element of pivot is real + A( K, K ) = REAL( A( K, K ) ) + IF( KSTEP.EQ.2 ) + $ A( K+1, K+1 ) = REAL( A( K+1, K+1 ) ) + END IF +* +* Update the trailing submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k of A now holds +* +* W(k) = L(k)*D(k), +* +* where L(k) is the k-th column of L +* + IF( K.LT.N ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) and +* store L(k) in column k +* +* Handle division by a small number +* + IF( ABS( REAL( A( K, K ) ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* + D11 = ONE / REAL( A( K, K ) ) + CALL CHER( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) +* +* Store L(k) in column k +* + CALL CSSCAL( N-K, D11, A( K+1, K ), 1 ) + ELSE +* +* Store L(k) in column k +* + D11 = REAL( A( K, K ) ) + DO 46 II = K + 1, N + A( II, K ) = A( II, K ) / D11 + 46 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL CHER( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* +* +* Perform a rank-2 update of A(k+2:n,k+2:n) as +* +* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T +* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.LT.N-1 ) THEN +* D = |A21| + D = SLAPY2( REAL( A( K+1, K ) ), + $ AIMAG( A( K+1, K ) ) ) + D11 = REAL( A( K+1, K+1 ) ) / D + D22 = REAL( A( K, K ) ) / D + D21 = A( K+1, K ) / D + TT = ONE / ( D11*D22-ONE ) +* + DO 60 J = K + 2, N +* +* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* + WK = TT*( D11*A( J, K )-D21*A( J, K+1 ) ) + WKP1 = TT*( D22*A( J, K+1 )-CONJG( D21 )* + $ A( J, K ) ) +* +* Perform a rank-2 update of A(k+2:n,k+2:n) +* + DO 50 I = J, N + A( I, J ) = A( I, J ) - + $ ( A( I, K ) / D )*CONJG( WK ) - + $ ( A( I, K+1 ) / D )*CONJG( WKP1 ) + 50 CONTINUE +* +* Store L(k) and L(k+1) in cols k and k+1 for row J +* + A( J, K ) = WK / D + A( J, K+1 ) = WKP1 / D +* (*) Make sure that diagonal element of pivot is real + A( J, J ) = CMPLX( REAL( A( J, J ) ), ZERO ) +* + 60 CONTINUE +* + END IF +* + END IF +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 40 +* + END IF +* + 70 CONTINUE +* + RETURN +* +* End of CHETF2_ROOK +* + END diff --git a/lapack-netlib/SRC/chetrf_rook.f b/lapack-netlib/SRC/chetrf_rook.f new file mode 100644 index 000000000..98c8dbd26 --- /dev/null +++ b/lapack-netlib/SRC/chetrf_rook.f @@ -0,0 +1,397 @@ +*> \brief \b CHETRF_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (blocked algorithm, calling Level 3 BLAS). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHETRF_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHETRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHETRF_ROOK computes the factorization of a comlex Hermitian matrix A +*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. +*> The form of the factorization is +*> +*> A = U*D*U**T or A = L*D*L**T +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and D is Hermitian and block diagonal with +*> 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, the block diagonal matrix D and the multipliers used +*> to obtain the factor U or L (see below for further details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> Only the last KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> Only the first KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (MAX(1,LWORK)). +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >=1. For best performance +*> LWORK >= N*NB, where NB is the block size returned by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complexHEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', then A = U*D*U**T, where +*> U = P(n)*U(n)* ... *P(k)U(k)* ..., +*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to +*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I v 0 ) k-s +*> U(k) = ( 0 I 0 ) s +*> ( 0 0 I ) n-k +*> k-s s n-k +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). +*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), +*> and A(k,k), and v overwrites A(1:k-2,k-1:k). +*> +*> If UPLO = 'L', then A = L*D*L**T, where +*> L = P(1)*L(1)* ... *P(k)*L(k)* ..., +*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to +*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I 0 0 ) k-1 +*> L(k) = ( 0 I 0 ) s +*> ( 0 v I ) n-k-s+1 +*> k-1 s n-k-s+1 +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). +*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), +*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CHETRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL CLAHEF_ROOK, CHETF2_ROOK, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size +* + NB = ILAENV( 1, 'CHETRF_ROOK', UPLO, N, -1, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHETRF_ROOK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* + NBMIN = 2 + LDWORK = N + IF( NB.GT.1 .AND. NB.LT.N ) THEN + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN + NB = MAX( LWORK / LDWORK, 1 ) + NBMIN = MAX( 2, ILAENV( 2, 'CHETRF_ROOK', + $ UPLO, N, -1, -1, -1 ) ) + END IF + ELSE + IWS = 1 + END IF + IF( NB.LT.NBMIN ) + $ NB = N +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* KB, where KB is the number of columns factorized by CLAHEF_ROOK; +* KB is either NB or NB-1, or K for the last block +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 40 +* + IF( K.GT.NB ) THEN +* +* Factorize columns k-kb+1:k of A and use blocked code to +* update columns 1:k-kb +* + CALL CLAHEF_ROOK( UPLO, K, NB, KB, A, LDA, + $ IPIV, WORK, LDWORK, IINFO ) + ELSE +* +* Use unblocked code to factorize columns 1:k of A +* + CALL CHETF2_ROOK( UPLO, K, A, LDA, IPIV, IINFO ) + KB = K + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO +* +* No need to adjust IPIV +* +* Decrease K and return to the start of the main loop +* + K = K - KB + GO TO 10 +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* KB, where KB is the number of columns factorized by CLAHEF_ROOK; +* KB is either NB or NB-1, or N-K+1 for the last block +* + K = 1 + 20 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 40 +* + IF( K.LE.N-NB ) THEN +* +* Factorize columns k:k+kb-1 of A and use blocked code to +* update columns k+kb:n +* + CALL CLAHEF_ROOK( UPLO, N-K+1, NB, KB, A( K, K ), LDA, + $ IPIV( K ), WORK, LDWORK, IINFO ) + ELSE +* +* Use unblocked code to factorize columns k:n of A +* + CALL CHETF2_ROOK( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), + $ IINFO ) + KB = N - K + 1 + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + K - 1 +* +* Adjust IPIV +* + DO 30 J = K, K + KB - 1 + IF( IPIV( J ).GT.0 ) THEN + IPIV( J ) = IPIV( J ) + K - 1 + ELSE + IPIV( J ) = IPIV( J ) - K + 1 + END IF + 30 CONTINUE +* +* Increase K and return to the start of the main loop +* + K = K + KB + GO TO 20 +* + END IF +* + 40 CONTINUE + WORK( 1 ) = LWKOPT + RETURN +* +* End of CHETRF_ROOK +* + END diff --git a/lapack-netlib/SRC/chetri_rook.f b/lapack-netlib/SRC/chetri_rook.f new file mode 100644 index 000000000..00d99e2a9 --- /dev/null +++ b/lapack-netlib/SRC/chetri_rook.f @@ -0,0 +1,516 @@ +*> \brief \b CHETRI_ROOK computes the inverse of HE matrix using the factorization obtained with the bounded Bunch-Kaufman ("rook") diagonal pivoting method. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHETRI_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHETRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHETRI_ROOK computes the inverse of a complex Hermitian indefinite matrix +*> A using the factorization A = U*D*U**H or A = L*D*L**H computed by +*> CHETRF_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**H; +*> = 'L': Lower triangular, form is A = L*D*L**H. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the block diagonal matrix D and the multipliers +*> used to obtain the factor U or L as computed by CHETRF_ROOK. +*> +*> On exit, if INFO = 0, the (Hermitian) inverse of the original +*> matrix. If UPLO = 'U', the upper triangular part of the +*> inverse is formed and the part of A below the diagonal is not +*> referenced; if UPLO = 'L' the lower triangular part of the +*> inverse is formed and the part of A above the diagonal is +*> not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by CHETRF_ROOK. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complexHEcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CHETRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + COMPLEX CONE, CZERO + PARAMETER ( ONE = 1.0E+0, CONE = ( 1.0E+0, 0.0E+0 ), + $ CZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J, K, KP, KSTEP + REAL AK, AKP1, D, T + COMPLEX AKKP1, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME + COMPLEX CDOTC + EXTERNAL LSAME, CDOTC +* .. +* .. External Subroutines .. + EXTERNAL CCOPY, CHEMV, CSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, CONJG, MAX, REAL +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHETRI_ROOK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO 10 INFO = N, 1, -1 + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO ) + $ RETURN + 10 CONTINUE + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO 20 INFO = 1, N + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO ) + $ RETURN + 20 CONTINUE + END IF + INFO = 0 +* + IF( UPPER ) THEN +* +* Compute inv(A) from the factorization A = U*D*U**H. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + 30 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 70 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Invert the diagonal block. +* + A( K, K ) = ONE / REAL( A( K, K ) ) +* +* Compute column K of the inverse. +* + IF( K.GT.1 ) THEN + CALL CCOPY( K-1, A( 1, K ), 1, WORK, 1 ) + CALL CHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO, + $ A( 1, K ), 1 ) + A( K, K ) = A( K, K ) - REAL( CDOTC( K-1, WORK, 1, A( 1, + $ K ), 1 ) ) + END IF + KSTEP = 1 + ELSE +* +* 2 x 2 diagonal block +* +* Invert the diagonal block. +* + T = ABS( A( K, K+1 ) ) + AK = REAL( A( K, K ) ) / T + AKP1 = REAL( A( K+1, K+1 ) ) / T + AKKP1 = A( K, K+1 ) / T + D = T*( AK*AKP1-ONE ) + A( K, K ) = AKP1 / D + A( K+1, K+1 ) = AK / D + A( K, K+1 ) = -AKKP1 / D +* +* Compute columns K and K+1 of the inverse. +* + IF( K.GT.1 ) THEN + CALL CCOPY( K-1, A( 1, K ), 1, WORK, 1 ) + CALL CHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO, + $ A( 1, K ), 1 ) + A( K, K ) = A( K, K ) - REAL( CDOTC( K-1, WORK, 1, A( 1, + $ K ), 1 ) ) + A( K, K+1 ) = A( K, K+1 ) - + $ CDOTC( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 ) + CALL CCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 ) + CALL CHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO, + $ A( 1, K+1 ), 1 ) + A( K+1, K+1 ) = A( K+1, K+1 ) - + $ REAL( CDOTC( K-1, WORK, 1, A( 1, K+1 ), + $ 1 ) ) + END IF + KSTEP = 2 + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* Interchange rows and columns K and IPIV(K) in the leading +* submatrix A(1:k,1:k) +* + KP = IPIV( K ) + IF( KP.NE.K ) THEN +* + IF( KP.GT.1 ) + $ CALL CSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) +* + DO 40 J = KP + 1, K - 1 + TEMP = CONJG( A( J, K ) ) + A( J, K ) = CONJG( A( KP, J ) ) + A( KP, J ) = TEMP + 40 CONTINUE +* + A( KP, K ) = CONJG( A( KP, K ) ) +* + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + ELSE +* +* Interchange rows and columns K and K+1 with -IPIV(K) and +* -IPIV(K+1) in the leading submatrix A(k+1:n,k+1:n) +* +* (1) Interchange rows and columns K and -IPIV(K) +* + KP = -IPIV( K ) + IF( KP.NE.K ) THEN +* + IF( KP.GT.1 ) + $ CALL CSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) +* + DO 50 J = KP + 1, K - 1 + TEMP = CONJG( A( J, K ) ) + A( J, K ) = CONJG( A( KP, J ) ) + A( KP, J ) = TEMP + 50 CONTINUE +* + A( KP, K ) = CONJG( A( KP, K ) ) +* + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP +* + TEMP = A( K, K+1 ) + A( K, K+1 ) = A( KP, K+1 ) + A( KP, K+1 ) = TEMP + END IF +* +* (2) Interchange rows and columns K+1 and -IPIV(K+1) +* + K = K + 1 + KP = -IPIV( K ) + IF( KP.NE.K ) THEN +* + IF( KP.GT.1 ) + $ CALL CSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) +* + DO 60 J = KP + 1, K - 1 + TEMP = CONJG( A( J, K ) ) + A( J, K ) = CONJG( A( KP, J ) ) + A( KP, J ) = TEMP + 60 CONTINUE +* + A( KP, K ) = CONJG( A( KP, K ) ) +* + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + END IF +* + K = K + 1 + GO TO 30 + 70 CONTINUE +* + ELSE +* +* Compute inv(A) from the factorization A = L*D*L**H. +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = N + 80 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 120 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Invert the diagonal block. +* + A( K, K ) = ONE / REAL( A( K, K ) ) +* +* Compute column K of the inverse. +* + IF( K.LT.N ) THEN + CALL CCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) + CALL CHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA, WORK, + $ 1, CZERO, A( K+1, K ), 1 ) + A( K, K ) = A( K, K ) - REAL( CDOTC( N-K, WORK, 1, + $ A( K+1, K ), 1 ) ) + END IF + KSTEP = 1 + ELSE +* +* 2 x 2 diagonal block +* +* Invert the diagonal block. +* + T = ABS( A( K, K-1 ) ) + AK = REAL( A( K-1, K-1 ) ) / T + AKP1 = REAL( A( K, K ) ) / T + AKKP1 = A( K, K-1 ) / T + D = T*( AK*AKP1-ONE ) + A( K-1, K-1 ) = AKP1 / D + A( K, K ) = AK / D + A( K, K-1 ) = -AKKP1 / D +* +* Compute columns K-1 and K of the inverse. +* + IF( K.LT.N ) THEN + CALL CCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) + CALL CHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA, WORK, + $ 1, CZERO, A( K+1, K ), 1 ) + A( K, K ) = A( K, K ) - REAL( CDOTC( N-K, WORK, 1, + $ A( K+1, K ), 1 ) ) + A( K, K-1 ) = A( K, K-1 ) - + $ CDOTC( N-K, A( K+1, K ), 1, A( K+1, K-1 ), + $ 1 ) + CALL CCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 ) + CALL CHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA, WORK, + $ 1, CZERO, A( K+1, K-1 ), 1 ) + A( K-1, K-1 ) = A( K-1, K-1 ) - + $ REAL( CDOTC( N-K, WORK, 1, A( K+1, K-1 ), + $ 1 ) ) + END IF + KSTEP = 2 + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* Interchange rows and columns K and IPIV(K) in the trailing +* submatrix A(k:n,k:n) +* + KP = IPIV( K ) + IF( KP.NE.K ) THEN +* + IF( KP.LT.N ) + $ CALL CSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) +* + DO 90 J = K + 1, KP - 1 + TEMP = CONJG( A( J, K ) ) + A( J, K ) = CONJG( A( KP, J ) ) + A( KP, J ) = TEMP + 90 CONTINUE +* + A( KP, K ) = CONJG( A( KP, K ) ) +* + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + ELSE +* +* Interchange rows and columns K and K-1 with -IPIV(K) and +* -IPIV(K-1) in the trailing submatrix A(k-1:n,k-1:n) +* +* (1) Interchange rows and columns K and -IPIV(K) +* + KP = -IPIV( K ) + IF( KP.NE.K ) THEN +* + IF( KP.LT.N ) + $ CALL CSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) +* + DO 100 J = K + 1, KP - 1 + TEMP = CONJG( A( J, K ) ) + A( J, K ) = CONJG( A( KP, J ) ) + A( KP, J ) = TEMP + 100 CONTINUE +* + A( KP, K ) = CONJG( A( KP, K ) ) +* + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP +* + TEMP = A( K, K-1 ) + A( K, K-1 ) = A( KP, K-1 ) + A( KP, K-1 ) = TEMP + END IF +* +* (2) Interchange rows and columns K-1 and -IPIV(K-1) +* + K = K - 1 + KP = -IPIV( K ) + IF( KP.NE.K ) THEN +* + IF( KP.LT.N ) + $ CALL CSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) +* + DO 110 J = K + 1, KP - 1 + TEMP = CONJG( A( J, K ) ) + A( J, K ) = CONJG( A( KP, J ) ) + A( KP, J ) = TEMP + 110 CONTINUE +* + A( KP, K ) = CONJG( A( KP, K ) ) +* + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + END IF +* + K = K - 1 + GO TO 80 + 120 CONTINUE + END IF +* + RETURN +* +* End of CHETRI_ROOK +* + END diff --git a/lapack-netlib/SRC/chetrs_rook.f b/lapack-netlib/SRC/chetrs_rook.f new file mode 100644 index 000000000..2b0cc6db2 --- /dev/null +++ b/lapack-netlib/SRC/chetrs_rook.f @@ -0,0 +1,503 @@ +*> \brief \b CHETRS_ROOK computes the solution to a system of linear equations A * X = B for HE matrices using factorization obtained with one of the bounded diagonal pivoting methods (max 2 interchanges) +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHETRS_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHETRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHETRS_ROOK solves a system of linear equations A*X = B with a complex +*> Hermitian matrix A using the factorization A = U*D*U**H or +*> A = L*D*L**H computed by CHETRF_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**H; +*> = 'L': Lower triangular, form is A = L*D*L**H. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by CHETRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by CHETRF_ROOK. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complexHEcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CHETRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + $ INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ONE + PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J, K, KP + REAL S + COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CGEMV, CGERU, CLACGV, CSSCAL, CSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG, MAX, REAL +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHETRS_ROOK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Solve A*X = B, where A = U*D*U**H. +* +* First solve U*D*X = B, overwriting B with X. +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 30 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(U(K)), where U(K) is the transformation +* stored in column K of A. +* + CALL CGERU( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, + $ B( 1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + S = REAL( ONE ) / REAL( A( K, K ) ) + CALL CSSCAL( NRHS, S, B( K, 1 ), LDB ) + K = K - 1 + ELSE +* +* 2 x 2 diagonal block +* +* Interchange rows K and -IPIV(K), then K-1 and -IPIV(K-1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K-1) + IF( KP.NE.K-1 ) + $ CALL CSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(U(K)), where U(K) is the transformation +* stored in columns K-1 and K of A. +* + CALL CGERU( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, + $ B( 1, 1 ), LDB ) + CALL CGERU( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ), + $ LDB, B( 1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + AKM1K = A( K-1, K ) + AKM1 = A( K-1, K-1 ) / AKM1K + AK = A( K, K ) / CONJG( AKM1K ) + DENOM = AKM1*AK - ONE + DO 20 J = 1, NRHS + BKM1 = B( K-1, J ) / AKM1K + BK = B( K, J ) / CONJG( AKM1K ) + B( K-1, J ) = ( AK*BKM1-BK ) / DENOM + B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM + 20 CONTINUE + K = K - 2 + END IF +* + GO TO 10 + 30 CONTINUE +* +* Next solve U**H *X = B, overwriting B with X. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + 40 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 50 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Multiply by inv(U**H(K)), where U(K) is the transformation +* stored in column K of A. +* + IF( K.GT.1 ) THEN + CALL CLACGV( NRHS, B( K, 1 ), LDB ) + CALL CGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B, + $ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB ) + CALL CLACGV( NRHS, B( K, 1 ), LDB ) + END IF +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K + 1 + ELSE +* +* 2 x 2 diagonal block +* +* Multiply by inv(U**H(K+1)), where U(K+1) is the transformation +* stored in columns K and K+1 of A. +* + IF( K.GT.1 ) THEN + CALL CLACGV( NRHS, B( K, 1 ), LDB ) + CALL CGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B, + $ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB ) + CALL CLACGV( NRHS, B( K, 1 ), LDB ) +* + CALL CLACGV( NRHS, B( K+1, 1 ), LDB ) + CALL CGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B, + $ LDB, A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB ) + CALL CLACGV( NRHS, B( K+1, 1 ), LDB ) + END IF +* +* Interchange rows K and -IPIV(K), then K+1 and -IPIV(K+1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K+1 ) + IF( KP.NE.K+1 ) + $ CALL CSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) +* + K = K + 2 + END IF +* + GO TO 40 + 50 CONTINUE +* + ELSE +* +* Solve A*X = B, where A = L*D*L**H. +* +* First solve L*D*X = B, overwriting B with X. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + 60 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 80 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(L(K)), where L(K) is the transformation +* stored in column K of A. +* + IF( K.LT.N ) + $ CALL CGERU( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ), + $ LDB, B( K+1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + S = REAL( ONE ) / REAL( A( K, K ) ) + CALL CSSCAL( NRHS, S, B( K, 1 ), LDB ) + K = K + 1 + ELSE +* +* 2 x 2 diagonal block +* +* Interchange rows K and -IPIV(K), then K+1 and -IPIV(K+1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K+1 ) + IF( KP.NE.K+1 ) + $ CALL CSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(L(K)), where L(K) is the transformation +* stored in columns K and K+1 of A. +* + IF( K.LT.N-1 ) THEN + CALL CGERU( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ), + $ LDB, B( K+2, 1 ), LDB ) + CALL CGERU( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1, + $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) + END IF +* +* Multiply by the inverse of the diagonal block. +* + AKM1K = A( K+1, K ) + AKM1 = A( K, K ) / CONJG( AKM1K ) + AK = A( K+1, K+1 ) / AKM1K + DENOM = AKM1*AK - ONE + DO 70 J = 1, NRHS + BKM1 = B( K, J ) / CONJG( AKM1K ) + BK = B( K+1, J ) / AKM1K + B( K, J ) = ( AK*BKM1-BK ) / DENOM + B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM + 70 CONTINUE + K = K + 2 + END IF +* + GO TO 60 + 80 CONTINUE +* +* Next solve L**H *X = B, overwriting B with X. +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = N + 90 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 100 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Multiply by inv(L**H(K)), where L(K) is the transformation +* stored in column K of A. +* + IF( K.LT.N ) THEN + CALL CLACGV( NRHS, B( K, 1 ), LDB ) + CALL CGEMV( 'Conjugate transpose', N-K, NRHS, -ONE, + $ B( K+1, 1 ), LDB, A( K+1, K ), 1, ONE, + $ B( K, 1 ), LDB ) + CALL CLACGV( NRHS, B( K, 1 ), LDB ) + END IF +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K - 1 + ELSE +* +* 2 x 2 diagonal block +* +* Multiply by inv(L**H(K-1)), where L(K-1) is the transformation +* stored in columns K-1 and K of A. +* + IF( K.LT.N ) THEN + CALL CLACGV( NRHS, B( K, 1 ), LDB ) + CALL CGEMV( 'Conjugate transpose', N-K, NRHS, -ONE, + $ B( K+1, 1 ), LDB, A( K+1, K ), 1, ONE, + $ B( K, 1 ), LDB ) + CALL CLACGV( NRHS, B( K, 1 ), LDB ) +* + CALL CLACGV( NRHS, B( K-1, 1 ), LDB ) + CALL CGEMV( 'Conjugate transpose', N-K, NRHS, -ONE, + $ B( K+1, 1 ), LDB, A( K+1, K-1 ), 1, ONE, + $ B( K-1, 1 ), LDB ) + CALL CLACGV( NRHS, B( K-1, 1 ), LDB ) + END IF +* +* Interchange rows K and -IPIV(K), then K-1 and -IPIV(K-1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K-1 ) + IF( KP.NE.K-1 ) + $ CALL CSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) +* + K = K - 2 + END IF +* + GO TO 90 + 100 CONTINUE + END IF +* + RETURN +* +* End of CHETRS_ROOK +* + END diff --git a/lapack-netlib/SRC/chsein.f b/lapack-netlib/SRC/chsein.f index fa87a7341..b4747b53f 100644 --- a/lapack-netlib/SRC/chsein.f +++ b/lapack-netlib/SRC/chsein.f @@ -104,6 +104,7 @@ *> \verbatim *> H is COMPLEX array, dimension (LDH,N) *> The upper Hessenberg matrix H. +*> If a NaN is detected in H, the routine will return with INFO=-6. *> \endverbatim *> *> \param[in] LDH @@ -225,7 +226,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complexOTHERcomputational * @@ -244,10 +245,10 @@ $ LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL, $ IFAILR, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER EIGSRC, INITV, SIDE @@ -276,9 +277,9 @@ COMPLEX CDUM, WK * .. * .. External Functions .. - LOGICAL LSAME + LOGICAL LSAME, SISNAN REAL CLANHS, SLAMCH - EXTERNAL LSAME, CLANHS, SLAMCH + EXTERNAL LSAME, CLANHS, SLAMCH, SISNAN * .. * .. External Subroutines .. EXTERNAL CLAEIN, XERBLA @@ -399,7 +400,10 @@ * has not ben computed before. * HNORM = CLANHS( 'I', KR-KL+1, H( KL, KL ), LDH, RWORK ) - IF( HNORM.GT.RZERO ) THEN + IF( SISNAN( HNORM ) ) THEN + INFO = -6 + RETURN + ELSE IF( (HNORM.GT.RZERO) ) THEN EPS3 = HNORM*ULP ELSE EPS3 = SMLNUM diff --git a/lapack-netlib/SRC/chseqr.f b/lapack-netlib/SRC/chseqr.f index 7f4f977c7..755ca7f7f 100644 --- a/lapack-netlib/SRC/chseqr.f +++ b/lapack-netlib/SRC/chseqr.f @@ -43,7 +43,7 @@ *> Optionally Z may be postmultiplied into an input unitary *> matrix Q so that this routine can give the Schur factorization *> of a matrix A which has been reduced to the Hessenberg form H -*> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. +*> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H. *> \endverbatim * * Arguments: @@ -216,7 +216,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complexOTHERcomputational * @@ -299,10 +299,10 @@ SUBROUTINE CHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N diff --git a/lapack-netlib/SRC/cla_lin_berr.f b/lapack-netlib/SRC/cla_lin_berr.f index 0bfff7a52..94db81439 100644 --- a/lapack-netlib/SRC/cla_lin_berr.f +++ b/lapack-netlib/SRC/cla_lin_berr.f @@ -67,14 +67,14 @@ *> *> \param[in] RES *> \verbatim -*> RES is DOUBLE PRECISION array, dimension (N,NRHS) +*> RES is REAL array, dimension (N,NRHS) *> The residual matrix, i.e., the matrix R in the relative backward *> error formula above. *> \endverbatim *> *> \param[in] AYB *> \verbatim -*> AYB is DOUBLE PRECISION array, dimension (N, NRHS) +*> AYB is REAL array, dimension (N, NRHS) *> The denominator in the relative backward error formula above, i.e., *> the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B *> are from iterative refinement (see cla_gerfsx_extended.f). @@ -94,17 +94,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup complexOTHERcomputational * * ===================================================================== SUBROUTINE CLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. INTEGER N, NZ, NRHS diff --git a/lapack-netlib/SRC/clahef.f b/lapack-netlib/SRC/clahef.f index ff269eef4..f51de1867 100644 --- a/lapack-netlib/SRC/clahef.f +++ b/lapack-netlib/SRC/clahef.f @@ -1,25 +1,25 @@ -*> \brief \b CLAHEF computes a partial factorization of a complex Hermitian indefinite matrix, using the diagonal pivoting method. +*> \brief \b CLAHEF computes a partial factorization of a complex Hermitian indefinite matrix using the Bunch-Kaufman diagonal pivoting method (blocked algorithm, calling Level 3 BLAS). * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLAHEF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLAHEF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KB, LDA, LDW, N, NB @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), W( LDW, * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,16 +110,26 @@ *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D. -*> If UPLO = 'U', only the last KB elements of IPIV are set; -*> if UPLO = 'L', only the first KB elements are set. *> -*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were -*> interchanged and D(k,k) is a 1-by-1 diagonal block. -*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and -*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) -*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = -*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were -*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> If UPLO = 'U': +*> Only the last KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns +*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) +*> is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> Only the first KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns +*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1) +*> is a 2-by-2 diagonal block. *> \endverbatim *> *> \param[out] W @@ -145,22 +155,32 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup complexHEcomputational * +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> \endverbatim +* * ===================================================================== SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER UPLO @@ -219,17 +239,20 @@ * for use in updating A11 (note that conjg(W) is actually stored) * * K is the main loop index, decreasing from N in steps of 1 or 2 -* -* KW is the column of W which corresponds to column K of A * K = N 10 CONTINUE +* +* KW is the column of W which corresponds to column K of A +* KW = NB + K - N * * Exit from loop * IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) $ GO TO 30 +* + KSTEP = 1 * * Copy column K of A to column KW of W and update it * @@ -240,8 +263,6 @@ $ W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 ) W( K, KW ) = REAL( W( K, KW ) ) END IF -* - KSTEP = 1 * * Determine rows and columns to be interchanged and whether * a 1-by-1 or 2-by-2 pivot block will be used @@ -249,7 +270,8 @@ ABSAKK = ABS( REAL( W( K, KW ) ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. * IF( K.GT.1 ) THEN IMAX = ICAMAX( K-1, W( 1, KW ), 1 ) @@ -260,13 +282,19 @@ * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * -* Column K is zero: set INFO and continue +* Column K is zero or underflow: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K KP = K A( K, K ) = REAL( A( K, K ) ) ELSE +* +* ============================================================ +* +* BEGIN pivot search +* +* Case(1) IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * * no interchange, use 1-by-1 pivot block @@ -274,6 +302,9 @@ KP = K ELSE * +* BEGIN pivot search along IMAX row +* +* * Copy column IMAX to column KW-1 of W and update it * CALL CCOPY( IMAX-1, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 ) @@ -289,7 +320,8 @@ END IF * * JMAX is the column-index of the largest off-diagonal -* element in row IMAX, and ROWMAX is its absolute value +* element in row IMAX, and ROWMAX is its absolute value. +* Determine only ROWMAX. * JMAX = IMAX + ICAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 ) ROWMAX = CABS1( W( JMAX, KW-1 ) ) @@ -298,11 +330,14 @@ ROWMAX = MAX( ROWMAX, CABS1( W( JMAX, KW-1 ) ) ) END IF * +* Case(2) IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN * * no interchange, use 1-by-1 pivot block * KP = K +* +* Case(3) ELSE IF( ABS( REAL( W( IMAX, KW-1 ) ) ).GE.ALPHA*ROWMAX ) $ THEN * @@ -311,9 +346,11 @@ * KP = IMAX * -* copy column KW-1 of W to column KW +* copy column KW-1 of W to column KW of W * CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* +* Case(4) ELSE * * interchange rows and columns K-1 and IMAX, use 2-by-2 @@ -322,27 +359,48 @@ KP = IMAX KSTEP = 2 END IF +* +* +* END pivot search along IMAX row +* END IF +* +* END pivot search +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped * KK = K - KSTEP + 1 +* +* KKW is the column of W which corresponds to column KK of A +* KKW = NB + KK - N * -* Updated column KP is already stored in column KKW of W +* Interchange rows and columns KP and KK. +* Updated column KP is already stored in column KKW of W. * IF( KP.NE.KK ) THEN * -* Copy non-updated column KK to column KP +* Copy non-updated column KK to column KP of submatrix A +* at step K. No need to copy element into column K +* (or K and K-1 for 2-by-2 pivot) of A, since these columns +* will be later overwritten. * A( KP, KP ) = REAL( A( KK, KK ) ) CALL CCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), $ LDA ) CALL CLACGV( KK-1-KP, A( KP, KP+1 ), LDA ) - CALL CCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) + IF( KP.GT.1 ) + $ CALL CCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) * -* Interchange rows KK and KP in last KK columns of A and W +* Interchange rows KK and KP in last K+1 to N columns of A +* (columns K (or K and K-1 for 2-by-2 pivot) of A will be +* later overwritten). Interchange rows KK and KP +* in last KKW to NB columns of W. * - IF( KK.LT.N ) - $ CALL CSWAP( N-KK, A( KK, KK+1 ), LDA, A( KP, KK+1 ), + IF( K.LT.N ) + $ CALL CSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ), $ LDA ) CALL CSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), $ LDW ) @@ -350,40 +408,108 @@ * IF( KSTEP.EQ.1 ) THEN * -* 1-by-1 pivot block D(k): column KW of W now holds +* 1-by-1 pivot block D(k): column kw of W now holds * -* W(k) = U(k)*D(k) +* W(kw) = U(k)*D(k), * * where U(k) is the k-th column of U * -* Store U(k) in column k of A +* (1) Store subdiag. elements of column U(k) +* and 1-by-1 block D(k) in column k of A. +* (NOTE: Diagonal element U(k,k) is a UNIT element +* and not stored) +* A(k,k) := D(k,k) = W(k,kw) +* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k) * +* (NOTE: No need to use for Hermitian matrix +* A( K, K ) = DBLE( W( K, K) ) to separately copy diagonal +* element D(k,k) from W (potentially saves only one load)) CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) - R1 = ONE / REAL( A( K, K ) ) - CALL CSSCAL( K-1, R1, A( 1, K ), 1 ) + IF( K.GT.1 ) THEN * -* Conjugate W(k) +* (NOTE: No need to check if A(k,k) is NOT ZERO, +* since that was ensured earlier in pivot search: +* case A(k,k) = 0 falls into 2x2 pivot case(4)) +* + R1 = ONE / REAL( A( K, K ) ) + CALL CSSCAL( K-1, R1, A( 1, K ), 1 ) +* +* (2) Conjugate column W(kw) +* + CALL CLACGV( K-1, W( 1, KW ), 1 ) + END IF * - CALL CLACGV( K-1, W( 1, KW ), 1 ) ELSE * -* 2-by-2 pivot block D(k): columns KW and KW-1 of W now -* hold +* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold * -* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k) * * where U(k) and U(k-1) are the k-th and (k-1)-th columns * of U +* +* (1) Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2 +* block D(k-1:k,k-1:k) in columns k-1 and k of A. +* (NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT +* block and not stored) +* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw) +* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) = +* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) ) * IF( K.GT.2 ) THEN * -* Store U(k) and U(k-1) in columns k and k-1 of A +* Factor out the columns of the inverse of 2-by-2 pivot +* block D, so that each column contains 1, to reduce the +* number of FLOPS when we multiply panel +* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1). +* +* D**(-1) = ( d11 cj(d21) )**(-1) = +* ( d21 d22 ) +* +* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) = +* ( (-d21) ( d11 ) ) +* +* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) * +* +* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) = +* ( ( -1 ) ( d11/conj(d21) ) ) +* +* = 1/(|d21|**2) * 1/(D22*D11-1) * +* +* * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = ( conj(D21)*( D11 ) D21*( -1 ) ) +* ( ( -1 ) ( D22 ) ), +* +* where D11 = d22/d21, +* D22 = d11/conj(d21), +* D21 = T/d21, +* T = 1/(D22*D11-1). +* +* (NOTE: No need to check for division by ZERO, +* since that was ensured earlier in pivot search: +* (a) d21 != 0, since in 2x2 pivot case(4) +* |d21| should be larger than |d11| and |d22|; +* (b) (D22*D11 - 1) != 0, since from (a), +* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.) * D21 = W( K-1, KW ) D11 = W( K, KW ) / CONJG( D21 ) D22 = W( K-1, KW-1 ) / D21 T = ONE / ( REAL( D11*D22 )-ONE ) D21 = T / D21 +* +* Update elements in columns A(k-1) and A(k) as +* dot products of rows of ( W(kw-1) W(kw) ) and columns +* of D**(-1) +* DO 20 J = 1, K - 2 A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) A( J, K ) = CONJG( D21 )* @@ -397,11 +523,13 @@ A( K-1, K ) = W( K-1, KW ) A( K, K ) = W( K, KW ) * -* Conjugate W(k) and W(k-1) +* (2) Conjugate columns W(kw) and W(kw-1) * CALL CLACGV( K-1, W( 1, KW ), 1 ) CALL CLACGV( K-2, W( 1, KW-1 ), 1 ) +* END IF +* END IF * * Store details of the interchanges in IPIV @@ -448,19 +576,27 @@ 50 CONTINUE * * Put U12 in standard form by partially undoing the interchanges -* in columns k+1:n +* in of rows in columns k+1:n looping backwards from k+1 to n * J = K + 1 60 CONTINUE - JJ = J - JP = IPIV( J ) - IF( JP.LT.0 ) THEN - JP = -JP +* +* Undo the interchanges (if any) of rows J and JP +* at each step J +* +* (Here, J is a diagonal index) + JJ = J + JP = IPIV( J ) + IF( JP.LT.0 ) THEN + JP = -JP +* (Here, J is a diagonal index) + J = J + 1 + END IF +* (NOTE: Here, J is used to determine row length. Length N-J+1 +* of the rows to swap back doesn't include diagonal element) J = J + 1 - END IF - J = J + 1 - IF( JP.NE.JJ .AND. J.LE.N ) - $ CALL CSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA ) + IF( JP.NE.JJ .AND. J.LE.N ) + $ CALL CSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA ) IF( J.LE.N ) $ GO TO 60 * @@ -483,6 +619,8 @@ * IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) $ GO TO 90 +* + KSTEP = 1 * * Copy column K of A to column K of W and update it * @@ -492,8 +630,6 @@ CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), LDA, $ W( K, 1 ), LDW, CONE, W( K, K ), 1 ) W( K, K ) = REAL( W( K, K ) ) -* - KSTEP = 1 * * Determine rows and columns to be interchanged and whether * a 1-by-1 or 2-by-2 pivot block will be used @@ -501,7 +637,8 @@ ABSAKK = ABS( REAL( W( K, K ) ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. * IF( K.LT.N ) THEN IMAX = K + ICAMAX( N-K, W( K+1, K ), 1 ) @@ -512,13 +649,19 @@ * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * -* Column K is zero: set INFO and continue +* Column K is zero or underflow: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K KP = K A( K, K ) = REAL( A( K, K ) ) ELSE +* +* ============================================================ +* +* BEGIN pivot search +* +* Case(1) IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * * no interchange, use 1-by-1 pivot block @@ -526,6 +669,9 @@ KP = K ELSE * +* BEGIN pivot search along IMAX row +* +* * Copy column IMAX to column K+1 of W and update it * CALL CCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 ) @@ -540,7 +686,8 @@ W( IMAX, K+1 ) = REAL( W( IMAX, K+1 ) ) * * JMAX is the column-index of the largest off-diagonal -* element in row IMAX, and ROWMAX is its absolute value +* element in row IMAX, and ROWMAX is its absolute value. +* Determine only ROWMAX. * JMAX = K - 1 + ICAMAX( IMAX-K, W( K, K+1 ), 1 ) ROWMAX = CABS1( W( JMAX, K+1 ) ) @@ -549,11 +696,14 @@ ROWMAX = MAX( ROWMAX, CABS1( W( JMAX, K+1 ) ) ) END IF * +* Case(2) IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN * * no interchange, use 1-by-1 pivot block * KP = K +* +* Case(3) ELSE IF( ABS( REAL( W( IMAX, K+1 ) ) ).GE.ALPHA*ROWMAX ) $ THEN * @@ -562,9 +712,11 @@ * KP = IMAX * -* copy column K+1 of W to column K +* copy column K+1 of W to column K of W * CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* +* Case(4) ELSE * * interchange rows and columns K+1 and IMAX, use 2-by-2 @@ -573,15 +725,29 @@ KP = IMAX KSTEP = 2 END IF +* +* +* END pivot search along IMAX row +* END IF +* +* END pivot search +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped * KK = K + KSTEP - 1 * -* Updated column KP is already stored in column KK of W +* Interchange rows and columns KP and KK. +* Updated column KP is already stored in column KK of W. * IF( KP.NE.KK ) THEN * -* Copy non-updated column KK to column KP +* Copy non-updated column KK to column KP of submatrix A +* at step K. No need to copy element into column K +* (or K and K+1 for 2-by-2 pivot) of A, since these columns +* will be later overwritten. * A( KP, KP ) = REAL( A( KK, KK ) ) CALL CCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), @@ -590,9 +756,13 @@ IF( KP.LT.N ) $ CALL CCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) * -* Interchange rows KK and KP in first KK columns of A and W +* Interchange rows KK and KP in first K-1 columns of A +* (columns K (or K and K+1 for 2-by-2 pivot) of A will be +* later overwritten). Interchange rows KK and KP +* in first KK columns of W. * - CALL CSWAP( KK-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) + IF( K.GT.1 ) + $ CALL CSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) CALL CSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) END IF * @@ -600,21 +770,35 @@ * * 1-by-1 pivot block D(k): column k of W now holds * -* W(k) = L(k)*D(k) +* W(k) = L(k)*D(k), * * where L(k) is the k-th column of L * -* Store L(k) in column k of A +* (1) Store subdiag. elements of column L(k) +* and 1-by-1 block D(k) in column k of A. +* (NOTE: Diagonal element L(k,k) is a UNIT element +* and not stored) +* A(k,k) := D(k,k) = W(k,k) +* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k) * +* (NOTE: No need to use for Hermitian matrix +* A( K, K ) = DBLE( W( K, K) ) to separately copy diagonal +* element D(k,k) from W (potentially saves only one load)) CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) IF( K.LT.N ) THEN +* +* (NOTE: No need to check if A(k,k) is NOT ZERO, +* since that was ensured earlier in pivot search: +* case A(k,k) = 0 falls into 2x2 pivot case(4)) +* R1 = ONE / REAL( A( K, K ) ) CALL CSSCAL( N-K, R1, A( K+1, K ), 1 ) * -* Conjugate W(k) +* (2) Conjugate column W(k) * CALL CLACGV( N-K, W( K+1, K ), 1 ) END IF +* ELSE * * 2-by-2 pivot block D(k): columns k and k+1 of W now hold @@ -623,16 +807,69 @@ * * where L(k) and L(k+1) are the k-th and (k+1)-th columns * of L +* +* (1) Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2 +* block D(k:k+1,k:k+1) in columns k and k+1 of A. +* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT +* block and not stored) +* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1) +* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) = +* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) ) * IF( K.LT.N-1 ) THEN * -* Store L(k) and L(k+1) in columns k and k+1 of A +* Factor out the columns of the inverse of 2-by-2 pivot +* block D, so that each column contains 1, to reduce the +* number of FLOPS when we multiply panel +* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1). +* +* D**(-1) = ( d11 cj(d21) )**(-1) = +* ( d21 d22 ) +* +* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) = +* ( (-d21) ( d11 ) ) +* +* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) * +* +* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) = +* ( ( -1 ) ( d11/conj(d21) ) ) +* +* = 1/(|d21|**2) * 1/(D22*D11-1) * +* +* * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = ( conj(D21)*( D11 ) D21*( -1 ) ) +* ( ( -1 ) ( D22 ) ) +* +* where D11 = d22/d21, +* D22 = d11/conj(d21), +* D21 = T/d21, +* T = 1/(D22*D11-1). +* +* (NOTE: No need to check for division by ZERO, +* since that was ensured earlier in pivot search: +* (a) d21 != 0, since in 2x2 pivot case(4) +* |d21| should be larger than |d11| and |d22|; +* (b) (D22*D11 - 1) != 0, since from (a), +* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.) * D21 = W( K+1, K ) D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / CONJG( D21 ) T = ONE / ( REAL( D11*D22 )-ONE ) D21 = T / D21 +* +* Update elements in columns A(k) and A(k+1) as +* dot products of rows of ( W(k) W(k+1) ) and columns +* of D**(-1) +* DO 80 J = K + 2, N A( J, K ) = CONJG( D21 )* $ ( D11*W( J, K )-W( J, K+1 ) ) @@ -646,11 +883,13 @@ A( K+1, K ) = W( K+1, K ) A( K+1, K+1 ) = W( K+1, K+1 ) * -* Conjugate W(k) and W(k+1) +* (2) Conjugate columns W(k) and W(k+1) * CALL CLACGV( N-K, W( K+1, K ), 1 ) CALL CLACGV( N-K-1, W( K+2, K+1 ), 1 ) +* END IF +* END IF * * Store details of the interchanges in IPIV @@ -698,19 +937,27 @@ 110 CONTINUE * * Put L21 in standard form by partially undoing the interchanges -* in columns 1:k-1 +* of rows in columns 1:k-1 looping backwards from k-1 to 1 * J = K - 1 120 CONTINUE - JJ = J - JP = IPIV( J ) - IF( JP.LT.0 ) THEN - JP = -JP +* +* Undo the interchanges (if any) of rows J and JP +* at each step J +* +* (Here, J is a diagonal index) + JJ = J + JP = IPIV( J ) + IF( JP.LT.0 ) THEN + JP = -JP +* (Here, J is a diagonal index) + J = J - 1 + END IF +* (NOTE: Here, J is used to determine row length. Length J +* of the rows to swap back doesn't include diagonal element) J = J - 1 - END IF - J = J - 1 - IF( JP.NE.JJ .AND. J.GE.1 ) - $ CALL CSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA ) + IF( JP.NE.JJ .AND. J.GE.1 ) + $ CALL CSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA ) IF( J.GE.1 ) $ GO TO 120 * diff --git a/lapack-netlib/SRC/clahef_rook.f b/lapack-netlib/SRC/clahef_rook.f new file mode 100644 index 000000000..698df999f --- /dev/null +++ b/lapack-netlib/SRC/clahef_rook.f @@ -0,0 +1,1176 @@ +* \brief \b CLAHEF_ROOK computes a partial factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (blocked algorithm, calling Level 3 BLAS). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CLAHEF_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), W( LDW, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLAHEF_ROOK computes a partial factorization of a complex Hermitian +*> matrix A using the bounded Bunch-Kaufman ("rook") diagonal pivoting +*> method. The partial factorization has the form: +*> +*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: +*> ( 0 U22 ) ( 0 D ) ( U12**H U22**H ) +*> +*> A = ( L11 0 ) ( D 0 ) ( L11**H L21**H ) if UPLO = 'L' +*> ( L21 I ) ( 0 A22 ) ( 0 I ) +*> +*> where the order of D is at most NB. The actual order is returned in +*> the argument KB, and is either NB or NB-1, or N if N <= NB. +*> Note that U**H denotes the conjugate transpose of U. +*> +*> CLAHEF_ROOK is an auxiliary routine called by CHETRF_ROOK. It uses +*> blocked code (calling Level 3 BLAS) to update the submatrix +*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> Hermitian matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The maximum number of columns of the matrix A that should be +*> factored. NB should be at least 2 to allow for 2-by-2 pivot +*> blocks. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> The number of columns of A that were actually factored. +*> KB is either NB-1 or NB, or N if N <= NB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading +*> n-by-n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading n-by-n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> On exit, A contains details of the partial factorization. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> Only the last KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> Only the first KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is COMPLEX array, dimension (LDW,NB) +*> \endverbatim +*> +*> \param[in] LDW +*> \verbatim +*> LDW is INTEGER +*> The leading dimension of the array W. LDW >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complexHEcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, + $ INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), W( LDW, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + COMPLEX CONE + PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) + REAL EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL DONE + INTEGER IMAX, ITEMP, II, J, JB, JJ, JMAX, JP1, JP2, K, + $ KK, KKW, KP, KSTEP, KW, P + REAL ABSAKK, ALPHA, COLMAX, STEMP, R1, ROWMAX, T, + $ SFMIN + COMPLEX D11, D21, D22, Z +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ICAMAX + REAL SLAMCH + EXTERNAL LSAME, ICAMAX, SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL CCOPY, CSSCAL, CGEMM, CGEMV, CLACGV, CSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, CONJG, AIMAG, MAX, MIN, REAL, SQRT +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function definitions .. + CABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) ) +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = SLAMCH( 'S' ) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Factorize the trailing columns of A using the upper triangle +* of A and working backwards, and compute the matrix W = U12*D +* for use in updating A11 (note that conjg(W) is actually stored) +* +* K is the main loop index, decreasing from N in steps of 1 or 2 +* + K = N + 10 CONTINUE +* +* KW is the column of W which corresponds to column K of A +* + KW = NB + K - N +* +* Exit from loop +* + IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) + $ GO TO 30 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column KW of W and update it +* + IF( K.GT.1 ) + $ CALL CCOPY( K-1, A( 1, K ), 1, W( 1, KW ), 1 ) + W( K, KW ) = REAL( A( K, K ) ) + IF( K.LT.N ) THEN + CALL CGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), LDA, + $ W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 ) + W( K, KW ) = REAL( W( K, KW ) ) + END IF +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( REAL( W( K, KW ) ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = ICAMAX( K-1, W( 1, KW ), 1 ) + COLMAX = CABS1( W( IMAX, KW ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + A( K, K ) = REAL( W( K, KW ) ) + IF( K.GT.1 ) + $ CALL CCOPY( K-1, W( 1, KW ), 1, A( 1, K ), 1 ) + ELSE +* +* ============================================================ +* +* BEGIN pivot search +* +* Case(1) +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* +* Lop until pivot found +* + DONE = .FALSE. +* + 12 CONTINUE +* +* BEGIN pivot search loop body +* +* +* Copy column IMAX to column KW-1 of W and update it +* + IF( IMAX.GT.1 ) + $ CALL CCOPY( IMAX-1, A( 1, IMAX ), 1, W( 1, KW-1 ), + $ 1 ) + W( IMAX, KW-1 ) = REAL( A( IMAX, IMAX ) ) +* + CALL CCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, + $ W( IMAX+1, KW-1 ), 1 ) + CALL CLACGV( K-IMAX, W( IMAX+1, KW-1 ), 1 ) +* + IF( K.LT.N ) THEN + CALL CGEMV( 'No transpose', K, N-K, -CONE, + $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW, + $ CONE, W( 1, KW-1 ), 1 ) + W( IMAX, KW-1 ) = REAL( W( IMAX, KW-1 ) ) + END IF +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + ICAMAX( K-IMAX, W( IMAX+1, KW-1 ), + $ 1 ) + ROWMAX = CABS1( W( JMAX, KW-1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = ICAMAX( IMAX-1, W( 1, KW-1 ), 1 ) + STEMP = CABS1( W( ITEMP, KW-1 ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Case(2) +* Equivalent to testing for +* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABS( REAL( W( IMAX,KW-1 ) ) ) + $ .LT.ALPHA*ROWMAX ) ) THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column KW-1 of W to column KW of W +* + CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + DONE = .TRUE. +* +* Case(3) +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K-1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. +* +* Case(4) + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + END IF +* +* +* END pivot search loop body +* + IF( .NOT.DONE ) GOTO 12 +* + END IF +* +* END pivot search +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped +* + KK = K - KSTEP + 1 +* +* KKW is the column of W which corresponds to column KK of A +* + KKW = NB + KK - N +* +* Interchange rows and columns P and K. +* Updated column P is already stored in column KW of W. +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P of submatrix A +* at step K. No need to copy element into columns +* K and K-1 of A for 2-by-2 pivot, since these columns +* will be later overwritten. +* + A( P, P ) = REAL( A( K, K ) ) + CALL CCOPY( K-1-P, A( P+1, K ), 1, A( P, P+1 ), + $ LDA ) + CALL CLACGV( K-1-P, A( P, P+1 ), LDA ) + IF( P.GT.1 ) + $ CALL CCOPY( P-1, A( 1, K ), 1, A( 1, P ), 1 ) +* +* Interchange rows K and P in the last K+1 to N columns of A +* (columns K and K-1 of A for 2-by-2 pivot will be +* later overwritten). Interchange rows K and P +* in last KKW to NB columns of W. +* + IF( K.LT.N ) + $ CALL CSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), + $ LDA ) + CALL CSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), + $ LDW ) + END IF +* +* Interchange rows and columns KP and KK. +* Updated column KP is already stored in column KKW of W. +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP of submatrix A +* at step K. No need to copy element into column K +* (or K and K-1 for 2-by-2 pivot) of A, since these columns +* will be later overwritten. +* + A( KP, KP ) = REAL( A( KK, KK ) ) + CALL CCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + CALL CLACGV( KK-1-KP, A( KP, KP+1 ), LDA ) + IF( KP.GT.1 ) + $ CALL CCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) +* +* Interchange rows KK and KP in last K+1 to N columns of A +* (columns K (or K and K-1 for 2-by-2 pivot) of A will be +* later overwritten). Interchange rows KK and KP +* in last KKW to NB columns of W. +* + IF( K.LT.N ) + $ CALL CSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ), + $ LDA ) + CALL CSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), + $ LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column kw of W now holds +* +* W(kw) = U(k)*D(k), +* +* where U(k) is the k-th column of U +* +* (1) Store subdiag. elements of column U(k) +* and 1-by-1 block D(k) in column k of A. +* (NOTE: Diagonal element U(k,k) is a UNIT element +* and not stored) +* A(k,k) := D(k,k) = W(k,kw) +* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k) +* +* (NOTE: No need to use for Hermitian matrix +* A( K, K ) = REAL( W( K, K) ) to separately copy diagonal +* element D(k,k) from W (potentially saves only one load)) + CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) + IF( K.GT.1 ) THEN +* +* (NOTE: No need to check if A(k,k) is NOT ZERO, +* since that was ensured earlier in pivot search: +* case A(k,k) = 0 falls into 2x2 pivot case(3)) +* +* Handle division by a small number +* + T = REAL( A( K, K ) ) + IF( ABS( T ).GE.SFMIN ) THEN + R1 = ONE / T + CALL CSSCAL( K-1, R1, A( 1, K ), 1 ) + ELSE + DO 14 II = 1, K-1 + A( II, K ) = A( II, K ) / T + 14 CONTINUE + END IF +* +* (2) Conjugate column W(kw) +* + CALL CLACGV( K-1, W( 1, KW ), 1 ) + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold +* +* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* +* (1) Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2 +* block D(k-1:k,k-1:k) in columns k-1 and k of A. +* (NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT +* block and not stored) +* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw) +* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) = +* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) ) +* + IF( K.GT.2 ) THEN +* +* Factor out the columns of the inverse of 2-by-2 pivot +* block D, so that each column contains 1, to reduce the +* number of FLOPS when we multiply panel +* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1). +* +* D**(-1) = ( d11 cj(d21) )**(-1) = +* ( d21 d22 ) +* +* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) = +* ( (-d21) ( d11 ) ) +* +* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) * +* +* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) = +* ( ( -1 ) ( d11/conj(d21) ) ) +* +* = 1/(|d21|**2) * 1/(D22*D11-1) * +* +* * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* Handle division by a small number. (NOTE: order of +* operations is important) +* +* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) ) +* ( (( -1 ) ) (( D22 ) ) ), +* +* where D11 = d22/d21, +* D22 = d11/conj(d21), +* D21 = d21, +* T = 1/(D22*D11-1). +* +* (NOTE: No need to check for division by ZERO, +* since that was ensured earlier in pivot search: +* (a) d21 != 0 in 2x2 pivot case(4), +* since |d21| should be larger than |d11| and |d22|; +* (b) (D22*D11 - 1) != 0, since from (a), +* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.) +* + D21 = W( K-1, KW ) + D11 = W( K, KW ) / CONJG( D21 ) + D22 = W( K-1, KW-1 ) / D21 + T = ONE / ( REAL( D11*D22 )-ONE ) +* +* Update elements in columns A(k-1) and A(k) as +* dot products of rows of ( W(kw-1) W(kw) ) and columns +* of D**(-1) +* + DO 20 J = 1, K - 2 + A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ CONJG( D21 ) ) + 20 CONTINUE + END IF +* +* Copy D(k) to A +* + A( K-1, K-1 ) = W( K-1, KW-1 ) + A( K-1, K ) = W( K-1, KW ) + A( K, K ) = W( K, KW ) +* +* (2) Conjugate columns W(kw) and W(kw-1) +* + CALL CLACGV( K-1, W( 1, KW ), 1 ) + CALL CLACGV( K-2, W( 1, KW-1 ), 1 ) +* + END IF +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + 30 CONTINUE +* +* Update the upper triangle of A11 (= A(1:k,1:k)) as +* +* A11 := A11 - U12*D*U12**H = A11 - U12*W**H +* +* computing blocks of NB columns at a time (note that conjg(W) is +* actually stored) +* + DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB + JB = MIN( NB, K-J+1 ) +* +* Update the upper triangle of the diagonal block +* + DO 40 JJ = J, J + JB - 1 + A( JJ, JJ ) = REAL( A( JJ, JJ ) ) + CALL CGEMV( 'No transpose', JJ-J+1, N-K, -CONE, + $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE, + $ A( J, JJ ), 1 ) + A( JJ, JJ ) = REAL( A( JJ, JJ ) ) + 40 CONTINUE +* +* Update the rectangular superdiagonal block +* + IF( J.GE.2 ) + $ CALL CGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, + $ -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, + $ CONE, A( 1, J ), LDA ) + 50 CONTINUE +* +* Put U12 in standard form by partially undoing the interchanges +* in of rows in columns k+1:n looping backwards from k+1 to n +* + J = K + 1 + 60 CONTINUE +* +* Undo the interchanges (if any) of rows J and JP2 +* (or J and JP2, and J+1 and JP1) at each step J +* + KSTEP = 1 + JP1 = 1 +* (Here, J is a diagonal index) + JJ = J + JP2 = IPIV( J ) + IF( JP2.LT.0 ) THEN + JP2 = -JP2 +* (Here, J is a diagonal index) + J = J + 1 + JP1 = -IPIV( J ) + KSTEP = 2 + END IF +* (NOTE: Here, J is used to determine row length. Length N-J+1 +* of the rows to swap back doesn't include diagonal element) + J = J + 1 + IF( JP2.NE.JJ .AND. J.LE.N ) + $ CALL CSWAP( N-J+1, A( JP2, J ), LDA, A( JJ, J ), LDA ) + JJ = JJ + 1 + IF( KSTEP.EQ.2 .AND. JP1.NE.JJ .AND. J.LE.N ) + $ CALL CSWAP( N-J+1, A( JP1, J ), LDA, A( JJ, J ), LDA ) + IF( J.LT.N ) + $ GO TO 60 +* +* Set KB to the number of columns factorized +* + KB = N - K +* + ELSE +* +* Factorize the leading columns of A using the lower triangle +* of A and working forwards, and compute the matrix W = L21*D +* for use in updating A22 (note that conjg(W) is actually stored) +* +* K is the main loop index, increasing from 1 in steps of 1 or 2 +* + K = 1 + 70 CONTINUE +* +* Exit from loop +* + IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) + $ GO TO 90 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column K of W and update column K of W +* + W( K, K ) = REAL( A( K, K ) ) + IF( K.LT.N ) + $ CALL CCOPY( N-K, A( K+1, K ), 1, W( K+1, K ), 1 ) + IF( K.GT.1 ) THEN + CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), + $ LDA, W( K, 1 ), LDW, CONE, W( K, K ), 1 ) + W( K, K ) = REAL( W( K, K ) ) + END IF +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( REAL( W( K, K ) ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + ICAMAX( N-K, W( K+1, K ), 1 ) + COLMAX = CABS1( W( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + A( K, K ) = REAL( W( K, K ) ) + IF( K.LT.N ) + $ CALL CCOPY( N-K, W( K+1, K ), 1, A( K+1, K ), 1 ) + ELSE +* +* ============================================================ +* +* BEGIN pivot search +* +* Case(1) +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 72 CONTINUE +* +* BEGIN pivot search loop body +* +* +* Copy column IMAX to column k+1 of W and update it +* + CALL CCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1) + CALL CLACGV( IMAX-K, W( K, K+1 ), 1 ) + W( IMAX, K+1 ) = REAL( A( IMAX, IMAX ) ) +* + IF( IMAX.LT.N ) + $ CALL CCOPY( N-IMAX, A( IMAX+1, IMAX ), 1, + $ W( IMAX+1, K+1 ), 1 ) +* + IF( K.GT.1 ) THEN + CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, + $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW, + $ CONE, W( K, K+1 ), 1 ) + W( IMAX, K+1 ) = REAL( W( IMAX, K+1 ) ) + END IF +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + ICAMAX( IMAX-K, W( K, K+1 ), 1 ) + ROWMAX = CABS1( W( JMAX, K+1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + ICAMAX( N-IMAX, W( IMAX+1, K+1 ), 1) + STEMP = CABS1( W( ITEMP, K+1 ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Case(2) +* Equivalent to testing for +* ABS( REAL( W( IMAX,K+1 ) ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABS( REAL( W( IMAX,K+1 ) ) ) + $ .LT.ALPHA*ROWMAX ) ) THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column K+1 of W to column K of W +* + CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + DONE = .TRUE. +* +* Case(3) +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. +* +* Case(4) + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + END IF +* +* +* End pivot search loop body +* + IF( .NOT.DONE ) GOTO 72 +* + END IF +* +* END pivot search +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped +* + KK = K + KSTEP - 1 +* +* Interchange rows and columns P and K (only for 2-by-2 pivot). +* Updated column P is already stored in column K of W. +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column KK-1 to column P of submatrix A +* at step K. No need to copy element into columns +* K and K+1 of A for 2-by-2 pivot, since these columns +* will be later overwritten. +* + A( P, P ) = REAL( A( K, K ) ) + CALL CCOPY( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA ) + CALL CLACGV( P-K-1, A( P, K+1 ), LDA ) + IF( P.LT.N ) + $ CALL CCOPY( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) +* +* Interchange rows K and P in first K-1 columns of A +* (columns K and K+1 of A for 2-by-2 pivot will be +* later overwritten). Interchange rows K and P +* in first KK columns of W. +* + IF( K.GT.1 ) + $ CALL CSWAP( K-1, A( K, 1 ), LDA, A( P, 1 ), LDA ) + CALL CSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW ) + END IF +* +* Interchange rows and columns KP and KK. +* Updated column KP is already stored in column KK of W. +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP of submatrix A +* at step K. No need to copy element into column K +* (or K and K+1 for 2-by-2 pivot) of A, since these columns +* will be later overwritten. +* + A( KP, KP ) = REAL( A( KK, KK ) ) + CALL CCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ LDA ) + CALL CLACGV( KP-KK-1, A( KP, KK+1 ), LDA ) + IF( KP.LT.N ) + $ CALL CCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) +* +* Interchange rows KK and KP in first K-1 columns of A +* (column K (or K and K+1 for 2-by-2 pivot) of A will be +* later overwritten). Interchange rows KK and KP +* in first KK columns of W. +* + IF( K.GT.1 ) + $ CALL CSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) + CALL CSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k of W now holds +* +* W(k) = L(k)*D(k), +* +* where L(k) is the k-th column of L +* +* (1) Store subdiag. elements of column L(k) +* and 1-by-1 block D(k) in column k of A. +* (NOTE: Diagonal element L(k,k) is a UNIT element +* and not stored) +* A(k,k) := D(k,k) = W(k,k) +* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k) +* +* (NOTE: No need to use for Hermitian matrix +* A( K, K ) = REAL( W( K, K) ) to separately copy diagonal +* element D(k,k) from W (potentially saves only one load)) + CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) + IF( K.LT.N ) THEN +* +* (NOTE: No need to check if A(k,k) is NOT ZERO, +* since that was ensured earlier in pivot search: +* case A(k,k) = 0 falls into 2x2 pivot case(3)) +* +* Handle division by a small number +* + T = REAL( A( K, K ) ) + IF( ABS( T ).GE.SFMIN ) THEN + R1 = ONE / T + CALL CSSCAL( N-K, R1, A( K+1, K ), 1 ) + ELSE + DO 74 II = K + 1, N + A( II, K ) = A( II, K ) / T + 74 CONTINUE + END IF +* +* (2) Conjugate column W(k) +* + CALL CLACGV( N-K, W( K+1, K ), 1 ) + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 of W now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* +* (1) Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2 +* block D(k:k+1,k:k+1) in columns k and k+1 of A. +* NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT +* block and not stored. +* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1) +* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) = +* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) ) +* + IF( K.LT.N-1 ) THEN +* +* Factor out the columns of the inverse of 2-by-2 pivot +* block D, so that each column contains 1, to reduce the +* number of FLOPS when we multiply panel +* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1). +* +* D**(-1) = ( d11 cj(d21) )**(-1) = +* ( d21 d22 ) +* +* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) = +* ( (-d21) ( d11 ) ) +* +* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) * +* +* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) = +* ( ( -1 ) ( d11/conj(d21) ) ) +* +* = 1/(|d21|**2) * 1/(D22*D11-1) * +* +* * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* Handle division by a small number. (NOTE: order of +* operations is important) +* +* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) ) +* ( (( -1 ) ) (( D22 ) ) ), +* +* where D11 = d22/d21, +* D22 = d11/conj(d21), +* D21 = d21, +* T = 1/(D22*D11-1). +* +* (NOTE: No need to check for division by ZERO, +* since that was ensured earlier in pivot search: +* (a) d21 != 0 in 2x2 pivot case(4), +* since |d21| should be larger than |d11| and |d22|; +* (b) (D22*D11 - 1) != 0, since from (a), +* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.) +* + D21 = W( K+1, K ) + D11 = W( K+1, K+1 ) / D21 + D22 = W( K, K ) / CONJG( D21 ) + T = ONE / ( REAL( D11*D22 )-ONE ) +* +* Update elements in columns A(k) and A(k+1) as +* dot products of rows of ( W(k) W(k+1) ) and columns +* of D**(-1) +* + DO 80 J = K + 2, N + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ CONJG( D21 ) ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) + 80 CONTINUE + END IF +* +* Copy D(k) to A +* + A( K, K ) = W( K, K ) + A( K+1, K ) = W( K+1, K ) + A( K+1, K+1 ) = W( K+1, K+1 ) +* +* (2) Conjugate columns W(k) and W(k+1) +* + CALL CLACGV( N-K, W( K+1, K ), 1 ) + CALL CLACGV( N-K-1, W( K+2, K+1 ), 1 ) +* + END IF +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 70 +* + 90 CONTINUE +* +* Update the lower triangle of A22 (= A(k:n,k:n)) as +* +* A22 := A22 - L21*D*L21**H = A22 - L21*W**H +* +* computing blocks of NB columns at a time (note that conjg(W) is +* actually stored) +* + DO 110 J = K, N, NB + JB = MIN( NB, N-J+1 ) +* +* Update the lower triangle of the diagonal block +* + DO 100 JJ = J, J + JB - 1 + A( JJ, JJ ) = REAL( A( JJ, JJ ) ) + CALL CGEMV( 'No transpose', J+JB-JJ, K-1, -CONE, + $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE, + $ A( JJ, JJ ), 1 ) + A( JJ, JJ ) = REAL( A( JJ, JJ ) ) + 100 CONTINUE +* +* Update the rectangular subdiagonal block +* + IF( J+JB.LE.N ) + $ CALL CGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, + $ K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ), + $ LDW, CONE, A( J+JB, J ), LDA ) + 110 CONTINUE +* +* Put L21 in standard form by partially undoing the interchanges +* of rows in columns 1:k-1 looping backwards from k-1 to 1 +* + J = K - 1 + 120 CONTINUE +* +* Undo the interchanges (if any) of rows J and JP2 +* (or J and JP2, and J-1 and JP1) at each step J +* + KSTEP = 1 + JP1 = 1 +* (Here, J is a diagonal index) + JJ = J + JP2 = IPIV( J ) + IF( JP2.LT.0 ) THEN + JP2 = -JP2 +* (Here, J is a diagonal index) + J = J - 1 + JP1 = -IPIV( J ) + KSTEP = 2 + END IF +* (NOTE: Here, J is used to determine row length. Length J +* of the rows to swap back doesn't include diagonal element) + J = J - 1 + IF( JP2.NE.JJ .AND. J.GE.1 ) + $ CALL CSWAP( J, A( JP2, 1 ), LDA, A( JJ, 1 ), LDA ) + JJ = JJ -1 + IF( KSTEP.EQ.2 .AND. JP1.NE.JJ .AND. J.GE.1 ) + $ CALL CSWAP( J, A( JP1, 1 ), LDA, A( JJ, 1 ), LDA ) + IF( J.GT.1 ) + $ GO TO 120 +* +* Set KB to the number of columns factorized +* + KB = K - 1 +* + END IF + RETURN +* +* End of CLAHEF_ROOK +* + END diff --git a/lapack-netlib/SRC/clarfb.f b/lapack-netlib/SRC/clarfb.f index ea378f3a1..19d7b81ca 100644 --- a/lapack-netlib/SRC/clarfb.f +++ b/lapack-netlib/SRC/clarfb.f @@ -159,7 +159,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2013 * *> \ingroup complexOTHERauxiliary * @@ -195,10 +195,10 @@ SUBROUTINE CLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2013 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS @@ -217,12 +217,11 @@ * .. * .. Local Scalars .. CHARACTER TRANST - INTEGER I, J, LASTV, LASTC + INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILACLR, ILACLC - EXTERNAL LSAME, ILACLR, ILACLC + EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL CCOPY, CGEMM, CLACGV, CTRMM @@ -255,36 +254,33 @@ * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) -* - LASTV = MAX( K, ILACLR( M, K, V, LDV ) ) - LASTC = ILACLC( LASTV, N, C, LDC ) * * W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) * * W := C1**H * DO 10 J = 1, K - CALL CCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - CALL CLACGV( LASTC, WORK( 1, J ), 1 ) + CALL CCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL CLACGV( N, WORK( 1, J ), 1 ) 10 CONTINUE * * W := W * V1 * - CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN * * W := W + C2**H *V2 * - CALL CGEMM( 'Conjugate transpose', 'No transpose', - $ LASTC, K, LASTV-K, ONE, C( K+1, 1 ), LDC, - $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK ) + CALL CGEMM( 'Conjugate transpose', 'No transpose', N, + $ K, M-K, ONE, C( K+1, 1 ), LDC, + $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**H or W * T * - CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**H * @@ -293,19 +289,19 @@ * C2 := C2 - V2 * W**H * CALL CGEMM( 'No transpose', 'Conjugate transpose', - $ LASTV-K, LASTC, K, -ONE, V( K+1, 1 ), LDV, - $ WORK, LDWORK, ONE, C( K+1, 1 ), LDC ) + $ M-K, N, K, -ONE, V( K+1, 1 ), LDV, WORK, + $ LDWORK, ONE, C( K+1, 1 ), LDC ) END IF * * W := W * V1**H * CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) + $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**H * DO 30 J = 1, K - DO 20 I = 1, LASTC + DO 20 I = 1, N C( J, I ) = C( J, I ) - CONJG( WORK( I, J ) ) 20 CONTINUE 30 CONTINUE @@ -313,58 +309,53 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) -* - LASTV = MAX( K, ILACLR( N, K, V, LDV ) ) - LASTC = ILACLR( M, LASTV, C, LDC ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C1 * DO 40 J = 1, K - CALL CCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + CALL CCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 40 CONTINUE * * W := W * V1 * - CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN * * W := W + C2 * V2 * - CALL CGEMM( 'No transpose', 'No transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) + CALL CGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**H * - CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**H * - IF( LASTV.GT.K ) THEN + IF( N.GT.K ) THEN * * C2 := C2 - W * V2**H * - CALL CGEMM( 'No transpose', 'Conjugate transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, - $ ONE, C( 1, K+1 ), LDC ) + CALL CGEMM( 'No transpose', 'Conjugate transpose', M, + $ N-K, K, -ONE, WORK, LDWORK, V( K+1, 1 ), + $ LDV, ONE, C( 1, K+1 ), LDC ) END IF * * W := W * V1**H * CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) + $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 60 J = 1, K - DO 50 I = 1, LASTC + DO 50 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 50 CONTINUE 60 CONTINUE @@ -379,38 +370,34 @@ IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H**H * C where C = ( C1 ) -* ( C2 ) -* - LASTC = ILACLC( M, N, C, LDC ) +* ( C2 ) * * W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) * * W := C2**H * DO 70 J = 1, K - CALL CCOPY( LASTC, C( M-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) - CALL CLACGV( LASTC, WORK( 1, J ), 1 ) + CALL CCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL CLACGV( N, WORK( 1, J ), 1 ) 70 CONTINUE * * W := W * V2 * - CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( M-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * -* W := W + C1**H*V1 +* W := W + C1**H * V1 * - CALL CGEMM( 'Conjugate transpose', 'No transpose', - $ LASTC, K, M-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL CGEMM( 'Conjugate transpose', 'No transpose', N, + $ K, M-K, ONE, C, LDC, V, LDV, ONE, WORK, + $ LDWORK ) END IF * * W := W * T**H or W * T * - CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**H * @@ -419,20 +406,20 @@ * C1 := C1 - V1 * W**H * CALL CGEMM( 'No transpose', 'Conjugate transpose', - $ M-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) + $ M-K, N, K, -ONE, V, LDV, WORK, LDWORK, + $ ONE, C, LDC ) END IF * * W := W * V2**H * CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V( M-K+1, 1 ), LDV, - $ WORK, LDWORK ) + $ 'Unit', N, K, ONE, V( M-K+1, 1 ), LDV, WORK, + $ LDWORK ) * * C2 := C2 - W**H * DO 90 J = 1, K - DO 80 I = 1, LASTC + DO 80 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - $ CONJG( WORK( I, J ) ) 80 CONTINUE @@ -441,36 +428,31 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) -* - LASTC = ILACLR( M, N, C, LDC ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C2 * DO 100 J = 1, K - CALL CCOPY( LASTC, C( 1, N-K+J ), 1, - $ WORK( 1, J ), 1 ) + CALL CCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 100 CONTINUE * * W := W * V2 * - CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( N-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1 * - CALL CGEMM( 'No transpose', 'No transpose', - $ LASTC, K, N-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + CALL CGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**H * - CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**H * @@ -478,23 +460,22 @@ * * C1 := C1 - W * V1**H * - CALL CGEMM( 'No transpose', 'Conjugate transpose', - $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) + CALL CGEMM( 'No transpose', 'Conjugate transpose', M, + $ N-K, K, -ONE, WORK, LDWORK, V, LDV, ONE, + $ C, LDC ) END IF * * W := W * V2**H * CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V( N-K+1, 1 ), LDV, - $ WORK, LDWORK ) + $ 'Unit', M, K, ONE, V( N-K+1, 1 ), LDV, WORK, + $ LDWORK ) * * C2 := C2 - W * DO 120 J = 1, K - DO 110 I = 1, LASTC - C( I, N-K+J ) = C( I, N-K+J ) - $ - WORK( I, J ) + DO 110 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 110 CONTINUE 120 CONTINUE END IF @@ -511,59 +492,56 @@ * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) -* - LASTV = MAX( K, ILACLC( K, M, V, LDV ) ) - LASTC = ILACLC( LASTV, N, C, LDC ) * * W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) * * W := C1**H * DO 130 J = 1, K - CALL CCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - CALL CLACGV( LASTC, WORK( 1, J ), 1 ) + CALL CCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL CLACGV( N, WORK( 1, J ), 1 ) 130 CONTINUE * * W := W * V1**H * CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN * -* W := W + C2**H*V2**H +* W := W + C2**H * V2**H * CALL CGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', LASTC, K, LASTV-K, - $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) + $ 'Conjugate transpose', N, K, M-K, ONE, + $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, + $ WORK, LDWORK ) END IF * * W := W * T**H or W * T * - CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**H * W**H * - IF( LASTV.GT.K ) THEN + IF( M.GT.K ) THEN * * C2 := C2 - V2**H * W**H * CALL CGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', LASTV-K, LASTC, K, - $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, - $ ONE, C( K+1, 1 ), LDC ) + $ 'Conjugate transpose', M-K, N, K, -ONE, + $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) END IF * * W := W * V1 * - CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**H * DO 150 J = 1, K - DO 140 I = 1, LASTC + DO 140 I = 1, N C( J, I ) = C( J, I ) - CONJG( WORK( I, J ) ) 140 CONTINUE 150 CONTINUE @@ -571,57 +549,53 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) -* - LASTV = MAX( K, ILACLC( K, N, V, LDV ) ) - LASTC = ILACLR( M, LASTV, C, LDC ) * * W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) * * W := C1 * DO 160 J = 1, K - CALL CCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + CALL CCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 160 CONTINUE * * W := W * V1**H * CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN * * W := W + C2 * V2**H * - CALL CGEMM( 'No transpose', 'Conjugate transpose', - $ LASTC, K, LASTV-K, ONE, C( 1, K+1 ), LDC, - $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK ) + CALL CGEMM( 'No transpose', 'Conjugate transpose', M, + $ K, N-K, ONE, C( 1, K+1 ), LDC, + $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**H * - CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * - IF( LASTV.GT.K ) THEN + IF( N.GT.K ) THEN * * C2 := C2 - W * V2 * - CALL CGEMM( 'No transpose', 'No transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, - $ ONE, C( 1, K+1 ), LDC ) + CALL CGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) END IF * * W := W * V1 * - CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 180 J = 1, K - DO 170 I = 1, LASTC + DO 170 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 170 CONTINUE 180 CONTINUE @@ -637,37 +611,34 @@ * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) -* - LASTC = ILACLC( M, N, C, LDC ) * * W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) * * W := C2**H * DO 190 J = 1, K - CALL CCOPY( LASTC, C( M-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) - CALL CLACGV( LASTC, WORK( 1, J ), 1 ) + CALL CCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL CLACGV( N, WORK( 1, J ), 1 ) 190 CONTINUE * * W := W * V2**H * CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V( 1, M-K+1 ), LDV, - $ WORK, LDWORK ) + $ 'Unit', N, K, ONE, V( 1, M-K+1 ), LDV, WORK, + $ LDWORK ) IF( M.GT.K ) THEN * * W := W + C1**H * V1**H * CALL CGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', LASTC, K, M-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + $ 'Conjugate transpose', N, K, M-K, ONE, C, + $ LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**H or W * T * - CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**H * W**H * @@ -676,20 +647,19 @@ * C1 := C1 - V1**H * W**H * CALL CGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', M-K, LASTC, K, - $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) + $ 'Conjugate transpose', M-K, N, K, -ONE, V, + $ LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2 * - CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, M-K+1 ), LDV, - $ WORK, LDWORK ) + CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W**H * DO 210 J = 1, K - DO 200 I = 1, LASTC + DO 200 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - $ CONJG( WORK( I, J ) ) 200 CONTINUE @@ -698,36 +668,33 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) -* - LASTC = ILACLR( M, N, C, LDC ) * * W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) * * W := C2 * DO 220 J = 1, K - CALL CCOPY( LASTC, C( 1, N-K+J ), 1, - $ WORK( 1, J ), 1 ) + CALL CCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 220 CONTINUE * * W := W * V2**H * CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V( 1, N-K+1 ), LDV, - $ WORK, LDWORK ) + $ 'Unit', M, K, ONE, V( 1, N-K+1 ), LDV, WORK, + $ LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1**H * - CALL CGEMM( 'No transpose', 'Conjugate transpose', - $ LASTC, K, N-K, ONE, C, LDC, V, LDV, ONE, - $ WORK, LDWORK ) + CALL CGEMM( 'No transpose', 'Conjugate transpose', M, + $ K, N-K, ONE, C, LDC, V, LDV, ONE, WORK, + $ LDWORK ) END IF * * W := W * T or W * T**H * - CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * @@ -735,21 +702,19 @@ * * C1 := C1 - W * V1 * - CALL CGEMM( 'No transpose', 'No transpose', - $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) + CALL CGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2 * - CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, N-K+1 ), LDV, - $ WORK, LDWORK ) + CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 240 J = 1, K - DO 230 I = 1, LASTC + DO 230 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 230 CONTINUE 240 CONTINUE diff --git a/lapack-netlib/SRC/clartg.f b/lapack-netlib/SRC/clartg.f index a720f1d0b..cfff122a1 100644 --- a/lapack-netlib/SRC/clartg.f +++ b/lapack-netlib/SRC/clartg.f @@ -85,7 +85,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup complexOTHERauxiliary * @@ -103,10 +103,10 @@ * ===================================================================== SUBROUTINE CLARTG( F, G, CS, SN, R ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. REAL CS @@ -130,7 +130,8 @@ * .. * .. External Functions .. REAL SLAMCH, SLAPY2 - EXTERNAL SLAMCH, SLAPY2 + LOGICAL SISNAN + EXTERNAL SLAMCH, SLAPY2, SISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, INT, LOG, MAX, REAL, @@ -139,26 +140,17 @@ * .. Statement Functions .. REAL ABS1, ABSSQ * .. -* .. Save statement .. -* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 -* .. -* .. Data statements .. -* DATA FIRST / .TRUE. / -* .. * .. Statement Function definitions .. ABS1( FF ) = MAX( ABS( REAL( FF ) ), ABS( AIMAG( FF ) ) ) ABSSQ( FF ) = REAL( FF )**2 + AIMAG( FF )**2 * .. * .. Executable Statements .. * -* IF( FIRST ) THEN - SAFMIN = SLAMCH( 'S' ) - EPS = SLAMCH( 'E' ) - SAFMN2 = SLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / - $ LOG( SLAMCH( 'B' ) ) / TWO ) - SAFMX2 = ONE / SAFMN2 -* FIRST = .FALSE. -* END IF + SAFMIN = SLAMCH( 'S' ) + EPS = SLAMCH( 'E' ) + SAFMN2 = SLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / + $ LOG( SLAMCH( 'B' ) ) / TWO ) + SAFMX2 = ONE / SAFMN2 SCALE = MAX( ABS1( F ), ABS1( G ) ) FS = F GS = G @@ -172,7 +164,7 @@ IF( SCALE.GE.SAFMX2 ) $ GO TO 10 ELSE IF( SCALE.LE.SAFMN2 ) THEN - IF( G.EQ.CZERO ) THEN + IF( G.EQ.CZERO.OR.SISNAN( ABS( G ) ) ) THEN CS = ONE SN = CZERO R = F diff --git a/lapack-netlib/SRC/clasyf.f b/lapack-netlib/SRC/clasyf.f index 87d911748..ade36f9e2 100644 --- a/lapack-netlib/SRC/clasyf.f +++ b/lapack-netlib/SRC/clasyf.f @@ -1,25 +1,25 @@ -*> \brief \b CLASYF computes a partial factorization of a complex symmetric matrix, using the diagonal pivoting method. +*> \brief \b CLASYF computes a partial factorization of a complex symmetric matrix using the Bunch-Kaufman diagonal pivoting method. * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download CLASYF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download CLASYF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KB, LDA, LDW, N, NB @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), W( LDW, * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,16 +110,26 @@ *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D. -*> If UPLO = 'U', only the last KB elements of IPIV are set; -*> if UPLO = 'L', only the first KB elements are set. *> -*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were -*> interchanged and D(k,k) is a 1-by-1 diagonal block. -*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and -*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) -*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = -*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were -*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> If UPLO = 'U': +*> Only the last KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns +*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) +*> is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> Only the first KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns +*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1) +*> is a 2-by-2 diagonal block. *> \endverbatim *> *> \param[out] W @@ -145,22 +155,32 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup complexSYcomputational * +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> \endverbatim +* * ===================================================================== SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER UPLO @@ -246,7 +266,8 @@ ABSAKK = CABS1( W( K, KW ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. * IF( K.GT.1 ) THEN IMAX = ICAMAX( K-1, W( 1, KW ), 1 ) @@ -257,7 +278,7 @@ * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * -* Column K is zero: set INFO and continue +* Column K is zero or underflow: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K @@ -302,7 +323,7 @@ * KP = IMAX * -* copy column KW-1 of W to column KW +* copy column KW-1 of W to column KW of W * CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) ELSE @@ -314,59 +335,117 @@ KSTEP = 2 END IF END IF +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped * KK = K - KSTEP + 1 +* +* KKW is the column of W which corresponds to column KK of A +* KKW = NB + KK - N * -* Updated column KP is already stored in column KKW of W +* Interchange rows and columns KP and KK. +* Updated column KP is already stored in column KKW of W. * IF( KP.NE.KK ) THEN * -* Copy non-updated column KK to column KP +* Copy non-updated column KK to column KP of submatrix A +* at step K. No need to copy element into column K +* (or K and K-1 for 2-by-2 pivot) of A, since these columns +* will be later overwritten. * - A( KP, K ) = A( KK, K ) - CALL CCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), + A( KP, KP ) = A( KK, KK ) + CALL CCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), $ LDA ) - CALL CCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 ) + IF( KP.GT.1 ) + $ CALL CCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) * -* Interchange rows KK and KP in last KK columns of A and W +* Interchange rows KK and KP in last K+1 to N columns of A +* (columns K (or K and K-1 for 2-by-2 pivot) of A will be +* later overwritten). Interchange rows KK and KP +* in last KKW to NB columns of W. * - CALL CSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA ) + IF( K.LT.N ) + $ CALL CSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ), + $ LDA ) CALL CSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), $ LDW ) END IF * IF( KSTEP.EQ.1 ) THEN * -* 1-by-1 pivot block D(k): column KW of W now holds +* 1-by-1 pivot block D(k): column kw of W now holds * -* W(k) = U(k)*D(k) +* W(kw) = U(k)*D(k), * * where U(k) is the k-th column of U * -* Store U(k) in column k of A +* Store subdiag. elements of column U(k) +* and 1-by-1 block D(k) in column k of A. +* NOTE: Diagonal element U(k,k) is a UNIT element +* and not stored. +* A(k,k) := D(k,k) = W(k,kw) +* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k) * CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) R1 = CONE / A( K, K ) CALL CSCAL( K-1, R1, A( 1, K ), 1 ) +* ELSE * -* 2-by-2 pivot block D(k): columns KW and KW-1 of W now -* hold +* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold * -* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k) * * where U(k) and U(k-1) are the k-th and (k-1)-th columns * of U +* +* Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2 +* block D(k-1:k,k-1:k) in columns k-1 and k of A. +* NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT +* block and not stored. +* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw) +* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) = +* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) ) * IF( K.GT.2 ) THEN * -* Store U(k) and U(k-1) in columns k and k-1 of A +* Compose the columns of the inverse of 2-by-2 pivot +* block D in the following way to reduce the number +* of FLOPS when we myltiply panel ( W(kw-1) W(kw) ) by +* this inverse +* +* D**(-1) = ( d11 d21 )**(-1) = +* ( d21 d22 ) +* +* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = +* ( (-d21 ) ( d11 ) ) +* +* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * +* +* * ( ( d22/d21 ) ( -1 ) ) = +* ( ( -1 ) ( d11/d21 ) ) +* +* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = 1/d21 * T * ( ( D11 ) ( -1 ) ) +* ( ( -1 ) ( D22 ) ) +* +* = D21 * ( ( D11 ) ( -1 ) ) +* ( ( -1 ) ( D22 ) ) * D21 = W( K-1, KW ) D11 = W( K, KW ) / D21 D22 = W( K-1, KW-1 ) / D21 T = CONE / ( D11*D22-CONE ) +* +* Update elements in columns A(k-1) and A(k) as +* dot products of rows of ( W(kw-1) W(kw) ) and columns +* of D**(-1) +* D21 = T / D21 DO 20 J = 1, K - 2 A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) @@ -379,7 +458,9 @@ A( K-1, K-1 ) = W( K-1, KW-1 ) A( K-1, K ) = W( K-1, KW ) A( K, K ) = W( K, KW ) +* END IF +* END IF * * Store details of the interchanges in IPIV @@ -423,20 +504,28 @@ 50 CONTINUE * * Put U12 in standard form by partially undoing the interchanges -* in columns k+1:n +* in columns k+1:n looping backwards from k+1 to n * J = K + 1 60 CONTINUE - JJ = J - JP = IPIV( J ) - IF( JP.LT.0 ) THEN - JP = -JP +* +* Undo the interchanges (if any) of rows JJ and JP at each +* step J +* +* (Here, J is a diagonal index) + JJ = J + JP = IPIV( J ) + IF( JP.LT.0 ) THEN + JP = -JP +* (Here, J is a diagonal index) + J = J + 1 + END IF +* (NOTE: Here, J is used to determine row length. Length N-J+1 +* of the rows to swap back doesn't include diagonal element) J = J + 1 - END IF - J = J + 1 - IF( JP.NE.JJ .AND. J.LE.N ) - $ CALL CSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA ) - IF( J.LE.N ) + IF( JP.NE.JJ .AND. J.LE.N ) + $ CALL CSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA ) + IF( J.LT.N ) $ GO TO 60 * * Set KB to the number of columns factorized @@ -473,7 +562,8 @@ ABSAKK = CABS1( W( K, K ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. * IF( K.LT.N ) THEN IMAX = K + ICAMAX( N-K, W( K+1, K ), 1 ) @@ -484,7 +574,7 @@ * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * -* Column K is zero: set INFO and continue +* Column K is zero or underflow: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K @@ -528,7 +618,7 @@ * KP = IMAX * -* copy column K+1 of W to column K +* copy column K+1 of W to column K of W * CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) ELSE @@ -540,22 +630,36 @@ KSTEP = 2 END IF END IF +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped * KK = K + KSTEP - 1 * -* Updated column KP is already stored in column KK of W +* Interchange rows and columns KP and KK. +* Updated column KP is already stored in column KK of W. * IF( KP.NE.KK ) THEN * -* Copy non-updated column KK to column KP +* Copy non-updated column KK to column KP of submatrix A +* at step K. No need to copy element into column K +* (or K and K+1 for 2-by-2 pivot) of A, since these columns +* will be later overwritten. * - A( KP, K ) = A( KK, K ) - CALL CCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA ) - CALL CCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 ) + A( KP, KP ) = A( KK, KK ) + CALL CCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ LDA ) + IF( KP.LT.N ) + $ CALL CCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) * -* Interchange rows KK and KP in first KK columns of A and W +* Interchange rows KK and KP in first K-1 columns of A +* (columns K (or K and K+1 for 2-by-2 pivot) of A will be +* later overwritten). Interchange rows KK and KP +* in first KK columns of W. * - CALL CSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) + IF( K.GT.1 ) + $ CALL CSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) CALL CSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) END IF * @@ -563,17 +667,23 @@ * * 1-by-1 pivot block D(k): column k of W now holds * -* W(k) = L(k)*D(k) +* W(k) = L(k)*D(k), * * where L(k) is the k-th column of L * -* Store L(k) in column k of A +* Store subdiag. elements of column L(k) +* and 1-by-1 block D(k) in column k of A. +* (NOTE: Diagonal element L(k,k) is a UNIT element +* and not stored) +* A(k,k) := D(k,k) = W(k,k) +* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k) * CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) IF( K.LT.N ) THEN R1 = CONE / A( K, K ) CALL CSCAL( N-K, R1, A( K+1, K ), 1 ) END IF +* ELSE * * 2-by-2 pivot block D(k): columns k and k+1 of W now hold @@ -582,16 +692,52 @@ * * where L(k) and L(k+1) are the k-th and (k+1)-th columns * of L +* +* Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2 +* block D(k:k+1,k:k+1) in columns k and k+1 of A. +* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT +* block and not stored) +* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1) +* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) = +* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) ) * IF( K.LT.N-1 ) THEN * -* Store L(k) and L(k+1) in columns k and k+1 of A +* Compose the columns of the inverse of 2-by-2 pivot +* block D in the following way to reduce the number +* of FLOPS when we myltiply panel ( W(k) W(k+1) ) by +* this inverse +* +* D**(-1) = ( d11 d21 )**(-1) = +* ( d21 d22 ) +* +* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = +* ( (-d21 ) ( d11 ) ) +* +* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * +* +* * ( ( d22/d21 ) ( -1 ) ) = +* ( ( -1 ) ( d11/d21 ) ) +* +* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = 1/d21 * T * ( ( D11 ) ( -1 ) ) +* ( ( -1 ) ( D22 ) ) +* +* = D21 * ( ( D11 ) ( -1 ) ) +* ( ( -1 ) ( D22 ) ) * D21 = W( K+1, K ) D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / D21 T = CONE / ( D11*D22-CONE ) D21 = T / D21 +* +* Update elements in columns A(k) and A(k+1) as +* dot products of rows of ( W(k) W(k+1) ) and columns +* of D**(-1) +* DO 80 J = K + 2, N A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) ) A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) @@ -603,7 +749,9 @@ A( K, K ) = W( K, K ) A( K+1, K ) = W( K+1, K ) A( K+1, K+1 ) = W( K+1, K+1 ) +* END IF +* END IF * * Store details of the interchanges in IPIV @@ -648,20 +796,28 @@ 110 CONTINUE * * Put L21 in standard form by partially undoing the interchanges -* in columns 1:k-1 +* of rows in columns 1:k-1 looping backwards from k-1 to 1 * J = K - 1 120 CONTINUE - JJ = J - JP = IPIV( J ) - IF( JP.LT.0 ) THEN - JP = -JP +* +* Undo the interchanges (if any) of rows JJ and JP at each +* step J +* +* (Here, J is a diagonal index) + JJ = J + JP = IPIV( J ) + IF( JP.LT.0 ) THEN + JP = -JP +* (Here, J is a diagonal index) + J = J - 1 + END IF +* (NOTE: Here, J is used to determine row length. Length J +* of the rows to swap back doesn't include diagonal element) J = J - 1 - END IF - J = J - 1 - IF( JP.NE.JJ .AND. J.GE.1 ) - $ CALL CSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA ) - IF( J.GE.1 ) + IF( JP.NE.JJ .AND. J.GE.1 ) + $ CALL CSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA ) + IF( J.GT.1 ) $ GO TO 120 * * Set KB to the number of columns factorized diff --git a/lapack-netlib/SRC/clasyf_rook.f b/lapack-netlib/SRC/clasyf_rook.f new file mode 100644 index 000000000..b83f54188 --- /dev/null +++ b/lapack-netlib/SRC/clasyf_rook.f @@ -0,0 +1,900 @@ +*> \brief \b CLASYF_ROOK computes a partial factorization of a complex symmetric matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CLASYF_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), W( LDW, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLASYF_ROOK computes a partial factorization of a complex symmetric +*> matrix A using the bounded Bunch-Kaufman ("rook") diagonal +*> pivoting method. The partial factorization has the form: +*> +*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: +*> ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) +*> +*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L' +*> ( L21 I ) ( 0 A22 ) ( 0 I ) +*> +*> where the order of D is at most NB. The actual order is returned in +*> the argument KB, and is either NB or NB-1, or N if N <= NB. +*> +*> CLASYF_ROOK is an auxiliary routine called by CSYTRF_ROOK. It uses +*> blocked code (calling Level 3 BLAS) to update the submatrix +*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The maximum number of columns of the matrix A that should be +*> factored. NB should be at least 2 to allow for 2-by-2 pivot +*> blocks. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> The number of columns of A that were actually factored. +*> KB is either NB-1 or NB, or N if N <= NB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> n-by-n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading n-by-n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> On exit, A contains details of the partial factorization. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> Only the last KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> Only the first KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is COMPLEX array, dimension (LDW,NB) +*> \endverbatim +*> +*> \param[in] LDW +*> \verbatim +*> LDW is INTEGER +*> The leading dimension of the array W. LDW >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complexSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, + $ INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), W( LDW, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) + COMPLEX CONE, CZERO + PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ), + $ CZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL DONE + INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, JP1, JP2, K, KK, + $ KW, KKW, KP, KSTEP, P, II + REAL ABSAKK, ALPHA, COLMAX, ROWMAX, STEMP, SFMIN + COMPLEX D11, D12, D21, D22, R1, T, Z +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ICAMAX + REAL SLAMCH + EXTERNAL LSAME, ICAMAX, SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL CCOPY, CGEMM, CGEMV, CSCAL, CSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT, AIMAG, REAL +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function definitions .. + CABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) ) +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = SLAMCH( 'S' ) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Factorize the trailing columns of A using the upper triangle +* of A and working backwards, and compute the matrix W = U12*D +* for use in updating A11 +* +* K is the main loop index, decreasing from N in steps of 1 or 2 +* + K = N + 10 CONTINUE +* +* KW is the column of W which corresponds to column K of A +* + KW = NB + K - N +* +* Exit from loop +* + IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) + $ GO TO 30 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column KW of W and update it +* + CALL CCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 ) + IF( K.LT.N ) + $ CALL CGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), + $ LDA, W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 ) +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = CABS1( W( K, KW ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = ICAMAX( K-1, W( 1, KW ), 1 ) + COLMAX = CABS1( W( IMAX, KW ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) + ELSE +* +* ============================================================ +* +* Test for interchange +* +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* Begin pivot search loop body +* +* +* Copy column IMAX to column KW-1 of W and update it +* + CALL CCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 ) + CALL CCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, + $ W( IMAX+1, KW-1 ), 1 ) +* + IF( K.LT.N ) + $ CALL CGEMV( 'No transpose', K, N-K, -CONE, + $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW, + $ CONE, W( 1, KW-1 ), 1 ) +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + ICAMAX( K-IMAX, W( IMAX+1, KW-1 ), + $ 1 ) + ROWMAX = CABS1( W( JMAX, KW-1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = ICAMAX( IMAX-1, W( 1, KW-1 ), 1 ) + STEMP = CABS1( W( ITEMP, KW-1 ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for +* CABS1( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.(CABS1( W( IMAX, KW-1 ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column KW-1 of W to column KW of W +* + CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K-1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 12 +* + END IF +* +* ============================================================ +* + KK = K - KSTEP + 1 +* +* KKW is the column of W which corresponds to column KK of A +* + KKW = NB + KK - N +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P +* + CALL CCOPY( K-P, A( P+1, K ), 1, A( P, P+1 ), LDA ) + CALL CCOPY( P, A( 1, K ), 1, A( 1, P ), 1 ) +* +* Interchange rows K and P in last N-K+1 columns of A +* and last N-K+2 columns of W +* + CALL CSWAP( N-K+1, A( K, K ), LDA, A( P, K ), LDA ) + CALL CSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), LDW ) + END IF +* +* Updated column KP is already stored in column KKW of W +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP +* + A( KP, K ) = A( KK, K ) + CALL CCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + CALL CCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 ) +* +* Interchange rows KK and KP in last N-KK+1 columns +* of A and W +* + CALL CSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA ) + CALL CSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), + $ LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column KW of W now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* +* Store U(k) in column k of A +* + CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) + IF( K.GT.1 ) THEN + IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN + R1 = CONE / A( K, K ) + CALL CSCAL( K-1, R1, A( 1, K ), 1 ) + ELSE IF( A( K, K ).NE.CZERO ) THEN + DO 14 II = 1, K - 1 + A( II, K ) = A( II, K ) / A( K, K ) + 14 CONTINUE + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns KW and KW-1 of W now +* hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* + IF( K.GT.2 ) THEN +* +* Store U(k) and U(k-1) in columns k and k-1 of A +* + D12 = W( K-1, KW ) + D11 = W( K, KW ) / D12 + D22 = W( K-1, KW-1 ) / D12 + T = CONE / ( D11*D22-CONE ) + DO 20 J = 1, K - 2 + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D12 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D12 ) + 20 CONTINUE + END IF +* +* Copy D(k) to A +* + A( K-1, K-1 ) = W( K-1, KW-1 ) + A( K-1, K ) = W( K-1, KW ) + A( K, K ) = W( K, KW ) + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + 30 CONTINUE +* +* Update the upper triangle of A11 (= A(1:k,1:k)) as +* +* A11 := A11 - U12*D*U12**T = A11 - U12*W**T +* +* computing blocks of NB columns at a time +* + DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB + JB = MIN( NB, K-J+1 ) +* +* Update the upper triangle of the diagonal block +* + DO 40 JJ = J, J + JB - 1 + CALL CGEMV( 'No transpose', JJ-J+1, N-K, -CONE, + $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE, + $ A( J, JJ ), 1 ) + 40 CONTINUE +* +* Update the rectangular superdiagonal block +* + IF( J.GE.2 ) + $ CALL CGEMM( 'No transpose', 'Transpose', J-1, JB, + $ N-K, -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, + $ CONE, A( 1, J ), LDA ) + 50 CONTINUE +* +* Put U12 in standard form by partially undoing the interchanges +* in columns k+1:n +* + J = K + 1 + 60 CONTINUE +* + KSTEP = 1 + JP1 = 1 + JJ = J + JP2 = IPIV( J ) + IF( JP2.LT.0 ) THEN + JP2 = -JP2 + J = J + 1 + JP1 = -IPIV( J ) + KSTEP = 2 + END IF +* + J = J + 1 + IF( JP2.NE.JJ .AND. J.LE.N ) + $ CALL CSWAP( N-J+1, A( JP2, J ), LDA, A( JJ, J ), LDA ) + JJ = J - 1 + IF( JP1.NE.JJ .AND. KSTEP.EQ.2 ) + $ CALL CSWAP( N-J+1, A( JP1, J ), LDA, A( JJ, J ), LDA ) + IF( J.LE.N ) + $ GO TO 60 +* +* Set KB to the number of columns factorized +* + KB = N - K +* + ELSE +* +* Factorize the leading columns of A using the lower triangle +* of A and working forwards, and compute the matrix W = L21*D +* for use in updating A22 +* +* K is the main loop index, increasing from 1 in steps of 1 or 2 +* + K = 1 + 70 CONTINUE +* +* Exit from loop +* + IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) + $ GO TO 90 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column K of W and update it +* + CALL CCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 ) + IF( K.GT.1 ) + $ CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), + $ LDA, W( K, 1 ), LDW, CONE, W( K, K ), 1 ) +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = CABS1( W( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + ICAMAX( N-K, W( K+1, K ), 1 ) + COLMAX = CABS1( W( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) + ELSE +* +* ============================================================ +* +* Test for interchange +* +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 72 CONTINUE +* +* Begin pivot search loop body +* +* +* Copy column IMAX to column K+1 of W and update it +* + CALL CCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1) + CALL CCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, + $ W( IMAX, K+1 ), 1 ) + IF( K.GT.1 ) + $ CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, + $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW, + $ CONE, W( K, K+1 ), 1 ) +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + ICAMAX( IMAX-K, W( K, K+1 ), 1 ) + ROWMAX = CABS1( W( JMAX, K+1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + ICAMAX( N-IMAX, W( IMAX+1, K+1 ), 1) + STEMP = CABS1( W( ITEMP, K+1 ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for +* CABS1( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( CABS1( W( IMAX, K+1 ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column K+1 of W to column K of W +* + CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 72 +* + END IF +* +* ============================================================ +* + KK = K + KSTEP - 1 +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P +* + CALL CCOPY( P-K, A( K, K ), 1, A( P, K ), LDA ) + CALL CCOPY( N-P+1, A( P, K ), 1, A( P, P ), 1 ) +* +* Interchange rows K and P in first K columns of A +* and first K+1 columns of W +* + CALL CSWAP( K, A( K, 1 ), LDA, A( P, 1 ), LDA ) + CALL CSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW ) + END IF +* +* Updated column KP is already stored in column KK of W +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP +* + A( KP, K ) = A( KK, K ) + CALL CCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA ) + CALL CCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 ) +* +* Interchange rows KK and KP in first KK columns of A and W +* + CALL CSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) + CALL CSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k of W now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* +* Store L(k) in column k of A +* + CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) + IF( K.LT.N ) THEN + IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN + R1 = CONE / A( K, K ) + CALL CSCAL( N-K, R1, A( K+1, K ), 1 ) + ELSE IF( A( K, K ).NE.CZERO ) THEN + DO 74 II = K + 1, N + A( II, K ) = A( II, K ) / A( K, K ) + 74 CONTINUE + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 of W now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* + IF( K.LT.N-1 ) THEN +* +* Store L(k) and L(k+1) in columns k and k+1 of A +* + D21 = W( K+1, K ) + D11 = W( K+1, K+1 ) / D21 + D22 = W( K, K ) / D21 + T = CONE / ( D11*D22-CONE ) + DO 80 J = K + 2, N + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) + 80 CONTINUE + END IF +* +* Copy D(k) to A +* + A( K, K ) = W( K, K ) + A( K+1, K ) = W( K+1, K ) + A( K+1, K+1 ) = W( K+1, K+1 ) + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 70 +* + 90 CONTINUE +* +* Update the lower triangle of A22 (= A(k:n,k:n)) as +* +* A22 := A22 - L21*D*L21**T = A22 - L21*W**T +* +* computing blocks of NB columns at a time +* + DO 110 J = K, N, NB + JB = MIN( NB, N-J+1 ) +* +* Update the lower triangle of the diagonal block +* + DO 100 JJ = J, J + JB - 1 + CALL CGEMV( 'No transpose', J+JB-JJ, K-1, -CONE, + $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE, + $ A( JJ, JJ ), 1 ) + 100 CONTINUE +* +* Update the rectangular subdiagonal block +* + IF( J+JB.LE.N ) + $ CALL CGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, + $ K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW, + $ CONE, A( J+JB, J ), LDA ) + 110 CONTINUE +* +* Put L21 in standard form by partially undoing the interchanges +* in columns 1:k-1 +* + J = K - 1 + 120 CONTINUE +* + KSTEP = 1 + JP1 = 1 + JJ = J + JP2 = IPIV( J ) + IF( JP2.LT.0 ) THEN + JP2 = -JP2 + J = J - 1 + JP1 = -IPIV( J ) + KSTEP = 2 + END IF +* + J = J - 1 + IF( JP2.NE.JJ .AND. J.GE.1 ) + $ CALL CSWAP( J, A( JP2, 1 ), LDA, A( JJ, 1 ), LDA ) + JJ = J + 1 + IF( JP1.NE.JJ .AND. KSTEP.EQ.2 ) + $ CALL CSWAP( J, A( JP1, 1 ), LDA, A( JJ, 1 ), LDA ) + IF( J.GE.1 ) + $ GO TO 120 +* +* Set KB to the number of columns factorized +* + KB = K - 1 +* + END IF + RETURN +* +* End of CLASYF_ROOK +* + END diff --git a/lapack-netlib/SRC/cstemr.f b/lapack-netlib/SRC/cstemr.f index d3831d10f..0089343ff 100644 --- a/lapack-netlib/SRC/cstemr.f +++ b/lapack-netlib/SRC/cstemr.f @@ -311,7 +311,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup complexOTHERcomputational * @@ -329,10 +329,10 @@ $ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, $ IWORK, LIWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE @@ -408,6 +408,7 @@ WU = ZERO IIL = 0 IIU = 0 + NSPLIT = 0 IF( VALEIG ) THEN * We do not reference VL, VU in the cases RANGE = 'I','A' diff --git a/lapack-netlib/SRC/csycon_rook.f b/lapack-netlib/SRC/csycon_rook.f new file mode 100644 index 000000000..217bae176 --- /dev/null +++ b/lapack-netlib/SRC/csycon_rook.f @@ -0,0 +1,255 @@ +*> \brief \b CSYCON_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CSYCON_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, +* WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* REAL ANORM, RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSYCON_ROOK estimates the reciprocal of the condition number (in the +*> 1-norm) of a complex symmetric matrix A using the factorization +*> A = U*D*U**T or A = L*D*L**T computed by CSYTRF_ROOK. +*> +*> An estimate is obtained for norm(inv(A)), and the reciprocal of the +*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by CSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by CSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] ANORM +*> \verbatim +*> ANORM is REAL +*> The 1-norm of the original matrix A. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is REAL +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an +*> estimate of the 1-norm of inv(A) computed in this routine. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup complexSYcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> April 2012, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N + REAL ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + COMPLEX CZERO + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, KASE + REAL AINVNM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CLACN2, CSYTRS_ROOK, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( ANORM.LT.ZERO ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CSYCON_ROOK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + RCOND = ZERO + IF( N.EQ.0 ) THEN + RCOND = ONE + RETURN + ELSE IF( ANORM.LE.ZERO ) THEN + RETURN + END IF +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO 10 I = N, 1, -1 + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.CZERO ) + $ RETURN + 10 CONTINUE + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO 20 I = 1, N + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.CZERO ) + $ RETURN + 20 CONTINUE + END IF +* +* Estimate the 1-norm of the inverse. +* + KASE = 0 + 30 CONTINUE + CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN +* +* Multiply by inv(L*D*L**T) or inv(U*D*U**T). +* + CALL CSYTRS_ROOK( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO ) + GO TO 30 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM.NE.ZERO ) + $ RCOND = ( ONE / AINVNM ) / ANORM +* + RETURN +* +* End of CSYCON_ROOK +* + END diff --git a/lapack-netlib/SRC/csysv_rook.f b/lapack-netlib/SRC/csysv_rook.f new file mode 100644 index 000000000..2e613628a --- /dev/null +++ b/lapack-netlib/SRC/csysv_rook.f @@ -0,0 +1,293 @@ +*> \brief CSYSV_ROOK computes the solution to system of linear equations A * X = B for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CSYSV_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSYSV_ROOK computes the solution to a complex system of linear +*> equations +*> A * X = B, +*> where A is an N-by-N symmetric matrix and X and B are N-by-NRHS +*> matrices. +*> +*> The diagonal pivoting method is used to factor A as +*> A = U * D * U**T, if UPLO = 'U', or +*> A = L * D * L**T, if UPLO = 'L', +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and D is symmetric and block diagonal with +*> 1-by-1 and 2-by-2 diagonal blocks. +*> +*> CSYTRF_ROOK is called to compute the factorization of a complex +*> symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal +*> pivoting method. +*> +*> The factored form of A is then used to solve the system +*> of equations A * X = B by calling CSYTRS_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, the block diagonal matrix D and the +*> multipliers used to obtain the factor U or L from the +*> factorization A = U*D*U**T or A = L*D*L**T as computed by +*> CSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, +*> as determined by CSYTRF_ROOK. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= 1, and for best performance +*> LWORK >= max(1,N*NB), where NB is the optimal blocksize for +*> CSYTRF_ROOK. +*> +*> TRS will be done with Level 2 BLAS +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, so the solution could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup complexSYsolve +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> April 2012, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CSYTRF_ROOK, CSYTRS_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + CALL CSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, -1, INFO ) + LWKOPT = WORK(1) + END IF + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CSYSV_ROOK ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = U*D*U**T or A = L*D*L**T. +* + CALL CSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* +* Solve with TRS_ROOK ( Use Level 2 BLAS) +* + CALL CSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of CSYSV_ROOK +* + END diff --git a/lapack-netlib/SRC/csytf2.f b/lapack-netlib/SRC/csytf2.f index c1889f120..b7dc56f60 100644 --- a/lapack-netlib/SRC/csytf2.f +++ b/lapack-netlib/SRC/csytf2.f @@ -90,13 +90,22 @@ *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D. -*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were -*> interchanged and D(k,k) is a 1-by-1 diagonal block. -*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and -*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) -*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = -*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were -*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns +*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) +*> is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns +*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1) +*> is a 2-by-2 diagonal block. *> \endverbatim *> *> \param[out] INFO @@ -118,7 +127,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup complexSYcomputational * @@ -182,10 +191,10 @@ * ===================================================================== SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER UPLO @@ -273,7 +282,8 @@ ABSAKK = CABS1( A( K, K ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. * IF( K.GT.1 ) THEN IMAX = ICAMAX( K-1, A( 1, K ), 1 ) @@ -284,7 +294,8 @@ * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO .OR. SISNAN(ABSAKK) ) THEN * -* Column K is zero or NaN: set INFO and continue +* Column K is zero or underflow, or contains a NaN: +* set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K @@ -441,7 +452,8 @@ ABSAKK = CABS1( A( K, K ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. * IF( K.LT.N ) THEN IMAX = K + ICAMAX( N-K, A( K+1, K ), 1 ) @@ -452,7 +464,8 @@ * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO .OR. SISNAN(ABSAKK) ) THEN * -* Column K is zero or NaN: set INFO and continue +* Column K is zero or underflow, or contains a NaN: +* set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K diff --git a/lapack-netlib/SRC/csytf2_rook.f b/lapack-netlib/SRC/csytf2_rook.f new file mode 100644 index 000000000..2a80375d3 --- /dev/null +++ b/lapack-netlib/SRC/csytf2_rook.f @@ -0,0 +1,821 @@ +*> \brief \b CSYTF2_ROOK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CSYTF2_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSYTF2_ROOK computes the factorization of a complex symmetric matrix A +*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method: +*> +*> A = U*D*U**T or A = L*D*L**T +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, U**T is the transpose of U, and D is symmetric and +*> block diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the unblocked version of the algorithm, calling Level 2 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> n-by-n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading n-by-n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, the block diagonal matrix D and the multipliers used +*> to obtain the factor U or L (see below for further details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complexSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', then A = U*D*U**T, where +*> U = P(n)*U(n)* ... *P(k)U(k)* ..., +*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to +*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I v 0 ) k-s +*> U(k) = ( 0 I 0 ) s +*> ( 0 0 I ) n-k +*> k-s s n-k +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). +*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), +*> and A(k,k), and v overwrites A(1:k-2,k-1:k). +*> +*> If UPLO = 'L', then A = L*D*L**T, where +*> L = P(1)*L(1)* ... *P(k)*L(k)* ..., +*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to +*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I 0 0 ) k-1 +*> L(k) = ( 0 I 0 ) s +*> ( 0 v I ) n-k-s+1 +*> k-1 s n-k-s+1 +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). +*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), +*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> 01-01-96 - Based on modifications by +*> J. Lewis, Boeing Computer Services Company +*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville abd , USA +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) + COMPLEX CONE + PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER, DONE + INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP, + $ P, II + REAL ABSAKK, ALPHA, COLMAX, ROWMAX, STEMP, SFMIN + COMPLEX D11, D12, D21, D22, T, WK, WKM1, WKP1, Z +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ICAMAX + REAL SLAMCH + EXTERNAL LSAME, ICAMAX, SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL CSCAL, CSWAP, CSYR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT, AIMAG, REAL +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function definitions .. + CABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CSYTF2_ROOK', -INFO ) + RETURN + END IF +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = SLAMCH( 'S' ) +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2 +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 70 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = CABS1( A( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = ICAMAX( K-1, A( 1, K ), 1 ) + COLMAX = CABS1( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + ELSE +* +* Test for interchange +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABSAKK.GE.ALPHA*COLMAX +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, +* use 1-by-1 pivot block +* + KP = K + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* Begin pivot search loop body +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + ICAMAX( K-IMAX, A( IMAX, IMAX+1 ), + $ LDA ) + ROWMAX = CABS1( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = ICAMAX( IMAX-1, A( 1, IMAX ), 1 ) + STEMP = CABS1( A( ITEMP, IMAX ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for (used to handle NaN and Inf) +* CABS1( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX +* + IF( .NOT.( CABS1(A( IMAX, IMAX )).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX .EQ. COLMAX, +* used to handle NaN and Inf +* + ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot NOT found, set variables and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 12 +* + END IF +* +* Swap TWO rows and TWO columns +* +* First swap +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Interchange rows and column K and P in the leading +* submatrix A(1:k,1:k) if we have a 2-by-2 pivot +* + IF( P.GT.1 ) + $ CALL CSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 ) + IF( P.LT.(K-1) ) + $ CALL CSWAP( K-P-1, A( P+1, K ), 1, A( P, P+1 ), + $ LDA ) + T = A( K, K ) + A( K, K ) = A( P, P ) + A( P, P ) = T + END IF +* +* Second swap +* + KK = K - KSTEP + 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the leading +* submatrix A(1:k,1:k) +* + IF( KP.GT.1 ) + $ CALL CSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) + IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) ) + $ CALL CSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K-1, K ) + A( K-1, K ) = A( KP, K ) + A( KP, K ) = T + END IF + END IF +* +* Update the leading submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* + IF( K.GT.1 ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) and +* store U(k) in column k +* + IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*1/D(k)*W(k)**T +* + D11 = CONE / A( K, K ) + CALL CSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) +* +* Store U(k) in column k +* + CALL CSCAL( K-1, D11, A( 1, K ), 1 ) + ELSE +* +* Store L(k) in column K +* + D11 = A( K, K ) + DO 16 II = 1, K - 1 + A( II, K ) = A( II, K ) / D11 + 16 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL CSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k-1 now hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* +* Perform a rank-2 update of A(1:k-2,1:k-2) as +* +* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T +* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.GT.2 ) THEN +* + D12 = A( K-1, K ) + D22 = A( K-1, K-1 ) / D12 + D11 = A( K, K ) / D12 + T = CONE / ( D11*D22-CONE ) +* + DO 30 J = K - 2, 1, -1 +* + WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) + WK = T*( D22*A( J, K )-A( J, K-1 ) ) +* + DO 20 I = J, 1, -1 + A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - + $ ( A( I, K-1 ) / D12 )*WKM1 + 20 CONTINUE +* +* Store U(k) and U(k-1) in cols k and k-1 for row J +* + A( J, K ) = WK / D12 + A( J, K-1 ) = WKM1 / D12 +* + 30 CONTINUE +* + END IF +* + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2 +* + K = 1 + 40 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 70 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = CABS1( A( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + ICAMAX( N-K, A( K+1, K ), 1 ) + COLMAX = CABS1( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + ELSE +* +* Test for interchange +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABSAKK.GE.ALPHA*COLMAX +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 42 CONTINUE +* +* Begin pivot search loop body +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + ICAMAX( IMAX-K, A( IMAX, K ), LDA ) + ROWMAX = CABS1( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + ICAMAX( N-IMAX, A( IMAX+1, IMAX ), + $ 1 ) + STEMP = CABS1( A( ITEMP, IMAX ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for (used to handle NaN and Inf) +* CABS1( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX +* + IF( .NOT.( CABS1(A( IMAX, IMAX )).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX .EQ. COLMAX, +* used to handle NaN and Inf +* + ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot NOT found, set variables and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 42 +* + END IF +* +* Swap TWO rows and TWO columns +* +* First swap +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Interchange rows and column K and P in the trailing +* submatrix A(k:n,k:n) if we have a 2-by-2 pivot +* + IF( P.LT.N ) + $ CALL CSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) + IF( P.GT.(K+1) ) + $ CALL CSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA ) + T = A( K, K ) + A( K, K ) = A( P, P ) + A( P, P ) = T + END IF +* +* Second swap +* + KK = K + KSTEP - 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the trailing +* submatrix A(k:n,k:n) +* + IF( KP.LT.N ) + $ CALL CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) ) + $ CALL CSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K+1, K ) + A( K+1, K ) = A( KP, K ) + A( KP, K ) = T + END IF + END IF +* +* Update the trailing submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* + IF( K.LT.N ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) and +* store L(k) in column k +* + IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* + D11 = CONE / A( K, K ) + CALL CSYR( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) +* +* Store L(k) in column k +* + CALL CSCAL( N-K, D11, A( K+1, K ), 1 ) + ELSE +* +* Store L(k) in column k +* + D11 = A( K, K ) + DO 46 II = K + 1, N + A( II, K ) = A( II, K ) / D11 + 46 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL CSYR( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* +* +* Perform a rank-2 update of A(k+2:n,k+2:n) as +* +* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T +* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.LT.N-1 ) THEN +* + D21 = A( K+1, K ) + D11 = A( K+1, K+1 ) / D21 + D22 = A( K, K ) / D21 + T = CONE / ( D11*D22-CONE ) +* + DO 60 J = K + 2, N +* +* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* + WK = T*( D11*A( J, K )-A( J, K+1 ) ) + WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) +* +* Perform a rank-2 update of A(k+2:n,k+2:n) +* + DO 50 I = J, N + A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - + $ ( A( I, K+1 ) / D21 )*WKP1 + 50 CONTINUE +* +* Store L(k) and L(k+1) in cols k and k+1 for row J +* + A( J, K ) = WK / D21 + A( J, K+1 ) = WKP1 / D21 +* + 60 CONTINUE +* + END IF +* + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 40 +* + END IF +* + 70 CONTINUE +* + RETURN +* +* End of CSYTF2_ROOK +* + END diff --git a/lapack-netlib/SRC/csytrf_rook.f b/lapack-netlib/SRC/csytrf_rook.f new file mode 100644 index 000000000..d4169d744 --- /dev/null +++ b/lapack-netlib/SRC/csytrf_rook.f @@ -0,0 +1,393 @@ +*> \brief \b CSYTRF_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CSYTRF_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSYTRF_ROOK computes the factorization of a complex symmetric matrix A +*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. +*> The form of the factorization is +*> +*> A = U*D*U**T or A = L*D*L**T +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and D is symmetric and block diagonal with +*> 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, the block diagonal matrix D and the multipliers used +*> to obtain the factor U or L (see below for further details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (MAX(1,LWORK)). +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >=1. For best performance +*> LWORK >= N*NB, where NB is the block size returned by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup complexSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', then A = U*D*U**T, where +*> U = P(n)*U(n)* ... *P(k)U(k)* ..., +*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to +*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I v 0 ) k-s +*> U(k) = ( 0 I 0 ) s +*> ( 0 0 I ) n-k +*> k-s s n-k +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). +*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), +*> and A(k,k), and v overwrites A(1:k-2,k-1:k). +*> +*> If UPLO = 'L', then A = L*D*L**T, where +*> L = P(1)*L(1)* ... *P(k)*L(k)* ..., +*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to +*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I 0 0 ) k-1 +*> L(k) = ( 0 I 0 ) s +*> ( 0 v I ) n-k-s+1 +*> k-1 s n-k-s+1 +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). +*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), +*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2011, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL CLASYF_ROOK, CSYTF2_ROOK, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size +* + NB = ILAENV( 1, 'CSYTRF_ROOK', UPLO, N, -1, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CSYTRF_ROOK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* + NBMIN = 2 + LDWORK = N + IF( NB.GT.1 .AND. NB.LT.N ) THEN + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN + NB = MAX( LWORK / LDWORK, 1 ) + NBMIN = MAX( 2, ILAENV( 2, 'CSYTRF_ROOK', + $ UPLO, N, -1, -1, -1 ) ) + END IF + ELSE + IWS = 1 + END IF + IF( NB.LT.NBMIN ) + $ NB = N +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* KB, where KB is the number of columns factorized by CLASYF_ROOK; +* KB is either NB or NB-1, or K for the last block +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 40 +* + IF( K.GT.NB ) THEN +* +* Factorize columns k-kb+1:k of A and use blocked code to +* update columns 1:k-kb +* + CALL CLASYF_ROOK( UPLO, K, NB, KB, A, LDA, + $ IPIV, WORK, LDWORK, IINFO ) + ELSE +* +* Use unblocked code to factorize columns 1:k of A +* + CALL CSYTF2_ROOK( UPLO, K, A, LDA, IPIV, IINFO ) + KB = K + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO +* +* No need to adjust IPIV +* +* Decrease K and return to the start of the main loop +* + K = K - KB + GO TO 10 +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* KB, where KB is the number of columns factorized by CLASYF_ROOK; +* KB is either NB or NB-1, or N-K+1 for the last block +* + K = 1 + 20 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 40 +* + IF( K.LE.N-NB ) THEN +* +* Factorize columns k:k+kb-1 of A and use blocked code to +* update columns k+kb:n +* + CALL CLASYF_ROOK( UPLO, N-K+1, NB, KB, A( K, K ), LDA, + $ IPIV( K ), WORK, LDWORK, IINFO ) + ELSE +* +* Use unblocked code to factorize columns k:n of A +* + CALL CSYTF2_ROOK( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), + $ IINFO ) + KB = N - K + 1 + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + K - 1 +* +* Adjust IPIV +* + DO 30 J = K, K + KB - 1 + IF( IPIV( J ).GT.0 ) THEN + IPIV( J ) = IPIV( J ) + K - 1 + ELSE + IPIV( J ) = IPIV( J ) - K + 1 + END IF + 30 CONTINUE +* +* Increase K and return to the start of the main loop +* + K = K + KB + GO TO 20 +* + END IF +* + 40 CONTINUE + WORK( 1 ) = LWKOPT + RETURN +* +* End of CSYTRF_ROOK +* + END diff --git a/lapack-netlib/SRC/csytri_rook.f b/lapack-netlib/SRC/csytri_rook.f new file mode 100644 index 000000000..0b57a713c --- /dev/null +++ b/lapack-netlib/SRC/csytri_rook.f @@ -0,0 +1,451 @@ +*> \brief \b CSYTRI_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CSYTRI_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSYTRI_ROOK computes the inverse of a complex symmetric +*> matrix A using the factorization A = U*D*U**T or A = L*D*L**T +*> computed by CSYTRF_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> On entry, the block diagonal matrix D and the multipliers +*> used to obtain the factor U or L as computed by CSYTRF_ROOK. +*> +*> On exit, if INFO = 0, the (symmetric) inverse of the original +*> matrix. If UPLO = 'U', the upper triangular part of the +*> inverse is formed and the part of A below the diagonal is not +*> referenced; if UPLO = 'L' the lower triangular part of the +*> inverse is formed and the part of A above the diagonal is +*> not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by CSYTRF_ROOK. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup complexSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2011, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX CONE, CZERO + PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ), + $ CZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER K, KP, KSTEP + COMPLEX AK, AKKP1, AKP1, D, T, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME + COMPLEX CDOTU + EXTERNAL LSAME, CDOTU +* .. +* .. External Subroutines .. + EXTERNAL CCOPY, CSWAP, CSYMV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CSYTRI_ROOK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO 10 INFO = N, 1, -1 + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO ) + $ RETURN + 10 CONTINUE + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO 20 INFO = 1, N + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO ) + $ RETURN + 20 CONTINUE + END IF + INFO = 0 +* + IF( UPPER ) THEN +* +* Compute inv(A) from the factorization A = U*D*U**T. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + 30 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 40 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Invert the diagonal block. +* + A( K, K ) = CONE / A( K, K ) +* +* Compute column K of the inverse. +* + IF( K.GT.1 ) THEN + CALL CCOPY( K-1, A( 1, K ), 1, WORK, 1 ) + CALL CSYMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO, + $ A( 1, K ), 1 ) + A( K, K ) = A( K, K ) - CDOTU( K-1, WORK, 1, A( 1, K ), + $ 1 ) + END IF + KSTEP = 1 + ELSE +* +* 2 x 2 diagonal block +* +* Invert the diagonal block. +* + T = A( K, K+1 ) + AK = A( K, K ) / T + AKP1 = A( K+1, K+1 ) / T + AKKP1 = A( K, K+1 ) / T + D = T*( AK*AKP1-CONE ) + A( K, K ) = AKP1 / D + A( K+1, K+1 ) = AK / D + A( K, K+1 ) = -AKKP1 / D +* +* Compute columns K and K+1 of the inverse. +* + IF( K.GT.1 ) THEN + CALL CCOPY( K-1, A( 1, K ), 1, WORK, 1 ) + CALL CSYMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO, + $ A( 1, K ), 1 ) + A( K, K ) = A( K, K ) - CDOTU( K-1, WORK, 1, A( 1, K ), + $ 1 ) + A( K, K+1 ) = A( K, K+1 ) - + $ CDOTU( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 ) + CALL CCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 ) + CALL CSYMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO, + $ A( 1, K+1 ), 1 ) + A( K+1, K+1 ) = A( K+1, K+1 ) - + $ CDOTU( K-1, WORK, 1, A( 1, K+1 ), 1 ) + END IF + KSTEP = 2 + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* Interchange rows and columns K and IPIV(K) in the leading +* submatrix A(1:k+1,1:k+1) +* + KP = IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.GT.1 ) + $ CALL CSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) + CALL CSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + ELSE +* +* Interchange rows and columns K and K+1 with -IPIV(K) and +* -IPIV(K+1)in the leading submatrix A(1:k+1,1:k+1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.GT.1 ) + $ CALL CSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) + CALL CSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) +* + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + TEMP = A( K, K+1 ) + A( K, K+1 ) = A( KP, K+1 ) + A( KP, K+1 ) = TEMP + END IF +* + K = K + 1 + KP = -IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.GT.1 ) + $ CALL CSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) + CALL CSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + END IF +* + K = K + 1 + GO TO 30 + 40 CONTINUE +* + ELSE +* +* Compute inv(A) from the factorization A = L*D*L**T. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = N + 50 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 60 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Invert the diagonal block. +* + A( K, K ) = CONE / A( K, K ) +* +* Compute column K of the inverse. +* + IF( K.LT.N ) THEN + CALL CCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) + CALL CSYMV( UPLO, N-K,-CONE, A( K+1, K+1 ), LDA, WORK, 1, + $ CZERO, A( K+1, K ), 1 ) + A( K, K ) = A( K, K ) - CDOTU( N-K, WORK, 1, A( K+1, K ), + $ 1 ) + END IF + KSTEP = 1 + ELSE +* +* 2 x 2 diagonal block +* +* Invert the diagonal block. +* + T = A( K, K-1 ) + AK = A( K-1, K-1 ) / T + AKP1 = A( K, K ) / T + AKKP1 = A( K, K-1 ) / T + D = T*( AK*AKP1-CONE ) + A( K-1, K-1 ) = AKP1 / D + A( K, K ) = AK / D + A( K, K-1 ) = -AKKP1 / D +* +* Compute columns K-1 and K of the inverse. +* + IF( K.LT.N ) THEN + CALL CCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) + CALL CSYMV( UPLO, N-K,-CONE, A( K+1, K+1 ), LDA, WORK, 1, + $ CZERO, A( K+1, K ), 1 ) + A( K, K ) = A( K, K ) - CDOTU( N-K, WORK, 1, A( K+1, K ), + $ 1 ) + A( K, K-1 ) = A( K, K-1 ) - + $ CDOTU( N-K, A( K+1, K ), 1, A( K+1, K-1 ), + $ 1 ) + CALL CCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 ) + CALL CSYMV( UPLO, N-K,-CONE, A( K+1, K+1 ), LDA, WORK, 1, + $ CZERO, A( K+1, K-1 ), 1 ) + A( K-1, K-1 ) = A( K-1, K-1 ) - + $ CDOTU( N-K, WORK, 1, A( K+1, K-1 ), 1 ) + END IF + KSTEP = 2 + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* Interchange rows and columns K and IPIV(K) in the trailing +* submatrix A(k-1:n,k-1:n) +* + KP = IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.LT.N ) + $ CALL CSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) + CALL CSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA ) + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + ELSE +* +* Interchange rows and columns K and K-1 with -IPIV(K) and +* -IPIV(K-1) in the trailing submatrix A(k-1:n,k-1:n) +* + KP = -IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.LT.N ) + $ CALL CSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) + CALL CSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA ) +* + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + TEMP = A( K, K-1 ) + A( K, K-1 ) = A( KP, K-1 ) + A( KP, K-1 ) = TEMP + END IF +* + K = K - 1 + KP = -IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.LT.N ) + $ CALL CSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) + CALL CSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA ) + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + END IF +* + K = K - 1 + GO TO 50 + 60 CONTINUE + END IF +* + RETURN +* +* End of CSYTRI_ROOK +* + END diff --git a/lapack-netlib/SRC/csytrs_rook.f b/lapack-netlib/SRC/csytrs_rook.f new file mode 100644 index 000000000..44727212c --- /dev/null +++ b/lapack-netlib/SRC/csytrs_rook.f @@ -0,0 +1,484 @@ +*> \brief \b CSYTRS_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CSYTRS_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSYTRS_ROOK solves a system of linear equations A*X = B with +*> a complex symmetric matrix A using the factorization A = U*D*U**T or +*> A = L*D*L**T computed by CSYTRF_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by CSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by CSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup complexSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2011, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE CSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + $ INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX CONE + PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J, K, KP + COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CGEMV, CGERU, CSCAL, CSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CSYTRS_ROOK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Solve A*X = B, where A = U*D*U**T. +* +* First solve U*D*X = B, overwriting B with X. +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 30 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(U(K)), where U(K) is the transformation +* stored in column K of A. +* + CALL CGERU( K-1, NRHS, -CONE, A( 1, K ), 1, B( K, 1 ), LDB, + $ B( 1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + CALL CSCAL( NRHS, CONE / A( K, K ), B( K, 1 ), LDB ) + K = K - 1 + ELSE +* +* 2 x 2 diagonal block +* +* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K-1 ) + IF( KP.NE.K-1 ) + $ CALL CSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(U(K)), where U(K) is the transformation +* stored in columns K-1 and K of A. +* + IF( K.GT.2 ) THEN + CALL CGERU( K-2, NRHS,-CONE, A( 1, K ), 1, B( K, 1 ), + $ LDB, B( 1, 1 ), LDB ) + CALL CGERU( K-2, NRHS,-CONE, A( 1, K-1 ), 1, B( K-1, 1 ), + $ LDB, B( 1, 1 ), LDB ) + END IF +* +* Multiply by the inverse of the diagonal block. +* + AKM1K = A( K-1, K ) + AKM1 = A( K-1, K-1 ) / AKM1K + AK = A( K, K ) / AKM1K + DENOM = AKM1*AK - CONE + DO 20 J = 1, NRHS + BKM1 = B( K-1, J ) / AKM1K + BK = B( K, J ) / AKM1K + B( K-1, J ) = ( AK*BKM1-BK ) / DENOM + B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM + 20 CONTINUE + K = K - 2 + END IF +* + GO TO 10 + 30 CONTINUE +* +* Next solve U**T *X = B, overwriting B with X. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + 40 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 50 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Multiply by inv(U**T(K)), where U(K) is the transformation +* stored in column K of A. +* + IF( K.GT.1 ) + $ CALL CGEMV( 'Transpose', K-1, NRHS, -CONE, B, + $ LDB, A( 1, K ), 1, CONE, B( K, 1 ), LDB ) +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K + 1 + ELSE +* +* 2 x 2 diagonal block +* +* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation +* stored in columns K and K+1 of A. +* + IF( K.GT.1 ) THEN + CALL CGEMV( 'Transpose', K-1, NRHS, -CONE, B, + $ LDB, A( 1, K ), 1, CONE, B( K, 1 ), LDB ) + CALL CGEMV( 'Transpose', K-1, NRHS, -CONE, B, + $ LDB, A( 1, K+1 ), 1, CONE, B( K+1, 1 ), LDB ) + END IF +* +* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1). +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K+1 ) + IF( KP.NE.K+1 ) + $ CALL CSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) +* + K = K + 2 + END IF +* + GO TO 40 + 50 CONTINUE +* + ELSE +* +* Solve A*X = B, where A = L*D*L**T. +* +* First solve L*D*X = B, overwriting B with X. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + 60 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 80 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(L(K)), where L(K) is the transformation +* stored in column K of A. +* + IF( K.LT.N ) + $ CALL CGERU( N-K, NRHS, -CONE, A( K+1, K ), 1, B( K, 1 ), + $ LDB, B( K+1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + CALL CSCAL( NRHS, CONE / A( K, K ), B( K, 1 ), LDB ) + K = K + 1 + ELSE +* +* 2 x 2 diagonal block +* +* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K+1 ) + IF( KP.NE.K+1 ) + $ CALL CSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(L(K)), where L(K) is the transformation +* stored in columns K and K+1 of A. +* + IF( K.LT.N-1 ) THEN + CALL CGERU( N-K-1, NRHS,-CONE, A( K+2, K ), 1, B( K, 1 ), + $ LDB, B( K+2, 1 ), LDB ) + CALL CGERU( N-K-1, NRHS,-CONE, A( K+2, K+1 ), 1, + $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) + END IF +* +* Multiply by the inverse of the diagonal block. +* + AKM1K = A( K+1, K ) + AKM1 = A( K, K ) / AKM1K + AK = A( K+1, K+1 ) / AKM1K + DENOM = AKM1*AK - CONE + DO 70 J = 1, NRHS + BKM1 = B( K, J ) / AKM1K + BK = B( K+1, J ) / AKM1K + B( K, J ) = ( AK*BKM1-BK ) / DENOM + B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM + 70 CONTINUE + K = K + 2 + END IF +* + GO TO 60 + 80 CONTINUE +* +* Next solve L**T *X = B, overwriting B with X. +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = N + 90 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 100 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Multiply by inv(L**T(K)), where L(K) is the transformation +* stored in column K of A. +* + IF( K.LT.N ) + $ CALL CGEMV( 'Transpose', N-K, NRHS, -CONE, B( K+1, 1 ), + $ LDB, A( K+1, K ), 1, CONE, B( K, 1 ), LDB ) +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K - 1 + ELSE +* +* 2 x 2 diagonal block +* +* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation +* stored in columns K-1 and K of A. +* + IF( K.LT.N ) THEN + CALL CGEMV( 'Transpose', N-K, NRHS, -CONE, B( K+1, 1 ), + $ LDB, A( K+1, K ), 1, CONE, B( K, 1 ), LDB ) + CALL CGEMV( 'Transpose', N-K, NRHS, -CONE, B( K+1, 1 ), + $ LDB, A( K+1, K-1 ), 1, CONE, B( K-1, 1 ), + $ LDB ) + END IF +* +* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K-1 ) + IF( KP.NE.K-1 ) + $ CALL CSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) +* + K = K - 2 + END IF +* + GO TO 90 + 100 CONTINUE + END IF +* + RETURN +* +* End of CSYTRS_ROOK +* + END diff --git a/lapack-netlib/SRC/ctpmqrt.f b/lapack-netlib/SRC/ctpmqrt.f index abfdae87c..08929b226 100644 --- a/lapack-netlib/SRC/ctpmqrt.f +++ b/lapack-netlib/SRC/ctpmqrt.f @@ -175,7 +175,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup complexOTHERcomputational * @@ -216,10 +216,10 @@ SUBROUTINE CTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, $ A, LDA, B, LDB, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -235,7 +235,7 @@ * .. * .. Local Scalars .. LOGICAL LEFT, RIGHT, TRAN, NOTRAN - INTEGER I, IB, MB, LB, KF, Q + INTEGER I, IB, MB, LB, KF, LDAQ, LDVQ * .. * .. External Functions .. LOGICAL LSAME @@ -257,10 +257,12 @@ TRAN = LSAME( TRANS, 'C' ) NOTRAN = LSAME( TRANS, 'N' ) * - IF( LEFT ) THEN - Q = M + IF ( LEFT ) THEN + LDVQ = MAX( 1, M ) + LDAQ = MAX( 1, K ) ELSE IF ( RIGHT ) THEN - Q = N + LDVQ = MAX( 1, N ) + LDAQ = MAX( 1, M ) END IF IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN INFO = -1 @@ -274,13 +276,13 @@ INFO = -5 ELSE IF( L.LT.0 .OR. L.GT.K ) THEN INFO = -6 - ELSE IF( NB.LT.1 .OR. NB.GT.K ) THEN + ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0) ) THEN INFO = -7 - ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN + ELSE IF( LDV.LT.LDVQ ) THEN INFO = -9 ELSE IF( LDT.LT.NB ) THEN INFO = -11 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + ELSE IF( LDA.LT.LDAQ ) THEN INFO = -13 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -15 diff --git a/lapack-netlib/SRC/ctpqrt.f b/lapack-netlib/SRC/ctpqrt.f index f29ddf979..4dc173f0b 100644 --- a/lapack-netlib/SRC/ctpqrt.f +++ b/lapack-netlib/SRC/ctpqrt.f @@ -132,7 +132,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup complexOTHERcomputational * @@ -189,10 +189,10 @@ SUBROUTINE CTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDT, N, M, L, NB @@ -219,9 +219,9 @@ INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 - ELSE IF( L.LT.0 .OR. L.GT.MIN(M,N) ) THEN + ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN INFO = -3 - ELSE IF( NB.LT.1 .OR. NB.GT.N ) THEN + ELSE IF( NB.LT.1 .OR. (NB.GT.N .AND. N.GT.0)) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 diff --git a/lapack-netlib/SRC/cunbdb.f b/lapack-netlib/SRC/cunbdb.f index 248070a16..36c52d18f 100644 --- a/lapack-netlib/SRC/cunbdb.f +++ b/lapack-netlib/SRC/cunbdb.f @@ -255,7 +255,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complexOTHERcomputational * @@ -287,10 +287,10 @@ $ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, $ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER SIGNS, TRANS @@ -420,19 +420,33 @@ THETA(I) = ATAN2( SCNRM2( M-P-I+1, X21(I,I), 1 ), $ SCNRM2( P-I+1, X11(I,I), 1 ) ) * - CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + IF( P .GT. I ) THEN + CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + ELSE IF ( P .EQ. I ) THEN + CALL CLARFGP( P-I+1, X11(I,I), X11(I,I), 1, TAUP1(I) ) + END IF X11(I,I) = ONE - CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + IF ( M-P .GT. I ) THEN + CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, + $ TAUP2(I) ) + ELSE IF ( M-P .EQ. I ) THEN + CALL CLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1, + $ TAUP2(I) ) + END IF X21(I,I) = ONE * - CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)), - $ X11(I,I+1), LDX11, WORK ) - CALL CLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, - $ CONJG(TAUP1(I)), X12(I,I), LDX12, WORK ) - CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)), - $ X21(I,I+1), LDX21, WORK ) - CALL CLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, - $ CONJG(TAUP2(I)), X22(I,I), LDX22, WORK ) + IF ( Q .GT. I ) THEN + CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, + $ CONJG(TAUP1(I)), X11(I,I+1), LDX11, WORK ) + CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, + $ CONJG(TAUP2(I)), X21(I,I+1), LDX21, WORK ) + END IF + IF ( M-Q+1 .GT. I ) THEN + CALL CLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, + $ CONJG(TAUP1(I)), X12(I,I), LDX12, WORK ) + CALL CLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, + $ CONJG(TAUP2(I)), X22(I,I), LDX22, WORK ) + END IF * IF( I .LT. Q ) THEN CALL CSCAL( Q-I, CMPLX( -Z1*Z3*SIN(THETA(I)), 0.0E0 ), @@ -451,13 +465,25 @@ * IF( I .LT. Q ) THEN CALL CLACGV( Q-I, X11(I,I+1), LDX11 ) - CALL CLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11, - $ TAUQ1(I) ) + IF ( I .EQ. Q-1 ) THEN + CALL CLARFGP( Q-I, X11(I,I+1), X11(I,I+1), LDX11, + $ TAUQ1(I) ) + ELSE + CALL CLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11, + $ TAUQ1(I) ) + END IF X11(I,I+1) = ONE END IF - CALL CLACGV( M-Q-I+1, X12(I,I), LDX12 ) - CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, - $ TAUQ2(I) ) + IF ( M-Q+1 .GT. I ) THEN + CALL CLACGV( M-Q-I+1, X12(I,I), LDX12 ) + IF ( M-Q .EQ. I ) THEN + CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12, + $ TAUQ2(I) ) + ELSE + CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, + $ TAUQ2(I) ) + END IF + END IF X12(I,I) = ONE * IF( I .LT. Q ) THEN @@ -466,10 +492,14 @@ CALL CLARF( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I), $ X21(I+1,I+1), LDX21, WORK ) END IF - CALL CLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), - $ X12(I+1,I), LDX12, WORK ) - CALL CLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), - $ X22(I+1,I), LDX22, WORK ) + IF ( P .GT. I ) THEN + CALL CLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), + $ X12(I+1,I), LDX12, WORK ) + END IF + IF ( M-P .GT. I ) THEN + CALL CLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), X22(I+1,I), LDX22, WORK ) + END IF * IF( I .LT. Q ) $ CALL CLACGV( Q-I, X11(I,I+1), LDX11 ) @@ -484,12 +514,19 @@ CALL CSCAL( M-Q-I+1, CMPLX( -Z1*Z4, 0.0E0 ), X12(I,I), $ LDX12 ) CALL CLACGV( M-Q-I+1, X12(I,I), LDX12 ) - CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, - $ TAUQ2(I) ) + IF ( I .GE. M-Q ) THEN + CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12, + $ TAUQ2(I) ) + ELSE + CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, + $ TAUQ2(I) ) + END IF X12(I,I) = ONE * - CALL CLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), - $ X12(I+1,I), LDX12, WORK ) + IF ( P .GT. I ) THEN + CALL CLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), + $ X12(I+1,I), LDX12, WORK ) + END IF IF( M-P-Q .GE. 1 ) $ CALL CLARF( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12, $ TAUQ2(I), X22(Q+1,I), LDX22, WORK ) @@ -548,8 +585,13 @@ * CALL CLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, TAUP1(I) ) X11(I,I) = ONE - CALL CLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21, - $ TAUP2(I) ) + IF ( I .EQ. M-P ) THEN + CALL CLARFGP( M-P-I+1, X21(I,I), X21(I,I), LDX21, + $ TAUP2(I) ) + ELSE + CALL CLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21, + $ TAUP2(I) ) + END IF X21(I,I) = ONE * CALL CLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I), @@ -594,9 +636,11 @@ END IF CALL CLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, CONJG(TAUQ2(I)), $ X12(I,I+1), LDX12, WORK ) - CALL CLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, - $ CONJG(TAUQ2(I)), X22(I,I+1), LDX22, WORK ) -* + + IF ( M-P .GT. I ) THEN + CALL CLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, + $ CONJG(TAUQ2(I)), X22(I,I+1), LDX22, WORK ) + END IF END DO * * Reduce columns Q + 1, ..., P of X12, X22 @@ -607,8 +651,10 @@ CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) ) X12(I,I) = ONE * - CALL CLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, CONJG(TAUQ2(I)), - $ X12(I,I+1), LDX12, WORK ) + IF ( P .GT. I ) THEN + CALL CLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, + $ CONJG(TAUQ2(I)), X12(I,I+1), LDX12, WORK ) + END IF IF( M-P-Q .GE. 1 ) $ CALL CLARF( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1, $ CONJG(TAUQ2(I)), X22(I,Q+1), LDX22, WORK ) @@ -624,10 +670,11 @@ CALL CLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), 1, $ TAUQ2(P+I) ) X22(P+I,Q+I) = ONE -* - CALL CLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1, - $ CONJG(TAUQ2(P+I)), X22(P+I,Q+I+1), LDX22, WORK ) -* + IF ( M-P-Q .NE. I ) THEN + CALL CLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1, + $ CONJG(TAUQ2(P+I)), X22(P+I,Q+I+1), LDX22, + $ WORK ) + END IF END DO * END IF diff --git a/lapack-netlib/SRC/cunbdb1.f b/lapack-netlib/SRC/cunbdb1.f new file mode 100644 index 000000000..fea26b21a --- /dev/null +++ b/lapack-netlib/SRC/cunbdb1.f @@ -0,0 +1,327 @@ +*> \brief \b CUNBDB1 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CUNBDB1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* REAL PHI(*), THETA(*) +* COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> CUNBDB1 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonomal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. Q must be no larger than P, +*> M-P, or M-Q. Routines CUNBDB2, CUNBDB3, and CUNBDB4 handle cases in +*> which Q is not the minimum dimension. +*> +*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are Q-by-Q bidiagonal matrices represented implicitly by +*> angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= +*> MIN(P,M-P,M-Q). +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is COMPLEX array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is COMPLEX array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is REAL array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is REAL array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is COMPLEX array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is COMPLEX array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is COMPLEX array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup complexOTHERcomputational +* +*> \par Further Details: +* ===================== + +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or CUNCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR +*> and CUNGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + REAL PHI(*), THETA(*) + COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + COMPLEX ONE + PARAMETER ( ONE = (1.0E0,0.0E0) ) +* .. +* .. Local Scalars .. + REAL C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, + $ LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, XERBLA + EXTERNAL CLACGV +* .. +* .. External Functions .. + REAL SCNRM2 + EXTERNAL SCNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( P .LT. Q .OR. M-P .LT. Q ) THEN + INFO = -2 + ELSE IF( Q .LT. 0 .OR. M-Q .LT. Q ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( P-1, M-P-1, Q-1 ) + IORBDB5 = 2 + LORBDB5 = Q-2 + LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'CUNBDB1', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce columns 1, ..., Q of X11 and X21 +* + DO I = 1, Q +* + CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + THETA(I) = ATAN2( REAL( X21(I,I) ), REAL( X11(I,I) ) ) + C = COS( THETA(I) ) + S = SIN( THETA(I) ) + X11(I,I) = ONE + X21(I,I) = ONE + CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)), + $ X11(I,I+1), LDX11, WORK(ILARF) ) + CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)), + $ X21(I,I+1), LDX21, WORK(ILARF) ) +* + IF( I .LT. Q ) THEN + CALL CSROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C, + $ S ) + CALL CLACGV( Q-I, X21(I,I+1), LDX21 ) + CALL CLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, TAUQ1(I) ) + S = REAL( X21(I,I+1) ) + X21(I,I+1) = ONE + CALL CLARF( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), + $ X11(I+1,I+1), LDX11, WORK(ILARF) ) + CALL CLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), + $ X21(I+1,I+1), LDX21, WORK(ILARF) ) + CALL CLACGV( Q-I, X21(I,I+1), LDX21 ) + C = SQRT( SCNRM2( P-I, X11(I+1,I+1), 1, X11(I+1,I+1), + $ 1 )**2 + SCNRM2( M-P-I, X21(I+1,I+1), 1, X21(I+1,I+1), + $ 1 )**2 ) + PHI(I) = ATAN2( S, C ) + CALL CUNBDB5( P-I, M-P-I, Q-I-1, X11(I+1,I+1), 1, + $ X21(I+1,I+1), 1, X11(I+1,I+2), LDX11, + $ X21(I+1,I+2), LDX21, WORK(IORBDB5), LORBDB5, + $ CHILDINFO ) + END IF +* + END DO +* + RETURN +* +* End of CUNBDB1 +* + END + diff --git a/lapack-netlib/SRC/cunbdb2.f b/lapack-netlib/SRC/cunbdb2.f new file mode 100644 index 000000000..cec00f93c --- /dev/null +++ b/lapack-netlib/SRC/cunbdb2.f @@ -0,0 +1,337 @@ +*> \brief \b CUNBDB2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CUNBDB2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* REAL PHI(*), THETA(*) +* COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> CUNBDB2 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonomal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. P must be no larger than M-P, +*> Q, or M-Q. Routines CUNBDB1, CUNBDB3, and CUNBDB4 handle cases in +*> which P is not the minimum dimension. +*> +*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are P-by-P bidiagonal matrices represented implicitly by +*> angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= min(M-P,Q,M-Q). +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M. +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is COMPLEX array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is COMPLEX array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is REAL array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is REAL array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is COMPLEX array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is COMPLEX array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is COMPLEX array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +*> +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup complexOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or CUNCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR +*> and CUNGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + REAL PHI(*), THETA(*) + COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + COMPLEX NEGONE, ONE + PARAMETER ( NEGONE = (-1.0E0,0.0E0), + $ ONE = (1.0E0,0.0E0) ) +* .. +* .. Local Scalars .. + REAL C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, + $ LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, CSCAL, XERBLA +* .. +* .. External Functions .. + REAL SCNRM2 + EXTERNAL SCNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( P .LT. 0 .OR. P .GT. M-P ) THEN + INFO = -2 + ELSE IF( Q .LT. 0 .OR. Q .LT. P .OR. M-Q .LT. P ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( P-1, M-P, Q-1 ) + IORBDB5 = 2 + LORBDB5 = Q-1 + LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'CUNBDB2', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce rows 1, ..., P of X11 and X21 +* + DO I = 1, P +* + IF( I .GT. 1 ) THEN + CALL CSROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C, + $ S ) + END IF + CALL CLACGV( Q-I+1, X11(I,I), LDX11 ) + CALL CLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) ) + C = REAL( X11(I,I) ) + X11(I,I) = ONE + CALL CLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL CLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X21(I,I), LDX21, WORK(ILARF) ) + CALL CLACGV( Q-I+1, X11(I,I), LDX11 ) + S = SQRT( SCNRM2( P-I, X11(I+1,I), 1, X11(I+1,I), + $ 1 )**2 + SCNRM2( M-P-I+1, X21(I,I), 1, X21(I,I), 1 )**2 ) + THETA(I) = ATAN2( S, C ) +* + CALL CUNBDB5( P-I, M-P-I+1, Q-I, X11(I+1,I), 1, X21(I,I), 1, + $ X11(I+1,I+1), LDX11, X21(I,I+1), LDX21, + $ WORK(IORBDB5), LORBDB5, CHILDINFO ) + CALL CSCAL( P-I, NEGONE, X11(I+1,I), 1 ) + CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + IF( I .LT. P ) THEN + CALL CLARFGP( P-I, X11(I+1,I), X11(I+2,I), 1, TAUP1(I) ) + PHI(I) = ATAN2( REAL( X11(I+1,I) ), REAL( X21(I,I) ) ) + C = COS( PHI(I) ) + S = SIN( PHI(I) ) + X11(I+1,I) = ONE + CALL CLARF( 'L', P-I, Q-I, X11(I+1,I), 1, CONJG(TAUP1(I)), + $ X11(I+1,I+1), LDX11, WORK(ILARF) ) + END IF + X21(I,I) = ONE + CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)), + $ X21(I,I+1), LDX21, WORK(ILARF) ) +* + END DO +* +* Reduce the bottom-right portion of X21 to the identity matrix +* + DO I = P + 1, Q + CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + X21(I,I) = ONE + CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)), + $ X21(I,I+1), LDX21, WORK(ILARF) ) + END DO +* + RETURN +* +* End of CUNBDB2 +* + END + diff --git a/lapack-netlib/SRC/cunbdb3.f b/lapack-netlib/SRC/cunbdb3.f new file mode 100644 index 000000000..5451ef003 --- /dev/null +++ b/lapack-netlib/SRC/cunbdb3.f @@ -0,0 +1,336 @@ +*> \brief \b CUNBDB3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CUNBDB3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* REAL PHI(*), THETA(*) +* COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> CUNBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonomal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-P must be no larger than P, +*> Q, or M-Q. Routines CUNBDB1, CUNBDB2, and CUNBDB4 handle cases in +*> which M-P is not the minimum dimension. +*> +*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are (M-P)-by-(M-P) bidiagonal matrices represented +*> implicitly by angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= M. M-P <= min(P,Q,M-Q). +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M. +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is COMPLEX array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is COMPLEX array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is REAL array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is REAL array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is COMPLEX array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is COMPLEX array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is COMPLEX array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +*> +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup complexOTHERcomputational +* +*> \par Further Details: +* ===================== + +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or CUNCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR +*> and CUNGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + REAL PHI(*), THETA(*) + COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + COMPLEX ONE + PARAMETER ( ONE = (1.0E0,0.0E0) ) +* .. +* .. Local Scalars .. + REAL C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, + $ LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, XERBLA +* .. +* .. External Functions .. + REAL SCNRM2 + EXTERNAL SCNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( 2*P .LT. M .OR. P .GT. M ) THEN + INFO = -2 + ELSE IF( Q .LT. M-P .OR. M-Q .LT. M-P ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( P, M-P-1, Q-1 ) + IORBDB5 = 2 + LORBDB5 = Q-1 + LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'CUNBDB3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce rows 1, ..., M-P of X11 and X21 +* + DO I = 1, M-P +* + IF( I .GT. 1 ) THEN + CALL CSROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C, + $ S ) + END IF +* + CALL CLACGV( Q-I+1, X21(I,I), LDX21 ) + CALL CLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) ) + S = REAL( X21(I,I) ) + X21(I,I) = ONE + CALL CLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X11(I,I), LDX11, WORK(ILARF) ) + CALL CLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X21(I+1,I), LDX21, WORK(ILARF) ) + CALL CLACGV( Q-I+1, X21(I,I), LDX21 ) + C = SQRT( SCNRM2( P-I+1, X11(I,I), 1, X11(I,I), + $ 1 )**2 + SCNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), 1 )**2 ) + THETA(I) = ATAN2( S, C ) +* + CALL CUNBDB5( P-I+1, M-P-I, Q-I, X11(I,I), 1, X21(I+1,I), 1, + $ X11(I,I+1), LDX11, X21(I+1,I+1), LDX21, + $ WORK(IORBDB5), LORBDB5, CHILDINFO ) + CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + IF( I .LT. M-P ) THEN + CALL CLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, TAUP2(I) ) + PHI(I) = ATAN2( REAL( X21(I+1,I) ), REAL( X11(I,I) ) ) + C = COS( PHI(I) ) + S = SIN( PHI(I) ) + X21(I+1,I) = ONE + CALL CLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1, CONJG(TAUP2(I)), + $ X21(I+1,I+1), LDX21, WORK(ILARF) ) + END IF + X11(I,I) = ONE + CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)), + $ X11(I,I+1), LDX11, WORK(ILARF) ) +* + END DO +* +* Reduce the bottom-right portion of X11 to the identity matrix +* + DO I = M-P + 1, Q + CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + X11(I,I) = ONE + CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)), + $ X11(I,I+1), LDX11, WORK(ILARF) ) + END DO +* + RETURN +* +* End of CUNBDB3 +* + END + diff --git a/lapack-netlib/SRC/cunbdb4.f b/lapack-netlib/SRC/cunbdb4.f new file mode 100644 index 000000000..bc948a30f --- /dev/null +++ b/lapack-netlib/SRC/cunbdb4.f @@ -0,0 +1,385 @@ +*> \brief \b CUNBDB4 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CUNBDB4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* REAL PHI(*), THETA(*) +* COMPLEX PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*), +* $ WORK(*), X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> CUNBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonomal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-Q must be no larger than P, +*> M-P, or Q. Routines CUNBDB1, CUNBDB2, and CUNBDB3 handle cases in +*> which M-Q is not the minimum dimension. +*> +*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are (M-Q)-by-(M-Q) bidiagonal matrices represented +*> implicitly by angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M and +*> M-Q <= min(P,M-P,Q). +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is COMPLEX array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is COMPLEX array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is REAL array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is REAL array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is COMPLEX array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is COMPLEX array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is COMPLEX array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] PHANTOM +*> \verbatim +*> PHANTOM is COMPLEX array, dimension (M) +*> The routine computes an M-by-1 column vector Y that is +*> orthogonal to the columns of [ X11; X21 ]. PHANTOM(1:P) and +*> PHANTOM(P+1:M) contain Householder vectors for Y(1:P) and +*> Y(P+1:M), respectively. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup complexOTHERcomputational +* +*> \par Further Details: +* ===================== + +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or CUNCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR +*> and CUNGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + $ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + REAL PHI(*), THETA(*) + COMPLEX PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*), + $ WORK(*), X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + COMPLEX NEGONE, ONE, ZERO + PARAMETER ( NEGONE = (-1.0E0,0.0E0), ONE = (1.0E0,0.0E0), + $ ZERO = (0.0E0,0.0E0) ) +* .. +* .. Local Scalars .. + REAL C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, J, LLARF, + $ LORBDB5, LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, CSCAL, XERBLA +* .. +* .. External Functions .. + REAL SCNRM2 + EXTERNAL SCNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( P .LT. M-Q .OR. M-P .LT. M-Q ) THEN + INFO = -2 + ELSE IF( Q .LT. M-Q .OR. Q .GT. M ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( Q-1, P-1, M-P-1 ) + IORBDB5 = 2 + LORBDB5 = Q + LWORKOPT = ILARF + LLARF - 1 + LWORKOPT = MAX( LWORKOPT, IORBDB5 + LORBDB5 - 1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'CUNBDB4', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce columns 1, ..., M-Q of X11 and X21 +* + DO I = 1, M-Q +* + IF( I .EQ. 1 ) THEN + DO J = 1, M + PHANTOM(J) = ZERO + END DO + CALL CUNBDB5( P, M-P, Q, PHANTOM(1), 1, PHANTOM(P+1), 1, + $ X11, LDX11, X21, LDX21, WORK(IORBDB5), + $ LORBDB5, CHILDINFO ) + CALL CSCAL( P, NEGONE, PHANTOM(1), 1 ) + CALL CLARFGP( P, PHANTOM(1), PHANTOM(2), 1, TAUP1(1) ) + CALL CLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, TAUP2(1) ) + THETA(I) = ATAN2( REAL( PHANTOM(1) ), REAL( PHANTOM(P+1) ) ) + C = COS( THETA(I) ) + S = SIN( THETA(I) ) + PHANTOM(1) = ONE + PHANTOM(P+1) = ONE + CALL CLARF( 'L', P, Q, PHANTOM(1), 1, CONJG(TAUP1(1)), X11, + $ LDX11, WORK(ILARF) ) + CALL CLARF( 'L', M-P, Q, PHANTOM(P+1), 1, CONJG(TAUP2(1)), + $ X21, LDX21, WORK(ILARF) ) + ELSE + CALL CUNBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1, + $ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I), + $ LDX21, WORK(IORBDB5), LORBDB5, CHILDINFO ) + CALL CSCAL( P-I+1, NEGONE, X11(I,I-1), 1 ) + CALL CLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, TAUP1(I) ) + CALL CLARFGP( M-P-I+1, X21(I,I-1), X21(I+1,I-1), 1, + $ TAUP2(I) ) + THETA(I) = ATAN2( REAL( X11(I,I-1) ), REAL( X21(I,I-1) ) ) + C = COS( THETA(I) ) + S = SIN( THETA(I) ) + X11(I,I-1) = ONE + X21(I,I-1) = ONE + CALL CLARF( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, + $ CONJG(TAUP1(I)), X11(I,I), LDX11, WORK(ILARF) ) + CALL CLARF( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, + $ CONJG(TAUP2(I)), X21(I,I), LDX21, WORK(ILARF) ) + END IF +* + CALL CSROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C ) + CALL CLACGV( Q-I+1, X21(I,I), LDX21 ) + CALL CLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) ) + C = REAL( X21(I,I) ) + X21(I,I) = ONE + CALL CLARF( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL CLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X21(I+1,I), LDX21, WORK(ILARF) ) + CALL CLACGV( Q-I+1, X21(I,I), LDX21 ) + IF( I .LT. M-Q ) THEN + S = SQRT( SCNRM2( P-I, X11(I+1,I), 1, X11(I+1,I), + $ 1 )**2 + SCNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), + $ 1 )**2 ) + PHI(I) = ATAN2( S, C ) + END IF +* + END DO +* +* Reduce the bottom-right portion of X11 to [ I 0 ] +* + DO I = M - Q + 1, P + CALL CLACGV( Q-I+1, X11(I,I), LDX11 ) + CALL CLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) ) + X11(I,I) = ONE + CALL CLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL CLARF( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X21(M-Q+1,I), LDX21, WORK(ILARF) ) + CALL CLACGV( Q-I+1, X11(I,I), LDX11 ) + END DO +* +* Reduce the bottom-right portion of X21 to [ 0 I ] +* + DO I = P + 1, Q + CALL CLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 ) + CALL CLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), LDX21, + $ TAUQ1(I) ) + X21(M-Q+I-P,I) = ONE + CALL CLARF( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, TAUQ1(I), + $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) ) + CALL CLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 ) + END DO +* + RETURN +* +* End of CUNBDB4 +* + END + diff --git a/lapack-netlib/SRC/cunbdb5.f b/lapack-netlib/SRC/cunbdb5.f new file mode 100644 index 000000000..d3a7d1535 --- /dev/null +++ b/lapack-netlib/SRC/cunbdb5.f @@ -0,0 +1,274 @@ +*> \brief \b CUNBDB5 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CUNBDB5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CUNBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, +* LDQ2, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, +* $ N +* .. +* .. Array Arguments .. +* COMPLEX Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> CUNBDB5 orthogonalizes the column vector +*> X = [ X1 ] +*> [ X2 ] +*> with respect to the columns of +*> Q = [ Q1 ] . +*> [ Q2 ] +*> The columns of Q must be orthonormal. +*> +*> If the projection is zero according to Kahan's "twice is enough" +*> criterion, then some other vector from the orthogonal complement +*> is returned. This vector is chosen in an arbitrary but deterministic +*> way. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M1 +*> \verbatim +*> M1 is INTEGER +*> The dimension of X1 and the number of rows in Q1. 0 <= M1. +*> \endverbatim +*> +*> \param[in] M2 +*> \verbatim +*> M2 is INTEGER +*> The dimension of X2 and the number of rows in Q2. 0 <= M2. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns in Q1 and Q2. 0 <= N. +*> \endverbatim +*> +*> \param[in,out] X1 +*> \verbatim +*> X1 is COMPLEX array, dimension (M1) +*> On entry, the top part of the vector to be orthogonalized. +*> On exit, the top part of the projected vector. +*> \endverbatim +*> +*> \param[in] INCX1 +*> \verbatim +*> INCX1 is INTEGER +*> Increment for entries of X1. +*> \endverbatim +*> +*> \param[in,out] X2 +*> \verbatim +*> X2 is COMPLEX array, dimension (M2) +*> On entry, the bottom part of the vector to be +*> orthogonalized. On exit, the bottom part of the projected +*> vector. +*> \endverbatim +*> +*> \param[in] INCX2 +*> \verbatim +*> INCX2 is INTEGER +*> Increment for entries of X2. +*> \endverbatim +*> +*> \param[in] Q1 +*> \verbatim +*> Q1 is COMPLEX array, dimension (LDQ1, N) +*> The top part of the orthonormal basis matrix. +*> \endverbatim +*> +*> \param[in] LDQ1 +*> \verbatim +*> LDQ1 is INTEGER +*> The leading dimension of Q1. LDQ1 >= M1. +*> \endverbatim +*> +*> \param[in] Q2 +*> \verbatim +*> Q2 is COMPLEX array, dimension (LDQ2, N) +*> The bottom part of the orthonormal basis matrix. +*> \endverbatim +*> +*> \param[in] LDQ2 +*> \verbatim +*> LDQ2 is INTEGER +*> The leading dimension of Q2. LDQ2 >= M2. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= N. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup complexOTHERcomputational +* +* ===================================================================== + SUBROUTINE CUNBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, + $ LDQ2, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, + $ N +* .. +* .. Array Arguments .. + COMPLEX Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ONE, ZERO + PARAMETER ( ONE = (1.0E0,0.0E0), ZERO = (0.0E0,0.0E0) ) +* .. +* .. Local Scalars .. + INTEGER CHILDINFO, I, J +* .. +* .. External Subroutines .. + EXTERNAL CUNBDB6, XERBLA +* .. +* .. External Functions .. + REAL SCNRM2 + EXTERNAL SCNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + IF( M1 .LT. 0 ) THEN + INFO = -1 + ELSE IF( M2 .LT. 0 ) THEN + INFO = -2 + ELSE IF( N .LT. 0 ) THEN + INFO = -3 + ELSE IF( INCX1 .LT. 1 ) THEN + INFO = -5 + ELSE IF( INCX2 .LT. 1 ) THEN + INFO = -7 + ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN + INFO = -9 + ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN + INFO = -11 + ELSE IF( LWORK .LT. N ) THEN + INFO = -13 + END IF +* + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'CUNBDB5', -INFO ) + RETURN + END IF +* +* Project X onto the orthogonal complement of Q +* + CALL CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, LDQ2, + $ WORK, LWORK, CHILDINFO ) +* +* If the projection is nonzero, then return +* + IF( SCNRM2(M1,X1,INCX1) .NE. ZERO + $ .OR. SCNRM2(M2,X2,INCX2) .NE. ZERO ) THEN + RETURN + END IF +* +* Project each standard basis vector e_1,...,e_M1 in turn, stopping +* when a nonzero projection is found +* + DO I = 1, M1 + DO J = 1, M1 + X1(J) = ZERO + END DO + X1(I) = ONE + DO J = 1, M2 + X2(J) = ZERO + END DO + CALL CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, + $ LDQ2, WORK, LWORK, CHILDINFO ) + IF( SCNRM2(M1,X1,INCX1) .NE. ZERO + $ .OR. SCNRM2(M2,X2,INCX2) .NE. ZERO ) THEN + RETURN + END IF + END DO +* +* Project each standard basis vector e_(M1+1),...,e_(M1+M2) in turn, +* stopping when a nonzero projection is found +* + DO I = 1, M2 + DO J = 1, M1 + X1(J) = ZERO + END DO + DO J = 1, M2 + X2(J) = ZERO + END DO + X2(I) = ONE + CALL CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, + $ LDQ2, WORK, LWORK, CHILDINFO ) + IF( SCNRM2(M1,X1,INCX1) .NE. ZERO + $ .OR. SCNRM2(M2,X2,INCX2) .NE. ZERO ) THEN + RETURN + END IF + END DO +* + RETURN +* +* End of CUNBDB5 +* + END + diff --git a/lapack-netlib/SRC/cunbdb6.f b/lapack-netlib/SRC/cunbdb6.f new file mode 100644 index 000000000..943e52249 --- /dev/null +++ b/lapack-netlib/SRC/cunbdb6.f @@ -0,0 +1,313 @@ +*> \brief \b CUNBDB6 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CUNBDB6 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, +* LDQ2, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, +* $ N +* .. +* .. Array Arguments .. +* COMPLEX Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> CUNBDB6 orthogonalizes the column vector +*> X = [ X1 ] +*> [ X2 ] +*> with respect to the columns of +*> Q = [ Q1 ] . +*> [ Q2 ] +*> The columns of Q must be orthonormal. +*> +*> If the projection is zero according to Kahan's "twice is enough" +*> criterion, then the zero vector is returned. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M1 +*> \verbatim +*> M1 is INTEGER +*> The dimension of X1 and the number of rows in Q1. 0 <= M1. +*> \endverbatim +*> +*> \param[in] M2 +*> \verbatim +*> M2 is INTEGER +*> The dimension of X2 and the number of rows in Q2. 0 <= M2. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns in Q1 and Q2. 0 <= N. +*> \endverbatim +*> +*> \param[in,out] X1 +*> \verbatim +*> X1 is COMPLEX array, dimension (M1) +*> On entry, the top part of the vector to be orthogonalized. +*> On exit, the top part of the projected vector. +*> \endverbatim +*> +*> \param[in] INCX1 +*> \verbatim +*> INCX1 is INTEGER +*> Increment for entries of X1. +*> \endverbatim +*> +*> \param[in,out] X2 +*> \verbatim +*> X2 is COMPLEX array, dimension (M2) +*> On entry, the bottom part of the vector to be +*> orthogonalized. On exit, the bottom part of the projected +*> vector. +*> \endverbatim +*> +*> \param[in] INCX2 +*> \verbatim +*> INCX2 is INTEGER +*> Increment for entries of X2. +*> \endverbatim +*> +*> \param[in] Q1 +*> \verbatim +*> Q1 is COMPLEX array, dimension (LDQ1, N) +*> The top part of the orthonormal basis matrix. +*> \endverbatim +*> +*> \param[in] LDQ1 +*> \verbatim +*> LDQ1 is INTEGER +*> The leading dimension of Q1. LDQ1 >= M1. +*> \endverbatim +*> +*> \param[in] Q2 +*> \verbatim +*> Q2 is COMPLEX array, dimension (LDQ2, N) +*> The bottom part of the orthonormal basis matrix. +*> \endverbatim +*> +*> \param[in] LDQ2 +*> \verbatim +*> LDQ2 is INTEGER +*> The leading dimension of Q2. LDQ2 >= M2. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= N. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup complexOTHERcomputational +* +* ===================================================================== + SUBROUTINE CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, + $ LDQ2, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, + $ N +* .. +* .. Array Arguments .. + COMPLEX Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ALPHASQ, REALONE, REALZERO + PARAMETER ( ALPHASQ = 0.01E0, REALONE = 1.0E0, + $ REALZERO = 0.0E0 ) + COMPLEX NEGONE, ONE, ZERO + PARAMETER ( NEGONE = (-1.0E0,0.0E0), ONE = (1.0E0,0.0E0), + $ ZERO = (0.0E0,0.0E0) ) +* .. +* .. Local Scalars .. + INTEGER I + REAL NORMSQ1, NORMSQ2, SCL1, SCL2, SSQ1, SSQ2 +* .. +* .. External Subroutines .. + EXTERNAL CGEMV, CLASSQ, XERBLA +* .. +* .. Intrinsic Function .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + IF( M1 .LT. 0 ) THEN + INFO = -1 + ELSE IF( M2 .LT. 0 ) THEN + INFO = -2 + ELSE IF( N .LT. 0 ) THEN + INFO = -3 + ELSE IF( INCX1 .LT. 1 ) THEN + INFO = -5 + ELSE IF( INCX2 .LT. 1 ) THEN + INFO = -7 + ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN + INFO = -9 + ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN + INFO = -11 + ELSE IF( LWORK .LT. N ) THEN + INFO = -13 + END IF +* + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'CUNBDB6', -INFO ) + RETURN + END IF +* +* First, project X onto the orthogonal complement of Q's column +* space +* + SCL1 = REALZERO + SSQ1 = REALONE + CALL CLASSQ( M1, X1, INCX1, SCL1, SSQ1 ) + SCL2 = REALZERO + SSQ2 = REALONE + CALL CLASSQ( M2, X2, INCX2, SCL2, SSQ2 ) + NORMSQ1 = SCL1**2*SSQ1 + SCL2**2*SSQ2 +* + IF( M1 .EQ. 0 ) THEN + DO I = 1, N + WORK(I) = ZERO + END DO + ELSE + CALL CGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK, + $ 1 ) + END IF +* + CALL CGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 ) +* + CALL CGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1, + $ INCX1 ) + CALL CGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2, + $ INCX2 ) +* + SCL1 = REALZERO + SSQ1 = REALONE + CALL CLASSQ( M1, X1, INCX1, SCL1, SSQ1 ) + SCL2 = REALZERO + SSQ2 = REALONE + CALL CLASSQ( M2, X2, INCX2, SCL2, SSQ2 ) + NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2 +* +* If projection is sufficiently large in norm, then stop. +* If projection is zero, then stop. +* Otherwise, project again. +* + IF( NORMSQ2 .GE. ALPHASQ*NORMSQ1 ) THEN + RETURN + END IF +* + IF( NORMSQ2 .EQ. ZERO ) THEN + RETURN + END IF +* + NORMSQ1 = NORMSQ2 +* + DO I = 1, N + WORK(I) = ZERO + END DO +* + IF( M1 .EQ. 0 ) THEN + DO I = 1, N + WORK(I) = ZERO + END DO + ELSE + CALL CGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK, + $ 1 ) + END IF +* + CALL CGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 ) +* + CALL CGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1, + $ INCX1 ) + CALL CGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2, + $ INCX2 ) +* + SCL1 = REALZERO + SSQ1 = REALONE + CALL CLASSQ( M1, X1, INCX1, SCL1, SSQ1 ) + SCL2 = REALZERO + SSQ2 = REALONE + CALL CLASSQ( M1, X1, INCX1, SCL1, SSQ1 ) + NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2 +* +* If second projection is sufficiently large in norm, then do +* nothing more. Alternatively, if it shrunk significantly, then +* truncate it to zero. +* + IF( NORMSQ2 .LT. ALPHASQ*NORMSQ1 ) THEN + DO I = 1, M1 + X1(I) = ZERO + END DO + DO I = 1, M2 + X2(I) = ZERO + END DO + END IF +* + RETURN +* +* End of CUNBDB6 +* + END + diff --git a/lapack-netlib/SRC/cuncsd.f b/lapack-netlib/SRC/cuncsd.f index fef03dd51..ca3922da4 100644 --- a/lapack-netlib/SRC/cuncsd.f +++ b/lapack-netlib/SRC/cuncsd.f @@ -308,7 +308,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complexOTHERcomputational * @@ -320,10 +320,10 @@ $ LDV2T, WORK, LWORK, RWORK, LRWORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS @@ -356,7 +356,7 @@ $ LBBCSDWORKOPT, LORBDBWORK, LORBDBWORKMIN, $ LORBDBWORKOPT, LORGLQWORK, LORGLQWORKMIN, $ LORGLQWORKOPT, LORGQRWORK, LORGQRWORKMIN, - $ LORGQRWORKOPT, LWORKMIN, LWORKOPT + $ LORGQRWORKOPT, LWORKMIN, LWORKOPT, P1, Q1 LOGICAL COLMAJOR, DEFAULTSIGNS, LQUERY, WANTU1, WANTU2, $ WANTV1T, WANTV2T INTEGER LRWORKMIN, LRWORKOPT @@ -392,9 +392,22 @@ INFO = -8 ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN INFO = -9 - ELSE IF( ( COLMAJOR .AND. LDX11 .LT. MAX(1,P) ) .OR. - $ ( .NOT.COLMAJOR .AND. LDX11 .LT. MAX(1,Q) ) ) THEN - INFO = -11 + ELSE IF ( COLMAJOR .AND. LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF (.NOT. COLMAJOR .AND. LDX11 .LT. MAX( 1, Q ) ) THEN + INFO = -11 + ELSE IF (COLMAJOR .AND. LDX12 .LT. MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF (.NOT. COLMAJOR .AND. LDX12 .LT. MAX( 1, M-Q ) ) THEN + INFO = -13 + ELSE IF (COLMAJOR .AND. LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -15 + ELSE IF (.NOT. COLMAJOR .AND. LDX21 .LT. MAX( 1, Q ) ) THEN + INFO = -15 + ELSE IF (COLMAJOR .AND. LDX22 .LT. MAX( 1, M-P ) ) THEN + INFO = -17 + ELSE IF (.NOT. COLMAJOR .AND. LDX22 .LT. MAX( 1, M-Q ) ) THEN + INFO = -17 ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN INFO = -20 ELSE IF( WANTU2 .AND. LDU2 .LT. M-P ) THEN @@ -458,9 +471,10 @@ IB22D = IB21E + MAX( 1, Q - 1 ) IB22E = IB22D + MAX( 1, Q ) IBBCSD = IB22E + MAX( 1, Q - 1 ) - CALL CBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, 0, - $ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, 0, - $ 0, 0, 0, 0, 0, 0, 0, RWORK, -1, CHILDINFO ) + CALL CBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, + $ THETA, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, + $ V2T, LDV2T, THETA, THETA, THETA, THETA, THETA, + $ THETA, THETA, THETA, RWORK, -1, CHILDINFO ) LBBCSDWORKOPT = INT( RWORK(1) ) LBBCSDWORKMIN = LBBCSDWORKOPT LRWORKOPT = IBBCSD + LBBCSDWORKOPT - 1 @@ -474,19 +488,19 @@ ITAUQ1 = ITAUP2 + MAX( 1, M - P ) ITAUQ2 = ITAUQ1 + MAX( 1, Q ) IORGQR = ITAUQ2 + MAX( 1, M - Q ) - CALL CUNGQR( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), 0, WORK, -1, + CALL CUNGQR( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), U1, WORK, -1, $ CHILDINFO ) LORGQRWORKOPT = INT( WORK(1) ) LORGQRWORKMIN = MAX( 1, M - Q ) IORGLQ = ITAUQ2 + MAX( 1, M - Q ) - CALL CUNGLQ( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), 0, WORK, -1, + CALL CUNGLQ( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), U1, WORK, -1, $ CHILDINFO ) LORGLQWORKOPT = INT( WORK(1) ) LORGLQWORKMIN = MAX( 1, M - Q ) IORBDB = ITAUQ2 + MAX( 1, M - Q ) CALL CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, - $ X21, LDX21, X22, LDX22, 0, 0, 0, 0, 0, 0, WORK, - $ -1, CHILDINFO ) + $ X21, LDX21, X22, LDX22, THETA, THETA, U1, U2, + $ V1T, V2T, WORK, -1, CHILDINFO ) LORBDBWORKOPT = INT( WORK(1) ) LORBDBWORKMIN = LORBDBWORKOPT LWORKOPT = MAX( IORGQR + LORGQRWORKOPT, IORGLQ + LORGLQWORKOPT, @@ -551,10 +565,14 @@ END IF IF( WANTV2T .AND. M-Q .GT. 0 ) THEN CALL CLACPY( 'U', P, M-Q, X12, LDX12, V2T, LDV2T ) - CALL CLACPY( 'U', M-P-Q, M-P-Q, X22(Q+1,P+1), LDX22, - $ V2T(P+1,P+1), LDV2T ) - CALL CUNGLQ( M-Q, M-Q, M-Q, V2T, LDV2T, WORK(ITAUQ2), - $ WORK(IORGLQ), LORGLQWORK, INFO ) + IF( M-P .GT. Q ) THEN + CALL CLACPY( 'U', M-P-Q, M-P-Q, X22(Q+1,P+1), LDX22, + $ V2T(P+1,P+1), LDV2T ) + END IF + IF( M .GT. Q ) THEN + CALL CUNGLQ( M-Q, M-Q, M-Q, V2T, LDV2T, WORK(ITAUQ2), + $ WORK(IORGLQ), LORGLQWORK, INFO ) + END IF END IF ELSE IF( WANTU1 .AND. P .GT. 0 ) THEN @@ -579,9 +597,13 @@ $ WORK(IORGQR), LORGQRWORK, INFO ) END IF IF( WANTV2T .AND. M-Q .GT. 0 ) THEN + P1 = MIN( P+1, M ) + Q1 = MIN( Q+1, M ) CALL CLACPY( 'L', M-Q, P, X12, LDX12, V2T, LDV2T ) - CALL CLACPY( 'L', M-P-Q, M-P-Q, X22(P+1,Q+1), LDX22, - $ V2T(P+1,P+1), LDV2T ) + IF ( M .GT. P+Q ) THEN + CALL CLACPY( 'L', M-P-Q, M-P-Q, X22(P1,Q1), LDX22, + $ V2T(P+1,P+1), LDV2T ) + END IF CALL CUNGQR( M-Q, M-Q, M-Q, V2T, LDV2T, WORK(ITAUQ2), $ WORK(IORGQR), LORGQRWORK, INFO ) END IF diff --git a/lapack-netlib/SRC/cuncsd2by1.f b/lapack-netlib/SRC/cuncsd2by1.f new file mode 100644 index 000000000..74364cec3 --- /dev/null +++ b/lapack-netlib/SRC/cuncsd2by1.f @@ -0,0 +1,757 @@ +*> \brief \b CUNCSD2BY1 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CUNCSD2BY1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, +* X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T, +* LDV1T, WORK, LWORK, RWORK, LRWORK, IWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBU1, JOBU2, JOBV1T +* INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21, +* $ M, P, Q +* INTEGER LRWORK, LRWORKMIN, LRWORKOPT +* .. +* .. Array Arguments .. +* REAL RWORK(*) +* REAL THETA(*) +* COMPLEX U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* INTEGER IWORK(*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> CUNCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with +*> orthonormal columns that has been partitioned into a 2-by-1 block +*> structure: +*> +*> [ I 0 0 ] +*> [ 0 C 0 ] +*> [ X11 ] [ U1 | ] [ 0 0 0 ] +*> X = [-----] = [---------] [----------] V1**T . +*> [ X21 ] [ | U2 ] [ 0 0 0 ] +*> [ 0 S 0 ] +*> [ 0 0 I ] +*> +*> X11 is P-by-Q. The unitary matrices U1, U2, V1, and V2 are P-by-P, +*> (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are +*> R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in +*> which R = MIN(P,M-P,Q,M-Q). +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBU1 +*> \verbatim +*> JOBU1 is CHARACTER +*> = 'Y': U1 is computed; +*> otherwise: U1 is not computed. +*> \endverbatim +*> +*> \param[in] JOBU2 +*> \verbatim +*> JOBU2 is CHARACTER +*> = 'Y': U2 is computed; +*> otherwise: U2 is not computed. +*> \endverbatim +*> +*> \param[in] JOBV1T +*> \verbatim +*> JOBV1T is CHARACTER +*> = 'Y': V1T is computed; +*> otherwise: V1T is not computed. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows and columns in X. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11 and X12. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M. +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is COMPLEX array, dimension (LDX11,Q) +*> On entry, part of the unitary matrix whose CSD is +*> desired. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= MAX(1,P). +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is COMPLEX array, dimension (LDX21,Q) +*> On entry, part of the unitary matrix whose CSD is +*> desired. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= MAX(1,M-P). +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is COMPLEX array, dimension (R), in which R = +*> MIN(P,M-P,Q,M-Q). +*> C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and +*> S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ). +*> \endverbatim +*> +*> \param[out] U1 +*> \verbatim +*> U1 is COMPLEX array, dimension (P) +*> If JOBU1 = 'Y', U1 contains the P-by-P unitary matrix U1. +*> \endverbatim +*> +*> \param[in] LDU1 +*> \verbatim +*> LDU1 is INTEGER +*> The leading dimension of U1. If JOBU1 = 'Y', LDU1 >= +*> MAX(1,P). +*> \endverbatim +*> +*> \param[out] U2 +*> \verbatim +*> U2 is COMPLEX array, dimension (M-P) +*> If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) unitary +*> matrix U2. +*> \endverbatim +*> +*> \param[in] LDU2 +*> \verbatim +*> LDU2 is INTEGER +*> The leading dimension of U2. If JOBU2 = 'Y', LDU2 >= +*> MAX(1,M-P). +*> \endverbatim +*> +*> \param[out] V1T +*> \verbatim +*> V1T is COMPLEX array, dimension (Q) +*> If JOBV1T = 'Y', V1T contains the Q-by-Q matrix unitary +*> matrix V1**T. +*> \endverbatim +*> +*> \param[in] LDV1T +*> \verbatim +*> LDV1T is INTEGER +*> The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >= +*> MAX(1,Q). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> If INFO > 0 on exit, WORK(2:R) contains the values PHI(1), +*> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R), +*> define the matrix in intermediate bidiagonal-block form +*> remaining after nonconvergence. INFO specifies the number +*> of nonzero PHI's. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> \endverbatim +*> \verbatim +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the work array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (MAX(1,LRWORK)) +*> On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. +*> If INFO > 0 on exit, RWORK(2:R) contains the values PHI(1), +*> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R), +*> define the matrix in intermediate bidiagonal-block form +*> remaining after nonconvergence. INFO specifies the number +*> of nonzero PHI's. +*> \endverbatim +*> +*> \param[in] LRWORK +*> \verbatim +*> LRWORK is INTEGER +*> The dimension of the array RWORK. +*> +*> If LRWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the RWORK array, returns +*> this value as the first entry of the work array, and no error +*> message related to LRWORK is issued by XERBLA. +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (M-MIN(P,M-P,Q,M-Q)) +*> \endverbatim +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: CBBCSD did not converge. See the description of WORK +*> above for details. +*> \endverbatim +* +*> \par References: +*> ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup complexOTHERcomputational +* +* ===================================================================== + SUBROUTINE CUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, + $ X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T, + $ LDV1T, WORK, LWORK, RWORK, LRWORK, IWORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + CHARACTER JOBU1, JOBU2, JOBV1T + INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21, + $ M, P, Q + INTEGER LRWORK, LRWORKMIN, LRWORKOPT +* .. +* .. Array Arguments .. + REAL RWORK(*) + REAL THETA(*) + COMPLEX U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) + INTEGER IWORK(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ONE, ZERO + PARAMETER ( ONE = (1.0E0,0.0E0), ZERO = (0.0E0,0.0E0) ) +* .. +* .. Local Scalars .. + INTEGER CHILDINFO, I, IB11D, IB11E, IB12D, IB12E, + $ IB21D, IB21E, IB22D, IB22E, IBBCSD, IORBDB, + $ IORGLQ, IORGQR, IPHI, ITAUP1, ITAUP2, ITAUQ1, + $ J, LBBCSD, LORBDB, LORGLQ, LORGLQMIN, + $ LORGLQOPT, LORGQR, LORGQRMIN, LORGQROPT, + $ LWORKMIN, LWORKOPT, R + LOGICAL LQUERY, WANTU1, WANTU2, WANTV1T +* .. +* .. External Subroutines .. + EXTERNAL CBBCSD, CCOPY, CLACPY, CLAPMR, CLAPMT, CUNBDB1, + $ CUNBDB2, CUNBDB3, CUNBDB4, CUNGLQ, CUNGQR, + $ XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Function .. + INTRINSIC INT, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + WANTU1 = LSAME( JOBU1, 'Y' ) + WANTU2 = LSAME( JOBU2, 'Y' ) + WANTV1T = LSAME( JOBV1T, 'Y' ) + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -4 + ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN + INFO = -5 + ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN + INFO = -6 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -8 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -10 + ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN + INFO = -13 + ELSE IF( WANTU2 .AND. LDU2 .LT. M - P ) THEN + INFO = -15 + ELSE IF( WANTV1T .AND. LDV1T .LT. Q ) THEN + INFO = -17 + END IF +* + R = MIN( P, M-P, Q, M-Q ) +* +* Compute workspace +* +* WORK layout: +* |-----------------------------------------| +* | LWORKOPT (1) | +* |-----------------------------------------| +* | TAUP1 (MAX(1,P)) | +* | TAUP2 (MAX(1,M-P)) | +* | TAUQ1 (MAX(1,Q)) | +* |-----------------------------------------| +* | CUNBDB WORK | CUNGQR WORK | CUNGLQ WORK | +* | | | | +* | | | | +* | | | | +* | | | | +* |-----------------------------------------| +* RWORK layout: +* |------------------| +* | LRWORKOPT (1) | +* |------------------| +* | PHI (MAX(1,R-1)) | +* |------------------| +* | B11D (R) | +* | B11E (R-1) | +* | B12D (R) | +* | B12E (R-1) | +* | B21D (R) | +* | B21E (R-1) | +* | B22D (R) | +* | B22E (R-1) | +* | CBBCSD RWORK | +* |------------------| +* + IF( INFO .EQ. 0 ) THEN + IPHI = 2 + IB11D = IPHI + MAX( 1, R-1 ) + IB11E = IB11D + MAX( 1, R ) + IB12D = IB11E + MAX( 1, R - 1 ) + IB12E = IB12D + MAX( 1, R ) + IB21D = IB12E + MAX( 1, R - 1 ) + IB21E = IB21D + MAX( 1, R ) + IB22D = IB21E + MAX( 1, R - 1 ) + IB22E = IB22D + MAX( 1, R ) + IBBCSD = IB22E + MAX( 1, R - 1 ) + ITAUP1 = 2 + ITAUP2 = ITAUP1 + MAX( 1, P ) + ITAUQ1 = ITAUP2 + MAX( 1, M-P ) + IORBDB = ITAUQ1 + MAX( 1, Q ) + IORGQR = ITAUQ1 + MAX( 1, Q ) + IORGLQ = ITAUQ1 + MAX( 1, Q ) + IF( R .EQ. Q ) THEN + CALL CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, + $ 0, 0, WORK, -1, CHILDINFO ) + LORBDB = INT( WORK(1) ) + IF( P .GE. M-P ) THEN + CALL CUNGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, P ) + LORGQROPT = INT( WORK(1) ) + ELSE + CALL CUNGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, M-P ) + LORGQROPT = INT( WORK(1) ) + END IF + CALL CUNGLQ( MAX(0,Q-1), MAX(0,Q-1), MAX(0,Q-1), V1T, LDV1T, + $ 0, WORK(1), -1, CHILDINFO ) + LORGLQMIN = MAX( 1, Q-1 ) + LORGLQOPT = INT( WORK(1) ) + CALL CBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA, + $ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, 0, 0, + $ 0, 0, 0, 0, 0, 0, RWORK(1), -1, CHILDINFO ) + LBBCSD = INT( RWORK(1) ) + ELSE IF( R .EQ. P ) THEN + CALL CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, + $ 0, 0, WORK(1), -1, CHILDINFO ) + LORBDB = INT( WORK(1) ) + IF( P-1 .GE. M-P ) THEN + CALL CUNGQR( P-1, P-1, P-1, U1(2,2), LDU1, 0, WORK(1), + $ -1, CHILDINFO ) + LORGQRMIN = MAX( 1, P-1 ) + LORGQROPT = INT( WORK(1) ) + ELSE + CALL CUNGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, M-P ) + LORGQROPT = INT( WORK(1) ) + END IF + CALL CUNGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1, + $ CHILDINFO ) + LORGLQMIN = MAX( 1, Q ) + LORGLQOPT = INT( WORK(1) ) + CALL CBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA, + $ 0, V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, 0, 0, + $ 0, 0, 0, 0, 0, 0, RWORK(1), -1, CHILDINFO ) + LBBCSD = INT( RWORK(1) ) + ELSE IF( R .EQ. M-P ) THEN + CALL CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, + $ 0, 0, WORK(1), -1, CHILDINFO ) + LORBDB = INT( WORK(1) ) + IF( P .GE. M-P-1 ) THEN + CALL CUNGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, P ) + LORGQROPT = INT( WORK(1) ) + ELSE + CALL CUNGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, 0, + $ WORK(1), -1, CHILDINFO ) + LORGQRMIN = MAX( 1, M-P-1 ) + LORGQROPT = INT( WORK(1) ) + END IF + CALL CUNGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1, + $ CHILDINFO ) + LORGLQMIN = MAX( 1, Q ) + LORGLQOPT = INT( WORK(1) ) + CALL CBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P, + $ THETA, 0, 0, 1, V1T, LDV1T, U2, LDU2, U1, LDU1, + $ 0, 0, 0, 0, 0, 0, 0, 0, RWORK(1), -1, + $ CHILDINFO ) + LBBCSD = INT( RWORK(1) ) + ELSE + CALL CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, + $ 0, 0, 0, WORK(1), -1, CHILDINFO ) + LORBDB = M + INT( WORK(1) ) + IF( P .GE. M-P ) THEN + CALL CUNGQR( P, P, M-Q, U1, LDU1, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, P ) + LORGQROPT = INT( WORK(1) ) + ELSE + CALL CUNGQR( M-P, M-P, M-Q, U2, LDU2, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, M-P ) + LORGQROPT = INT( WORK(1) ) + END IF + CALL CUNGLQ( Q, Q, Q, V1T, LDV1T, 0, WORK(1), -1, + $ CHILDINFO ) + LORGLQMIN = MAX( 1, Q ) + LORGLQOPT = INT( WORK(1) ) + CALL CBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q, + $ THETA, 0, U2, LDU2, U1, LDU1, 0, 1, V1T, LDV1T, + $ 0, 0, 0, 0, 0, 0, 0, 0, RWORK(1), -1, + $ CHILDINFO ) + LBBCSD = INT( RWORK(1) ) + END IF + LRWORKMIN = IBBCSD+LBBCSD-1 + LRWORKOPT = LRWORKMIN + RWORK(1) = LRWORKOPT + LWORKMIN = MAX( IORBDB+LORBDB-1, + $ IORGQR+LORGQRMIN-1, + $ IORGLQ+LORGLQMIN-1 ) + LWORKOPT = MAX( IORBDB+LORBDB-1, + $ IORGQR+LORGQROPT-1, + $ IORGLQ+LORGLQOPT-1 ) + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -19 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'CUNCSD2BY1', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF + LORGQR = LWORK-IORGQR+1 + LORGLQ = LWORK-IORGLQ+1 +* +* Handle four cases separately: R = Q, R = P, R = M-P, and R = M-Q, +* in which R = MIN(P,M-P,Q,M-Q) +* + IF( R .EQ. Q ) THEN +* +* Case 1: R = Q +* +* Simultaneously bidiagonalize X11 and X21 +* + CALL CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2), + $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO ) +* +* Accumulate Householder reflectors +* + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL CLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 ) + CALL CUNGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR), + $ LORGQR, CHILDINFO ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL CLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 ) + CALL CUNGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + V1T(1,1) = ONE + DO J = 2, Q + V1T(1,J) = ZERO + V1T(J,1) = ZERO + END DO + CALL CLACPY( 'U', Q-1, Q-1, X21(1,2), LDX21, V1T(2,2), + $ LDV1T ) + CALL CUNGLQ( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1), + $ WORK(IORGLQ), LORGLQ, CHILDINFO ) + END IF +* +* Simultaneously diagonalize X11 and X21. +* + CALL CBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA, + $ RWORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, + $ RWORK(IB11D), RWORK(IB11E), RWORK(IB12D), + $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E), + $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD, + $ CHILDINFO ) +* +* Permute rows and columns to place zero submatrices in +* preferred positions +* + IF( Q .GT. 0 .AND. WANTU2 ) THEN + DO I = 1, Q + IWORK(I) = M - P - Q + I + END DO + DO I = Q + 1, M - P + IWORK(I) = I - Q + END DO + CALL CLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK ) + END IF + ELSE IF( R .EQ. P ) THEN +* +* Case 2: R = P +* +* Simultaneously bidiagonalize X11 and X21 +* + CALL CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2), + $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO ) +* +* Accumulate Householder reflectors +* + IF( WANTU1 .AND. P .GT. 0 ) THEN + U1(1,1) = ONE + DO J = 2, P + U1(1,J) = ZERO + U1(J,1) = ZERO + END DO + CALL CLACPY( 'L', P-1, P-1, X11(2,1), LDX11, U1(2,2), LDU1 ) + CALL CUNGQR( P-1, P-1, P-1, U1(2,2), LDU1, WORK(ITAUP1), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL CLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 ) + CALL CUNGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL CLACPY( 'U', P, Q, X11, LDX11, V1T, LDV1T ) + CALL CUNGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1), + $ WORK(IORGLQ), LORGLQ, CHILDINFO ) + END IF +* +* Simultaneously diagonalize X11 and X21. +* + CALL CBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA, + $ RWORK(IPHI), V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, + $ RWORK(IB11D), RWORK(IB11E), RWORK(IB12D), + $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E), + $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD, + $ CHILDINFO ) +* +* Permute rows and columns to place identity submatrices in +* preferred positions +* + IF( Q .GT. 0 .AND. WANTU2 ) THEN + DO I = 1, Q + IWORK(I) = M - P - Q + I + END DO + DO I = Q + 1, M - P + IWORK(I) = I - Q + END DO + CALL CLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK ) + END IF + ELSE IF( R .EQ. M-P ) THEN +* +* Case 3: R = M-P +* +* Simultaneously bidiagonalize X11 and X21 +* + CALL CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2), + $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO ) +* +* Accumulate Householder reflectors +* + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL CLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 ) + CALL CUNGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR), + $ LORGQR, CHILDINFO ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + U2(1,1) = ONE + DO J = 2, M-P + U2(1,J) = ZERO + U2(J,1) = ZERO + END DO + CALL CLACPY( 'L', M-P-1, M-P-1, X21(2,1), LDX21, U2(2,2), + $ LDU2 ) + CALL CUNGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, + $ WORK(ITAUP2), WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL CLACPY( 'U', M-P, Q, X21, LDX21, V1T, LDV1T ) + CALL CUNGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1), + $ WORK(IORGLQ), LORGLQ, CHILDINFO ) + END IF +* +* Simultaneously diagonalize X11 and X21. +* + CALL CBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P, + $ THETA, RWORK(IPHI), 0, 1, V1T, LDV1T, U2, LDU2, + $ U1, LDU1, RWORK(IB11D), RWORK(IB11E), + $ RWORK(IB12D), RWORK(IB12E), RWORK(IB21D), + $ RWORK(IB21E), RWORK(IB22D), RWORK(IB22E), + $ RWORK(IBBCSD), LBBCSD, CHILDINFO ) +* +* Permute rows and columns to place identity submatrices in +* preferred positions +* + IF( Q .GT. R ) THEN + DO I = 1, R + IWORK(I) = Q - R + I + END DO + DO I = R + 1, Q + IWORK(I) = I - R + END DO + IF( WANTU1 ) THEN + CALL CLAPMT( .FALSE., P, Q, U1, LDU1, IWORK ) + END IF + IF( WANTV1T ) THEN + CALL CLAPMR( .FALSE., Q, Q, V1T, LDV1T, IWORK ) + END IF + END IF + ELSE +* +* Case 4: R = M-Q +* +* Simultaneously bidiagonalize X11 and X21 +* + CALL CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2), + $ WORK(ITAUQ1), WORK(IORBDB), WORK(IORBDB+M), + $ LORBDB-M, CHILDINFO ) +* +* Accumulate Householder reflectors +* + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL CCOPY( P, WORK(IORBDB), 1, U1, 1 ) + DO J = 2, P + U1(1,J) = ZERO + END DO + CALL CLACPY( 'L', P-1, M-Q-1, X11(2,1), LDX11, U1(2,2), + $ LDU1 ) + CALL CUNGQR( P, P, M-Q, U1, LDU1, WORK(ITAUP1), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL CCOPY( M-P, WORK(IORBDB+P), 1, U2, 1 ) + DO J = 2, M-P + U2(1,J) = ZERO + END DO + CALL CLACPY( 'L', M-P-1, M-Q-1, X21(2,1), LDX21, U2(2,2), + $ LDU2 ) + CALL CUNGQR( M-P, M-P, M-Q, U2, LDU2, WORK(ITAUP2), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL CLACPY( 'U', M-Q, Q, X21, LDX21, V1T, LDV1T ) + CALL CLACPY( 'U', P-(M-Q), Q-(M-Q), X11(M-Q+1,M-Q+1), LDX11, + $ V1T(M-Q+1,M-Q+1), LDV1T ) + CALL CLACPY( 'U', -P+Q, Q-P, X21(M-Q+1,P+1), LDX21, + $ V1T(P+1,P+1), LDV1T ) + CALL CUNGLQ( Q, Q, Q, V1T, LDV1T, WORK(ITAUQ1), + $ WORK(IORGLQ), LORGLQ, CHILDINFO ) + END IF +* +* Simultaneously diagonalize X11 and X21. +* + CALL CBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q, + $ THETA, RWORK(IPHI), U2, LDU2, U1, LDU1, 0, 1, V1T, + $ LDV1T, RWORK(IB11D), RWORK(IB11E), RWORK(IB12D), + $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E), + $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD, + $ CHILDINFO ) +* +* Permute rows and columns to place identity submatrices in +* preferred positions +* + IF( P .GT. R ) THEN + DO I = 1, R + IWORK(I) = P - R + I + END DO + DO I = R + 1, P + IWORK(I) = I - R + END DO + IF( WANTU1 ) THEN + CALL CLAPMT( .FALSE., P, P, U1, LDU1, IWORK ) + END IF + IF( WANTV1T ) THEN + CALL CLAPMR( .FALSE., P, Q, V1T, LDV1T, IWORK ) + END IF + END IF + END IF +* + RETURN +* +* End of CUNCSD2BY1 +* + END + diff --git a/lapack-netlib/SRC/dbbcsd.f b/lapack-netlib/SRC/dbbcsd.f index 479168e26..3e54909f2 100644 --- a/lapack-netlib/SRC/dbbcsd.f +++ b/lapack-netlib/SRC/dbbcsd.f @@ -322,7 +322,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup doubleOTHERcomputational * @@ -332,10 +332,10 @@ $ V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, $ B22D, B22E, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS @@ -358,8 +358,8 @@ PARAMETER ( HUNDRED = 100.0D0, MEIGHTH = -0.125D0, $ ONE = 1.0D0, PIOVER2 = 1.57079632679489662D0, $ TEN = 10.0D0, ZERO = 0.0D0 ) - DOUBLE PRECISION NEGONECOMPLEX - PARAMETER ( NEGONECOMPLEX = -1.0D0 ) + DOUBLE PRECISION NEGONE + PARAMETER ( NEGONE = -1.0D0 ) * .. * .. Local Scalars .. LOGICAL COLMAJOR, LQUERY, RESTART11, RESTART12, @@ -477,7 +477,10 @@ * Initial deflation * IMAX = Q - DO WHILE( ( IMAX .GT. 1 ) .AND. ( PHI(IMAX-1) .EQ. ZERO ) ) + DO WHILE( IMAX .GT. 1 ) + IF( PHI(IMAX-1) .NE. ZERO ) THEN + EXIT + END IF IMAX = IMAX - 1 END DO IMIN = IMAX - 1 @@ -939,9 +942,9 @@ B21D(IMAX) = -B21D(IMAX) IF( WANTV1T ) THEN IF( COLMAJOR ) THEN - CALL DSCAL( Q, NEGONECOMPLEX, V1T(IMAX,1), LDV1T ) + CALL DSCAL( Q, NEGONE, V1T(IMAX,1), LDV1T ) ELSE - CALL DSCAL( Q, NEGONECOMPLEX, V1T(1,IMAX), 1 ) + CALL DSCAL( Q, NEGONE, V1T(1,IMAX), 1 ) END IF END IF END IF @@ -962,9 +965,9 @@ B12D(IMAX) = -B12D(IMAX) IF( WANTU1 ) THEN IF( COLMAJOR ) THEN - CALL DSCAL( P, NEGONECOMPLEX, U1(1,IMAX), 1 ) + CALL DSCAL( P, NEGONE, U1(1,IMAX), 1 ) ELSE - CALL DSCAL( P, NEGONECOMPLEX, U1(IMAX,1), LDU1 ) + CALL DSCAL( P, NEGONE, U1(IMAX,1), LDU1 ) END IF END IF END IF @@ -972,9 +975,9 @@ B22D(IMAX) = -B22D(IMAX) IF( WANTU2 ) THEN IF( COLMAJOR ) THEN - CALL DSCAL( M-P, NEGONECOMPLEX, U2(1,IMAX), 1 ) + CALL DSCAL( M-P, NEGONE, U2(1,IMAX), 1 ) ELSE - CALL DSCAL( M-P, NEGONECOMPLEX, U2(IMAX,1), LDU2 ) + CALL DSCAL( M-P, NEGONE, U2(IMAX,1), LDU2 ) END IF END IF END IF @@ -984,9 +987,9 @@ IF( B12D(IMAX)+B22D(IMAX) .LT. 0 ) THEN IF( WANTV2T ) THEN IF( COLMAJOR ) THEN - CALL DSCAL( M-Q, NEGONECOMPLEX, V2T(IMAX,1), LDV2T ) + CALL DSCAL( M-Q, NEGONE, V2T(IMAX,1), LDV2T ) ELSE - CALL DSCAL( M-Q, NEGONECOMPLEX, V2T(1,IMAX), 1 ) + CALL DSCAL( M-Q, NEGONE, V2T(1,IMAX), 1 ) END IF END IF END IF diff --git a/lapack-netlib/SRC/dgebal.f b/lapack-netlib/SRC/dgebal.f index 5d7ed035c..80ae26812 100644 --- a/lapack-netlib/SRC/dgebal.f +++ b/lapack-netlib/SRC/dgebal.f @@ -121,7 +121,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup doubleGEcomputational * @@ -160,10 +160,10 @@ * ===================================================================== SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER JOB @@ -192,8 +192,8 @@ * .. External Functions .. LOGICAL DISNAN, LSAME INTEGER IDAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL DISNAN, LSAME, IDAMAX, DLAMCH + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL DISNAN, LSAME, IDAMAX, DLAMCH, DNRM2 * .. * .. External Subroutines .. EXTERNAL DSCAL, DSWAP, XERBLA @@ -312,19 +312,14 @@ SFMAX1 = ONE / SFMIN1 SFMIN2 = SFMIN1*SCLFAC SFMAX2 = ONE / SFMIN2 +* 140 CONTINUE NOCONV = .FALSE. * DO 200 I = K, L - C = ZERO - R = ZERO -* - DO 150 J = K, L - IF( J.EQ.I ) - $ GO TO 150 - C = C + ABS( A( J, I ) ) - R = R + ABS( A( I, J ) ) - 150 CONTINUE +* + C = DNRM2( L-K+1, A( K, I ), 1 ) + R = DNRM2( L-K+1, A( I, K ), LDA ) ICA = IDAMAX( L, A( 1, I ), 1 ) CA = ABS( A( ICA, I ) ) IRA = IDAMAX( N-K+1, A( I, K ), LDA ) diff --git a/lapack-netlib/SRC/dgemqrt.f b/lapack-netlib/SRC/dgemqrt.f index 99b396822..ef79221c3 100644 --- a/lapack-netlib/SRC/dgemqrt.f +++ b/lapack-netlib/SRC/dgemqrt.f @@ -160,7 +160,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup doubleGEcomputational * @@ -168,10 +168,10 @@ SUBROUTINE DGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, $ C, LDC, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -225,7 +225,7 @@ INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.Q ) THEN INFO = -5 - ELSE IF( NB.LT.1 .OR. NB.GT.K ) THEN + ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0)) THEN INFO = -6 ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN INFO = -8 diff --git a/lapack-netlib/SRC/dgeqrt.f b/lapack-netlib/SRC/dgeqrt.f index 91dfad1e6..0ba5c7fcf 100644 --- a/lapack-netlib/SRC/dgeqrt.f +++ b/lapack-netlib/SRC/dgeqrt.f @@ -108,7 +108,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup doubleGEcomputational * @@ -141,10 +141,10 @@ * ===================================================================== SUBROUTINE DGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDT, M, N, NB @@ -173,7 +173,7 @@ INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 - ELSE IF( NB.LT.1 .OR. NB.GT.MIN(M,N) ) THEN + ELSE IF( NB.LT.1 .OR. ( NB.GT.MIN(M,N) .AND. MIN(M,N).GT.0 ) )THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 diff --git a/lapack-netlib/SRC/dgesdd.f b/lapack-netlib/SRC/dgesdd.f index 31a811a5a..6fc753329 100644 --- a/lapack-netlib/SRC/dgesdd.f +++ b/lapack-netlib/SRC/dgesdd.f @@ -175,8 +175,7 @@ *> LWORK >= 3*min(M,N) + *> max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)). *> If JOBZ = 'S' or 'A' -*> LWORK >= 3*min(M,N) + -*> max(max(M,N),4*min(M,N)*min(M,N)+3*min(M,N)+max(M,N)). +*> LWORK >= min(M,N)*(6+4*min(M,N))+max(M,N) *> For good performance, LWORK should generally be larger. *> If LWORK = -1 but other input arguments are legal, WORK(1) *> returns the optimal LWORK. @@ -203,7 +202,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup doubleGEsing * @@ -217,10 +216,10 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, $ LWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER JOBZ diff --git a/lapack-netlib/SRC/dgetc2.f b/lapack-netlib/SRC/dgetc2.f index 6ae1a204b..7e43a0236 100644 --- a/lapack-netlib/SRC/dgetc2.f +++ b/lapack-netlib/SRC/dgetc2.f @@ -98,7 +98,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup doubleGEauxiliary * @@ -111,10 +111,10 @@ * ===================================================================== SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. INTEGER INFO, LDA, N @@ -203,6 +203,11 @@ INFO = N A( N, N ) = SMIN END IF +* +* Set last pivots to N +* + IPIV( N ) = N + JPIV( N ) = N * RETURN * diff --git a/lapack-netlib/SRC/dhgeqz.f b/lapack-netlib/SRC/dhgeqz.f index f6989aae2..bf6e414d7 100644 --- a/lapack-netlib/SRC/dhgeqz.f +++ b/lapack-netlib/SRC/dhgeqz.f @@ -282,7 +282,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup doubleGEcomputational * @@ -304,10 +304,10 @@ $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, $ LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOB @@ -739,9 +739,9 @@ * Exceptional shift. Chosen for no particularly good reason. * (Single shift only.) * - IF( ( DBLE( MAXIT )*SAFMIN )*ABS( H( ILAST-1, ILAST ) ).LT. + IF( ( DBLE( MAXIT )*SAFMIN )*ABS( H( ILAST, ILAST-1 ) ).LT. $ ABS( T( ILAST-1, ILAST-1 ) ) ) THEN - ESHIFT = ESHIFT + H( ILAST, ILAST-1 ) / + ESHIFT = H( ILAST, ILAST-1 ) / $ T( ILAST-1, ILAST-1 ) ELSE ESHIFT = ESHIFT + ONE / ( SAFMIN*DBLE( MAXIT ) ) @@ -759,6 +759,16 @@ $ T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1, $ S2, WR, WR2, WI ) * + IF ( ABS( (WR/S1)*T( ILAST, ILAST ) - H( ILAST, ILAST ) ) + $ .GT. ABS( (WR2/S2)*T( ILAST, ILAST ) + $ - H( ILAST, ILAST ) ) ) THEN + TEMP = WR + WR = WR2 + WR2 = TEMP + TEMP = S1 + S1 = S2 + S2 = TEMP + END IF TEMP = MAX( S1, SAFMIN*MAX( ONE, ABS( WR ), ABS( WI ) ) ) IF( WI.NE.ZERO ) $ GO TO 200 diff --git a/lapack-netlib/SRC/dhsein.f b/lapack-netlib/SRC/dhsein.f index d239a0ea8..b8244b828 100644 --- a/lapack-netlib/SRC/dhsein.f +++ b/lapack-netlib/SRC/dhsein.f @@ -108,6 +108,7 @@ *> \verbatim *> H is DOUBLE PRECISION array, dimension (LDH,N) *> The upper Hessenberg matrix H. +*> If a NaN is detected in H, the routine will return with INFO=-6. *> \endverbatim *> *> \param[in] LDH @@ -243,7 +244,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup doubleOTHERcomputational * @@ -262,10 +263,10 @@ $ VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, $ IFAILR, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER EIGSRC, INITV, SIDE @@ -291,9 +292,9 @@ $ WKR * .. * .. External Functions .. - LOGICAL LSAME + LOGICAL LSAME, DISNAN DOUBLE PRECISION DLAMCH, DLANHS - EXTERNAL LSAME, DLAMCH, DLANHS + EXTERNAL LSAME, DLAMCH, DLANHS, DISNAN * .. * .. External Subroutines .. EXTERNAL DLAEIN, XERBLA @@ -423,7 +424,10 @@ * has not ben computed before. * HNORM = DLANHS( 'I', KR-KL+1, H( KL, KL ), LDH, WORK ) - IF( HNORM.GT.ZERO ) THEN + IF( DISNAN( HNORM ) ) THEN + INFO = -6 + RETURN + ELSE IF( HNORM.GT.ZERO ) THEN EPS3 = HNORM*ULP ELSE EPS3 = SMLNUM diff --git a/lapack-netlib/SRC/dladiv.f b/lapack-netlib/SRC/dladiv.f index 306a6b002..c22d56d2c 100644 --- a/lapack-netlib/SRC/dladiv.f +++ b/lapack-netlib/SRC/dladiv.f @@ -36,8 +36,9 @@ *> p + i*q = --------- *> c + i*d *> -*> The algorithm is due to Robert L. Smith and can be found -*> in D. Knuth, The art of Computer Programming, Vol.2, p.195 +*> The algorithm is due to Michael Baudin and Robert L. Smith +*> and can be found in the paper +*> "A Robust Complex Division in Scilab" *> \endverbatim * * Arguments: @@ -83,17 +84,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date January 2013 * *> \ingroup auxOTHERauxiliary * * ===================================================================== SUBROUTINE DLADIV( A, B, C, D, P, Q ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* January 2013 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, D, P, Q @@ -101,28 +102,152 @@ * * ===================================================================== * +* .. Parameters .. + DOUBLE PRECISION BS + PARAMETER ( BS = 2.0D0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = 0.5D0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D0 ) +* * .. Local Scalars .. - DOUBLE PRECISION E, F + DOUBLE PRECISION AA, BB, CC, DD, AB, CD, S, OV, UN, BE, EPS +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLADIV1 * .. * .. Intrinsic Functions .. - INTRINSIC ABS + INTRINSIC ABS, MAX * .. * .. Executable Statements .. * - IF( ABS( D ).LT.ABS( C ) ) THEN - E = D / C - F = C + D*E - P = ( A+B*E ) / F - Q = ( B-A*E ) / F + AA = A + BB = B + CC = C + DD = D + AB = MAX( ABS(A), ABS(B) ) + CD = MAX( ABS(C), ABS(D) ) + S = 1.0D0 + + OV = DLAMCH( 'Overflow threshold' ) + UN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Epsilon' ) + BE = BS / (EPS*EPS) + + IF( AB >= HALF*OV ) THEN + AA = HALF * AA + BB = HALF * BB + S = TWO * S + END IF + IF( CD >= HALF*OV ) THEN + CC = HALF * CC + DD = HALF * DD + S = HALF * S + END IF + IF( AB <= UN*BS/EPS ) THEN + AA = AA * BE + BB = BB * BE + S = S / BE + END IF + IF( CD <= UN*BS/EPS ) THEN + CC = CC * BE + DD = DD * BE + S = S * BE + END IF + IF( ABS( D ).LE.ABS( C ) ) THEN + CALL DLADIV1(AA, BB, CC, DD, P, Q) ELSE - E = C / D - F = D + C*E - P = ( B+A*E ) / F - Q = ( -A+B*E ) / F + CALL DLADIV1(BB, AA, DD, CC, P, Q) + Q = -Q END IF + P = P * S + Q = Q * S * RETURN * * End of DLADIV * END + + + + SUBROUTINE DLADIV1( A, B, C, D, P, Q ) +* +* -- LAPACK auxiliary routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2013 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, D, P, Q +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* +* .. Local Scalars .. + DOUBLE PRECISION R, T +* .. +* .. External Functions .. + DOUBLE PRECISION DLADIV2 + EXTERNAL DLADIV2 +* .. +* .. Executable Statements .. +* + R = D / C + T = ONE / (C + D * R) + P = DLADIV2(A, B, C, D, R, T) + A = -A + Q = DLADIV2(B, A, C, D, R, T) +* + RETURN +* +* End of DLADIV1 +* + END + + DOUBLE PRECISION FUNCTION DLADIV2( A, B, C, D, R, T ) +* +* -- LAPACK auxiliary routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2013 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, D, R, T +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +* +* .. Local Scalars .. + DOUBLE PRECISION BR +* .. +* .. Executable Statements .. +* + IF( R.NE.ZERO ) THEN + BR = B * R + if( BR.NE.ZERO ) THEN + DLADIV2 = (A + BR) * T + ELSE + DLADIV2 = A * T + (B * T) * R + END IF + ELSE + DLADIV2 = (A + D * (B / C)) * T + END IF +* + RETURN +* +* End of DLADIV12 +* + END diff --git a/lapack-netlib/SRC/dlaqp2.f b/lapack-netlib/SRC/dlaqp2.f index 0c044366c..e138aeee1 100644 --- a/lapack-netlib/SRC/dlaqp2.f +++ b/lapack-netlib/SRC/dlaqp2.f @@ -122,7 +122,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup doubleOTHERauxiliary * @@ -149,10 +149,10 @@ SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. INTEGER LDA, M, N, OFFSET @@ -217,7 +217,7 @@ CALL DLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) ) END IF * - IF( I.LE.N ) THEN + IF( I.LT.N ) THEN * * Apply H(i)**T to A(offset+i:m,i+1:n) from the left. * diff --git a/lapack-netlib/SRC/dlarfb.f b/lapack-netlib/SRC/dlarfb.f index 17218478a..18ec9bfd7 100644 --- a/lapack-netlib/SRC/dlarfb.f +++ b/lapack-netlib/SRC/dlarfb.f @@ -159,7 +159,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2013 * *> \ingroup doubleOTHERauxiliary * @@ -195,10 +195,10 @@ SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2013 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS @@ -217,12 +217,11 @@ * .. * .. Local Scalars .. CHARACTER TRANST - INTEGER I, J, LASTV, LASTC, lastv2 + INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILADLR, ILADLC - EXTERNAL LSAME, ILADLR, ILADLC + EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DTRMM @@ -252,58 +251,53 @@ * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) -* - LASTV = MAX( K, ILADLR( M, K, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) * * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) * * W := C1**T * DO 10 J = 1, K - CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 10 CONTINUE * * W := W * V1 * - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN * -* W := W + C2**T *V2 +* W := W + C2**T * V2 * - CALL DGEMM( 'Transpose', 'No transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) + CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, + $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) END IF * * W := W * T**T or W * T * - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**T * - IF( LASTV.GT.K ) THEN + IF( M.GT.K ) THEN * * C2 := C2 - V2 * W**T * - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTV-K, LASTC, K, - $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, - $ C( K+1, 1 ), LDC ) + CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, + $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) END IF * * W := W * V1**T * - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, + $ ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**T * DO 30 J = 1, K - DO 20 I = 1, LASTC + DO 20 I = 1, N C( J, I ) = C( J, I ) - WORK( I, J ) 20 CONTINUE 30 CONTINUE @@ -311,58 +305,53 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLR( N, K, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C1 * DO 40 J = 1, K - CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 40 CONTINUE * * W := W * V1 * - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN * * W := W + C2 * V2 * - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) + CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**T * - IF( LASTV.GT.K ) THEN + IF( N.GT.K ) THEN * * C2 := C2 - W * V2**T * - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, - $ C( 1, K+1 ), LDC ) + CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) END IF * * W := W * V1**T * - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, + $ ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 60 J = 1, K - DO 50 I = 1, LASTC + DO 50 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 50 CONTINUE 60 CONTINUE @@ -378,36 +367,31 @@ * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) -* - LASTC = ILADLC( M, N, C, LDC ) * * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) * * W := C2**T * DO 70 J = 1, K - CALL DCOPY( LASTC, C( M-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) + CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 70 CONTINUE * * W := W * V2 * - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( M-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * -* W := W + C1**T*V1 +* W := W + C1**T * V1 * - CALL DGEMM( 'Transpose', 'No transpose', - $ LASTC, K, M-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**T or W * T * - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**T * @@ -415,57 +399,51 @@ * * C1 := C1 - V1 * W**T * - CALL DGEMM( 'No transpose', 'Transpose', - $ M-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) + CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, + $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2**T * - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( M-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W**T * DO 90 J = 1, K - DO 80 I = 1, LASTC - C( M-K+J, I ) = C( M-K+J, I ) - WORK(I, J) + DO 80 I = 1, N + C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) 80 CONTINUE 90 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTC = ILADLR( M, N, C, LDC ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C2 * DO 100 J = 1, K - CALL DCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) + CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 100 CONTINUE * * W := W * V2 * - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( N-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1 * - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, K, N-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**T * @@ -473,22 +451,20 @@ * * C1 := C1 - W * V1**T * - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) + CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2**T * - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( N-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, + $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W * DO 120 J = 1, K - DO 110 I = 1, LASTC - C( I, N-K+J ) = C( I, N-K+J ) - WORK(I, J) + DO 110 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 110 CONTINUE 120 CONTINUE END IF @@ -505,58 +481,53 @@ * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) -* - LASTV = MAX( K, ILADLC( K, M, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) * * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) * * W := C1**T * DO 130 J = 1, K - CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 130 CONTINUE * * W := W * V1**T * - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN * -* W := W + C2**T*V2**T +* W := W + C2**T * V2**T * - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) + CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, + $ WORK, LDWORK ) END IF * * W := W * T**T or W * T * - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**T * W**T * - IF( LASTV.GT.K ) THEN + IF( M.GT.K ) THEN * * C2 := C2 - V2**T * W**T * - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTV-K, LASTC, K, - $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, - $ ONE, C( K+1, 1 ), LDC ) + CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, + $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) END IF * * W := W * V1 * - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**T * DO 150 J = 1, K - DO 140 I = 1, LASTC + DO 140 I = 1, N C( J, I ) = C( J, I ) - WORK( I, J ) 140 CONTINUE 150 CONTINUE @@ -564,58 +535,53 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLC( K, N, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) * * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) * * W := C1 * DO 160 J = 1, K - CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 160 CONTINUE * * W := W * V1**T * - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, + $ ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN * * W := W + C2 * V2**T * - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) + CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, + $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, + $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * - IF( LASTV.GT.K ) THEN + IF( N.GT.K ) THEN * * C2 := C2 - W * V2 * - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, - $ ONE, C( 1, K+1 ), LDC ) + CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) END IF * * W := W * V1 * - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 180 J = 1, K - DO 170 I = 1, LASTC + DO 170 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 170 CONTINUE 180 CONTINUE @@ -631,36 +597,31 @@ * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) -* - LASTC = ILADLC( M, N, C, LDC ) * * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) * * W := C2**T * DO 190 J = 1, K - CALL DCOPY( LASTC, C( M-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) + CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 190 CONTINUE * * W := W * V2**T * - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( 1, M-K+1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, + $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C1**T * V1**T * - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTC, K, M-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**T or W * T * - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**T * W**T * @@ -668,58 +629,51 @@ * * C1 := C1 - V1**T * W**T * - CALL DGEMM( 'Transpose', 'Transpose', - $ M-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) + CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, + $ V, LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2 * - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, M-K+1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W**T * DO 210 J = 1, K - DO 200 I = 1, LASTC - C( M-K+J, I ) = C( M-K+J, I ) - WORK(I, J) + DO 200 I = 1, N + C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) 200 CONTINUE 210 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTC = ILADLR( M, N, C, LDC ) +* Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) * * W := C2 * DO 220 J = 1, K - CALL DCOPY( LASTC, C( 1, N-K+J ), 1, - $ WORK( 1, J ), 1 ) + CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 220 CONTINUE * * W := W * V2**T * - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( 1, N-K+1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, + $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1**T * - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, K, N-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * @@ -727,22 +681,20 @@ * * C1 := C1 - W * V1 * - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) + CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2 * - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, N-K+1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 240 J = 1, K - DO 230 I = 1, LASTC - C( I, N-K+J ) = C( I, N-K+J ) - WORK(I, J) + DO 230 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 230 CONTINUE 240 CONTINUE * diff --git a/lapack-netlib/SRC/dlasd4.f b/lapack-netlib/SRC/dlasd4.f index 838f7162d..71b6f7925 100644 --- a/lapack-netlib/SRC/dlasd4.f +++ b/lapack-netlib/SRC/dlasd4.f @@ -140,7 +140,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup auxOTHERauxiliary * @@ -153,10 +153,10 @@ * ===================================================================== SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. INTEGER I, INFO, N diff --git a/lapack-netlib/SRC/dlasyf.f b/lapack-netlib/SRC/dlasyf.f index b16f2701d..de705e4ab 100644 --- a/lapack-netlib/SRC/dlasyf.f +++ b/lapack-netlib/SRC/dlasyf.f @@ -1,25 +1,25 @@ -*> \brief \b DLASYF computes a partial factorization of a real symmetric matrix, using the diagonal pivoting method. +*> \brief \b DLASYF computes a partial factorization of a real symmetric matrix using the Bunch-Kaufman diagonal pivoting method. * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLASYF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLASYF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KB, LDA, LDW, N, NB @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), W( LDW, * ) * .. -* +* * *> \par Purpose: * ============= @@ -109,16 +109,26 @@ *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D. -*> If UPLO = 'U', only the last KB elements of IPIV are set; -*> if UPLO = 'L', only the first KB elements are set. *> -*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were -*> interchanged and D(k,k) is a 1-by-1 diagonal block. -*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and -*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) -*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = -*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were -*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> If UPLO = 'U': +*> Only the last KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns +*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) +*> is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> Only the first KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns +*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1) +*> is a 2-by-2 diagonal block. *> \endverbatim *> *> \param[out] W @@ -144,22 +154,32 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup doubleSYcomputational * +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> \endverbatim +* * ===================================================================== SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER UPLO @@ -237,7 +257,8 @@ ABSAKK = ABS( W( K, KW ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. * IF( K.GT.1 ) THEN IMAX = IDAMAX( K-1, W( 1, KW ), 1 ) @@ -248,7 +269,7 @@ * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * -* Column K is zero: set INFO and continue +* Column K is zero or underflow: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K @@ -293,7 +314,7 @@ * KP = IMAX * -* copy column KW-1 of W to column KW +* copy column KW-1 of W to column KW of W * CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) ELSE @@ -305,60 +326,118 @@ KSTEP = 2 END IF END IF +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped * KK = K - KSTEP + 1 +* +* KKW is the column of W which corresponds to column KK of A +* KKW = NB + KK - N * -* Updated column KP is already stored in column KKW of W +* Interchange rows and columns KP and KK. +* Updated column KP is already stored in column KKW of W. * IF( KP.NE.KK ) THEN * -* Copy non-updated column KK to column KP +* Copy non-updated column KK to column KP of submatrix A +* at step K. No need to copy element into column K +* (or K and K-1 for 2-by-2 pivot) of A, since these columns +* will be later overwritten. * - A( KP, K ) = A( KK, K ) - CALL DCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), + A( KP, KP ) = A( KK, KK ) + CALL DCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), $ LDA ) - CALL DCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 ) + IF( KP.GT.1 ) + $ CALL DCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) * -* Interchange rows KK and KP in last KK columns of A and W +* Interchange rows KK and KP in last K+1 to N columns of A +* (columns K (or K and K-1 for 2-by-2 pivot) of A will be +* later overwritten). Interchange rows KK and KP +* in last KKW to NB columns of W. * - CALL DSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA ) + IF( K.LT.N ) + $ CALL DSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ), + $ LDA ) CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), $ LDW ) END IF * IF( KSTEP.EQ.1 ) THEN * -* 1-by-1 pivot block D(k): column KW of W now holds +* 1-by-1 pivot block D(k): column kw of W now holds * -* W(k) = U(k)*D(k) +* W(kw) = U(k)*D(k), * * where U(k) is the k-th column of U * -* Store U(k) in column k of A +* Store subdiag. elements of column U(k) +* and 1-by-1 block D(k) in column k of A. +* NOTE: Diagonal element U(k,k) is a UNIT element +* and not stored. +* A(k,k) := D(k,k) = W(k,kw) +* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k) * CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) R1 = ONE / A( K, K ) CALL DSCAL( K-1, R1, A( 1, K ), 1 ) +* ELSE * -* 2-by-2 pivot block D(k): columns KW and KW-1 of W now -* hold +* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold * -* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k) * * where U(k) and U(k-1) are the k-th and (k-1)-th columns * of U +* +* Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2 +* block D(k-1:k,k-1:k) in columns k-1 and k of A. +* NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT +* block and not stored. +* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw) +* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) = +* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) ) * IF( K.GT.2 ) THEN * -* Store U(k) and U(k-1) in columns k and k-1 of A +* Compose the columns of the inverse of 2-by-2 pivot +* block D in the following way to reduce the number +* of FLOPS when we myltiply panel ( W(kw-1) W(kw) ) by +* this inverse +* +* D**(-1) = ( d11 d21 )**(-1) = +* ( d21 d22 ) +* +* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = +* ( (-d21 ) ( d11 ) ) +* +* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * +* +* * ( ( d22/d21 ) ( -1 ) ) = +* ( ( -1 ) ( d11/d21 ) ) +* +* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = 1/d21 * T * ( ( D11 ) ( -1 ) ) +* ( ( -1 ) ( D22 ) ) +* +* = D21 * ( ( D11 ) ( -1 ) ) +* ( ( -1 ) ( D22 ) ) * D21 = W( K-1, KW ) D11 = W( K, KW ) / D21 D22 = W( K-1, KW-1 ) / D21 T = ONE / ( D11*D22-ONE ) D21 = T / D21 +* +* Update elements in columns A(k-1) and A(k) as +* dot products of rows of ( W(kw-1) W(kw) ) and columns +* of D**(-1) +* DO 20 J = 1, K - 2 A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) ) @@ -370,7 +449,9 @@ A( K-1, K-1 ) = W( K-1, KW-1 ) A( K-1, K ) = W( K-1, KW ) A( K, K ) = W( K, KW ) +* END IF +* END IF * * Store details of the interchanges in IPIV @@ -414,20 +495,28 @@ 50 CONTINUE * * Put U12 in standard form by partially undoing the interchanges -* in columns k+1:n +* in columns k+1:n looping backwards from k+1 to n * J = K + 1 60 CONTINUE - JJ = J - JP = IPIV( J ) - IF( JP.LT.0 ) THEN - JP = -JP +* +* Undo the interchanges (if any) of rows JJ and JP at each +* step J +* +* (Here, J is a diagonal index) + JJ = J + JP = IPIV( J ) + IF( JP.LT.0 ) THEN + JP = -JP +* (Here, J is a diagonal index) + J = J + 1 + END IF +* (NOTE: Here, J is used to determine row length. Length N-J+1 +* of the rows to swap back doesn't include diagonal element) J = J + 1 - END IF - J = J + 1 - IF( JP.NE.JJ .AND. J.LE.N ) - $ CALL DSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA ) - IF( J.LE.N ) + IF( JP.NE.JJ .AND. J.LE.N ) + $ CALL DSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA ) + IF( J.LT.N ) $ GO TO 60 * * Set KB to the number of columns factorized @@ -464,7 +553,8 @@ ABSAKK = ABS( W( K, K ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. * IF( K.LT.N ) THEN IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 ) @@ -475,7 +565,7 @@ * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * -* Column K is zero: set INFO and continue +* Column K is zero or underflow: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K @@ -518,7 +608,7 @@ * KP = IMAX * -* copy column K+1 of W to column K +* copy column K+1 of W to column K of W * CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) ELSE @@ -530,22 +620,36 @@ KSTEP = 2 END IF END IF +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped * KK = K + KSTEP - 1 * -* Updated column KP is already stored in column KK of W +* Interchange rows and columns KP and KK. +* Updated column KP is already stored in column KK of W. * IF( KP.NE.KK ) THEN * -* Copy non-updated column KK to column KP +* Copy non-updated column KK to column KP of submatrix A +* at step K. No need to copy element into column K +* (or K and K+1 for 2-by-2 pivot) of A, since these columns +* will be later overwritten. * - A( KP, K ) = A( KK, K ) - CALL DCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA ) - CALL DCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 ) + A( KP, KP ) = A( KK, KK ) + CALL DCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ LDA ) + IF( KP.LT.N ) + $ CALL DCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) * -* Interchange rows KK and KP in first KK columns of A and W +* Interchange rows KK and KP in first K-1 columns of A +* (columns K (or K and K+1 for 2-by-2 pivot) of A will be +* later overwritten). Interchange rows KK and KP +* in first KK columns of W. * - CALL DSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) + IF( K.GT.1 ) + $ CALL DSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) END IF * @@ -553,17 +657,23 @@ * * 1-by-1 pivot block D(k): column k of W now holds * -* W(k) = L(k)*D(k) +* W(k) = L(k)*D(k), * * where L(k) is the k-th column of L * -* Store L(k) in column k of A +* Store subdiag. elements of column L(k) +* and 1-by-1 block D(k) in column k of A. +* (NOTE: Diagonal element L(k,k) is a UNIT element +* and not stored) +* A(k,k) := D(k,k) = W(k,k) +* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k) * CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) IF( K.LT.N ) THEN R1 = ONE / A( K, K ) CALL DSCAL( N-K, R1, A( K+1, K ), 1 ) END IF +* ELSE * * 2-by-2 pivot block D(k): columns k and k+1 of W now hold @@ -572,16 +682,52 @@ * * where L(k) and L(k+1) are the k-th and (k+1)-th columns * of L +* +* Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2 +* block D(k:k+1,k:k+1) in columns k and k+1 of A. +* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT +* block and not stored) +* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1) +* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) = +* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) ) * IF( K.LT.N-1 ) THEN * -* Store L(k) and L(k+1) in columns k and k+1 of A +* Compose the columns of the inverse of 2-by-2 pivot +* block D in the following way to reduce the number +* of FLOPS when we myltiply panel ( W(k) W(k+1) ) by +* this inverse +* +* D**(-1) = ( d11 d21 )**(-1) = +* ( d21 d22 ) +* +* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = +* ( (-d21 ) ( d11 ) ) +* +* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * +* +* * ( ( d22/d21 ) ( -1 ) ) = +* ( ( -1 ) ( d11/d21 ) ) +* +* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = 1/d21 * T * ( ( D11 ) ( -1 ) ) +* ( ( -1 ) ( D22 ) ) +* +* = D21 * ( ( D11 ) ( -1 ) ) +* ( ( -1 ) ( D22 ) ) * D21 = W( K+1, K ) D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / D21 T = ONE / ( D11*D22-ONE ) D21 = T / D21 +* +* Update elements in columns A(k) and A(k+1) as +* dot products of rows of ( W(k) W(k+1) ) and columns +* of D**(-1) +* DO 80 J = K + 2, N A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) ) A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) @@ -593,7 +739,9 @@ A( K, K ) = W( K, K ) A( K+1, K ) = W( K+1, K ) A( K+1, K+1 ) = W( K+1, K+1 ) +* END IF +* END IF * * Store details of the interchanges in IPIV @@ -638,20 +786,28 @@ 110 CONTINUE * * Put L21 in standard form by partially undoing the interchanges -* in columns 1:k-1 +* of rows in columns 1:k-1 looping backwards from k-1 to 1 * J = K - 1 120 CONTINUE - JJ = J - JP = IPIV( J ) - IF( JP.LT.0 ) THEN - JP = -JP +* +* Undo the interchanges (if any) of rows JJ and JP at each +* step J +* +* (Here, J is a diagonal index) + JJ = J + JP = IPIV( J ) + IF( JP.LT.0 ) THEN + JP = -JP +* (Here, J is a diagonal index) + J = J - 1 + END IF +* (NOTE: Here, J is used to determine row length. Length J +* of the rows to swap back doesn't include diagonal element) J = J - 1 - END IF - J = J - 1 - IF( JP.NE.JJ .AND. J.GE.1 ) - $ CALL DSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA ) - IF( J.GE.1 ) + IF( JP.NE.JJ .AND. J.GE.1 ) + $ CALL DSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA ) + IF( J.GT.1 ) $ GO TO 120 * * Set KB to the number of columns factorized diff --git a/lapack-netlib/SRC/dlasyf_rook.f b/lapack-netlib/SRC/dlasyf_rook.f new file mode 100644 index 000000000..49ee7a6c9 --- /dev/null +++ b/lapack-netlib/SRC/dlasyf_rook.f @@ -0,0 +1,892 @@ +*> \brief \b DLASYF_ROOK *> DLASYF_ROOK computes a partial factorization of a real symmetric matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASYF_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) +* +* .. Scalar Arguments .. +* CHARADLATER UPLO +* INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), W( LDW, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLASYF_ROOK computes a partial factorization of a real symmetric +*> matrix A using the bounded Bunch-Kaufman ("rook") diagonal +*> pivoting method. The partial factorization has the form: +*> +*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: +*> ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) +*> +*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L' +*> ( L21 I ) ( 0 A22 ) ( 0 I ) +*> +*> where the order of D is at most NB. The actual order is returned in +*> the argument KB, and is either NB or NB-1, or N if N <= NB. +*> +*> DLASYF_ROOK is an auxiliary routine called by DSYTRF_ROOK. It uses +*> blocked code (calling Level 3 BLAS) to update the submatrix +*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The maximum number of columns of the matrix A that should be +*> factored. NB should be at least 2 to allow for 2-by-2 pivot +*> blocks. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> The number of columns of A that were actually factored. +*> KB is either NB-1 or NB, or N if N <= NB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> n-by-n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading n-by-n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> On exit, A contains details of the partial factorization. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> Only the last KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> Only the first KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (LDW,NB) +*> \endverbatim +*> +*> \param[in] LDW +*> \verbatim +*> LDW is INTEGER +*> The leading dimension of the array W. LDW >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, + $ INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), W( LDW, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL DONE + INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, JP1, JP2, K, KK, + $ KW, KKW, KP, KSTEP, P, II + + DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, + $ DTEMP, R1, ROWMAX, T, SFMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, IDAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DSCAL, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = DLAMCH( 'S' ) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Factorize the trailing columns of A using the upper triangle +* of A and working backwards, and compute the matrix W = U12*D +* for use in updating A11 +* +* K is the main loop index, decreasing from N in steps of 1 or 2 +* + K = N + 10 CONTINUE +* +* KW is the column of W which corresponds to column K of A +* + KW = NB + K - N +* +* Exit from loop +* + IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) + $ GO TO 30 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column KW of W and update it +* + CALL DCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 ) + IF( K.LT.N ) + $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), + $ LDA, W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 ) +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( W( K, KW ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = IDAMAX( K-1, W( 1, KW ), 1 ) + COLMAX = ABS( W( IMAX, KW ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) + ELSE +* +* ============================================================ +* +* Test for interchange +* +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* Begin pivot search loop body +* +* +* Copy column IMAX to column KW-1 of W and update it +* + CALL DCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 ) + CALL DCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, + $ W( IMAX+1, KW-1 ), 1 ) +* + IF( K.LT.N ) + $ CALL DGEMV( 'No transpose', K, N-K, -ONE, + $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW, + $ ONE, W( 1, KW-1 ), 1 ) +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + IDAMAX( K-IMAX, W( IMAX+1, KW-1 ), + $ 1 ) + ROWMAX = ABS( W( JMAX, KW-1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = IDAMAX( IMAX-1, W( 1, KW-1 ), 1 ) + DTEMP = ABS( W( ITEMP, KW-1 ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for +* ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.(ABS( W( IMAX, KW-1 ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column KW-1 of W to column KW of W +* + CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K-1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 12 +* + END IF +* +* ============================================================ +* + KK = K - KSTEP + 1 +* +* KKW is the column of W which corresponds to column KK of A +* + KKW = NB + KK - N +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P +* + CALL DCOPY( K-P, A( P+1, K ), 1, A( P, P+1 ), LDA ) + CALL DCOPY( P, A( 1, K ), 1, A( 1, P ), 1 ) +* +* Interchange rows K and P in last N-K+1 columns of A +* and last N-K+2 columns of W +* + CALL DSWAP( N-K+1, A( K, K ), LDA, A( P, K ), LDA ) + CALL DSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), LDW ) + END IF +* +* Updated column KP is already stored in column KKW of W +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP +* + A( KP, K ) = A( KK, K ) + CALL DCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + CALL DCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 ) +* +* Interchange rows KK and KP in last N-KK+1 columns +* of A and W +* + CALL DSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA ) + CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), + $ LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column KW of W now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* +* Store U(k) in column k of A +* + CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) + IF( K.GT.1 ) THEN + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN + R1 = ONE / A( K, K ) + CALL DSCAL( K-1, R1, A( 1, K ), 1 ) + ELSE IF( A( K, K ).NE.ZERO ) THEN + DO 14 II = 1, K - 1 + A( II, K ) = A( II, K ) / A( K, K ) + 14 CONTINUE + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns KW and KW-1 of W now +* hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* + IF( K.GT.2 ) THEN +* +* Store U(k) and U(k-1) in columns k and k-1 of A +* + D12 = W( K-1, KW ) + D11 = W( K, KW ) / D12 + D22 = W( K-1, KW-1 ) / D12 + T = ONE / ( D11*D22-ONE ) + DO 20 J = 1, K - 2 + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D12 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D12 ) + 20 CONTINUE + END IF +* +* Copy D(k) to A +* + A( K-1, K-1 ) = W( K-1, KW-1 ) + A( K-1, K ) = W( K-1, KW ) + A( K, K ) = W( K, KW ) + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + 30 CONTINUE +* +* Update the upper triangle of A11 (= A(1:k,1:k)) as +* +* A11 := A11 - U12*D*U12**T = A11 - U12*W**T +* +* computing blocks of NB columns at a time +* + DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB + JB = MIN( NB, K-J+1 ) +* +* Update the upper triangle of the diagonal block +* + DO 40 JJ = J, J + JB - 1 + CALL DGEMV( 'No transpose', JJ-J+1, N-K, -ONE, + $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE, + $ A( J, JJ ), 1 ) + 40 CONTINUE +* +* Update the rectangular superdiagonal block +* + IF( J.GE.2 ) + $ CALL DGEMM( 'No transpose', 'Transpose', J-1, JB, + $ N-K, -ONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, + $ ONE, A( 1, J ), LDA ) + 50 CONTINUE +* +* Put U12 in standard form by partially undoing the interchanges +* in columns k+1:n +* + J = K + 1 + 60 CONTINUE +* + KSTEP = 1 + JP1 = 1 + JJ = J + JP2 = IPIV( J ) + IF( JP2.LT.0 ) THEN + JP2 = -JP2 + J = J + 1 + JP1 = -IPIV( J ) + KSTEP = 2 + END IF +* + J = J + 1 + IF( JP2.NE.JJ .AND. J.LE.N ) + $ CALL DSWAP( N-J+1, A( JP2, J ), LDA, A( JJ, J ), LDA ) + JJ = J - 1 + IF( JP1.NE.JJ .AND. KSTEP.EQ.2 ) + $ CALL DSWAP( N-J+1, A( JP1, J ), LDA, A( JJ, J ), LDA ) + IF( J.LE.N ) + $ GO TO 60 +* +* Set KB to the number of columns factorized +* + KB = N - K +* + ELSE +* +* Factorize the leading columns of A using the lower triangle +* of A and working forwards, and compute the matrix W = L21*D +* for use in updating A22 +* +* K is the main loop index, increasing from 1 in steps of 1 or 2 +* + K = 1 + 70 CONTINUE +* +* Exit from loop +* + IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) + $ GO TO 90 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column K of W and update it +* + CALL DCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 ) + IF( K.GT.1 ) + $ CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), + $ LDA, W( K, 1 ), LDW, ONE, W( K, K ), 1 ) +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( W( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 ) + COLMAX = ABS( W( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) + ELSE +* +* ============================================================ +* +* Test for interchange +* +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 72 CONTINUE +* +* Begin pivot search loop body +* +* +* Copy column IMAX to column K+1 of W and update it +* + CALL DCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1) + CALL DCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, + $ W( IMAX, K+1 ), 1 ) + IF( K.GT.1 ) + $ CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, + $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW, + $ ONE, W( K, K+1 ), 1 ) +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + IDAMAX( IMAX-K, W( K, K+1 ), 1 ) + ROWMAX = ABS( W( JMAX, K+1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + IDAMAX( N-IMAX, W( IMAX+1, K+1 ), 1) + DTEMP = ABS( W( ITEMP, K+1 ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for +* ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABS( W( IMAX, K+1 ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column K+1 of W to column K of W +* + CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 72 +* + END IF +* +* ============================================================ +* + KK = K + KSTEP - 1 +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P +* + CALL DCOPY( P-K, A( K, K ), 1, A( P, K ), LDA ) + CALL DCOPY( N-P+1, A( P, K ), 1, A( P, P ), 1 ) +* +* Interchange rows K and P in first K columns of A +* and first K+1 columns of W +* + CALL DSWAP( K, A( K, 1 ), LDA, A( P, 1 ), LDA ) + CALL DSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW ) + END IF +* +* Updated column KP is already stored in column KK of W +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP +* + A( KP, K ) = A( KK, K ) + CALL DCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA ) + CALL DCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 ) +* +* Interchange rows KK and KP in first KK columns of A and W +* + CALL DSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) + CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k of W now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* +* Store L(k) in column k of A +* + CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) + IF( K.LT.N ) THEN + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN + R1 = ONE / A( K, K ) + CALL DSCAL( N-K, R1, A( K+1, K ), 1 ) + ELSE IF( A( K, K ).NE.ZERO ) THEN + DO 74 II = K + 1, N + A( II, K ) = A( II, K ) / A( K, K ) + 74 CONTINUE + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 of W now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* + IF( K.LT.N-1 ) THEN +* +* Store L(k) and L(k+1) in columns k and k+1 of A +* + D21 = W( K+1, K ) + D11 = W( K+1, K+1 ) / D21 + D22 = W( K, K ) / D21 + T = ONE / ( D11*D22-ONE ) + DO 80 J = K + 2, N + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) + 80 CONTINUE + END IF +* +* Copy D(k) to A +* + A( K, K ) = W( K, K ) + A( K+1, K ) = W( K+1, K ) + A( K+1, K+1 ) = W( K+1, K+1 ) + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 70 +* + 90 CONTINUE +* +* Update the lower triangle of A22 (= A(k:n,k:n)) as +* +* A22 := A22 - L21*D*L21**T = A22 - L21*W**T +* +* computing blocks of NB columns at a time +* + DO 110 J = K, N, NB + JB = MIN( NB, N-J+1 ) +* +* Update the lower triangle of the diagonal block +* + DO 100 JJ = J, J + JB - 1 + CALL DGEMV( 'No transpose', J+JB-JJ, K-1, -ONE, + $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE, + $ A( JJ, JJ ), 1 ) + 100 CONTINUE +* +* Update the rectangular subdiagonal block +* + IF( J+JB.LE.N ) + $ CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, + $ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW, + $ ONE, A( J+JB, J ), LDA ) + 110 CONTINUE +* +* Put L21 in standard form by partially undoing the interchanges +* in columns 1:k-1 +* + J = K - 1 + 120 CONTINUE +* + KSTEP = 1 + JP1 = 1 + JJ = J + JP2 = IPIV( J ) + IF( JP2.LT.0 ) THEN + JP2 = -JP2 + J = J - 1 + JP1 = -IPIV( J ) + KSTEP = 2 + END IF +* + J = J - 1 + IF( JP2.NE.JJ .AND. J.GE.1 ) + $ CALL DSWAP( J, A( JP2, 1 ), LDA, A( JJ, 1 ), LDA ) + JJ = J + 1 + IF( JP1.NE.JJ .AND. KSTEP.EQ.2 ) + $ CALL DSWAP( J, A( JP1, 1 ), LDA, A( JJ, 1 ), LDA ) + IF( J.GE.1 ) + $ GO TO 120 +* +* Set KB to the number of columns factorized +* + KB = K - 1 +* + END IF + RETURN +* +* End of DLASYF_ROOK +* + END diff --git a/lapack-netlib/SRC/dorbdb.f b/lapack-netlib/SRC/dorbdb.f index 5580f4ee8..9b56bf08c 100644 --- a/lapack-netlib/SRC/dorbdb.f +++ b/lapack-netlib/SRC/dorbdb.f @@ -255,7 +255,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup doubleOTHERcomputational * @@ -287,10 +287,10 @@ $ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, $ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER SIGNS, TRANS @@ -415,19 +415,36 @@ THETA(I) = ATAN2( DNRM2( M-P-I+1, X21(I,I), 1 ), $ DNRM2( P-I+1, X11(I,I), 1 ) ) * - CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + IF( P .GT. I ) THEN + CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + ELSE IF( P .EQ. I ) THEN + CALL DLARFGP( P-I+1, X11(I,I), X11(I,I), 1, TAUP1(I) ) + END IF X11(I,I) = ONE - CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + IF ( M-P .GT. I ) THEN + CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, + $ TAUP2(I) ) + ELSE IF ( M-P .EQ. I ) THEN + CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1, TAUP2(I) ) + END IF X21(I,I) = ONE * - CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), - $ X11(I,I+1), LDX11, WORK ) - CALL DLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, TAUP1(I), - $ X12(I,I), LDX12, WORK ) - CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), - $ X21(I,I+1), LDX21, WORK ) - CALL DLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, TAUP2(I), - $ X22(I,I), LDX22, WORK ) + IF ( Q .GT. I ) THEN + CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), + $ X11(I,I+1), LDX11, WORK ) + END IF + IF ( M-Q+1 .GT. I ) THEN + CALL DLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, TAUP1(I), + $ X12(I,I), LDX12, WORK ) + END IF + IF ( Q .GT. I ) THEN + CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), + $ X21(I,I+1), LDX21, WORK ) + END IF + IF ( M-Q+1 .GT. I ) THEN + CALL DLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, TAUP2(I), + $ X22(I,I), LDX22, WORK ) + END IF * IF( I .LT. Q ) THEN CALL DSCAL( Q-I, -Z1*Z3*SIN(THETA(I)), X11(I,I+1), @@ -444,12 +461,24 @@ $ DNRM2( M-Q-I+1, X12(I,I), LDX12 ) ) * IF( I .LT. Q ) THEN - CALL DLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11, - $ TAUQ1(I) ) + IF ( Q-I .EQ. 1 ) THEN + CALL DLARFGP( Q-I, X11(I,I+1), X11(I,I+1), LDX11, + $ TAUQ1(I) ) + ELSE + CALL DLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11, + $ TAUQ1(I) ) + END IF X11(I,I+1) = ONE END IF - CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, - $ TAUQ2(I) ) + IF ( Q+I-1 .LT. M ) THEN + IF ( M-Q .EQ. I ) THEN + CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12, + $ TAUQ2(I) ) + ELSE + CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, + $ TAUQ2(I) ) + END IF + END IF X12(I,I) = ONE * IF( I .LT. Q ) THEN @@ -458,10 +487,14 @@ CALL DLARF( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I), $ X21(I+1,I+1), LDX21, WORK ) END IF - CALL DLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), - $ X12(I+1,I), LDX12, WORK ) - CALL DLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), - $ X22(I+1,I), LDX22, WORK ) + IF ( P .GT. I ) THEN + CALL DLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), + $ X12(I+1,I), LDX12, WORK ) + END IF + IF ( M-P .GT. I ) THEN + CALL DLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), X22(I+1,I), LDX22, WORK ) + END IF * END DO * @@ -470,12 +503,19 @@ DO I = Q + 1, P * CALL DSCAL( M-Q-I+1, -Z1*Z4, X12(I,I), LDX12 ) - CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, - $ TAUQ2(I) ) + IF ( I .GE. M-Q ) THEN + CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12, + $ TAUQ2(I) ) + ELSE + CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, + $ TAUQ2(I) ) + END IF X12(I,I) = ONE * - CALL DLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), - $ X12(I+1,I), LDX12, WORK ) + IF ( P. GT. I ) THEN + CALL DLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), + $ X12(I+1,I), LDX12, WORK ) + END IF IF( M-P-Q .GE. 1 ) $ CALL DLARF( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12, $ TAUQ2(I), X22(Q+1,I), LDX22, WORK ) @@ -487,11 +527,18 @@ DO I = 1, M - P - Q * CALL DSCAL( M-P-Q-I+1, Z2*Z4, X22(Q+I,P+I), LDX22 ) - CALL DLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I+1), - $ LDX22, TAUQ2(P+I) ) + IF ( I .EQ. M-P-Q ) THEN + CALL DLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I), + $ LDX22, TAUQ2(P+I) ) + ELSE + CALL DLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I+1), + $ LDX22, TAUQ2(P+I) ) + END IF X22(Q+I,P+I) = ONE - CALL DLARF( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), LDX22, - $ TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, WORK ) + IF ( I .LT. M-P-Q ) THEN + CALL DLARF( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), LDX22, + $ TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, WORK ) + END IF * END DO * @@ -521,18 +568,31 @@ * CALL DLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, TAUP1(I) ) X11(I,I) = ONE - CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21, + IF ( I .EQ. M-P ) THEN + CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I), LDX21, + $ TAUP2(I) ) + ELSE + CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21, $ TAUP2(I) ) + END IF X21(I,I) = ONE * - CALL DLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I), - $ X11(I+1,I), LDX11, WORK ) - CALL DLARF( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, TAUP1(I), - $ X12(I,I), LDX12, WORK ) - CALL DLARF( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, TAUP2(I), - $ X21(I+1,I), LDX21, WORK ) - CALL DLARF( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21, - $ TAUP2(I), X22(I,I), LDX22, WORK ) + IF ( Q .GT. I ) THEN + CALL DLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I), + $ X11(I+1,I), LDX11, WORK ) + END IF + IF ( M-Q+1 .GT. I ) THEN + CALL DLARF( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, + $ TAUP1(I), X12(I,I), LDX12, WORK ) + END IF + IF ( Q .GT. I ) THEN + CALL DLARF( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, TAUP2(I), + $ X21(I+1,I), LDX21, WORK ) + END IF + IF ( M-Q+1 .GT. I ) THEN + CALL DLARF( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21, + $ TAUP2(I), X22(I,I), LDX22, WORK ) + END IF * IF( I .LT. Q ) THEN CALL DSCAL( Q-I, -Z1*Z3*SIN(THETA(I)), X11(I+1,I), 1 ) @@ -548,10 +608,22 @@ $ DNRM2( M-Q-I+1, X12(I,I), 1 ) ) * IF( I .LT. Q ) THEN - CALL DLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1, TAUQ1(I) ) + IF ( Q-I .EQ. 1) THEN + CALL DLARFGP( Q-I, X11(I+1,I), X11(I+1,I), 1, + $ TAUQ1(I) ) + ELSE + CALL DLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1, + $ TAUQ1(I) ) + END IF X11(I+1,I) = ONE END IF - CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) ) + IF ( M-Q .GT. I ) THEN + CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, + $ TAUQ2(I) ) + ELSE + CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I), 1, + $ TAUQ2(I) ) + END IF X12(I,I) = ONE * IF( I .LT. Q ) THEN @@ -562,8 +634,10 @@ END IF CALL DLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I), $ X12(I,I+1), LDX12, WORK ) - CALL DLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, TAUQ2(I), - $ X22(I,I+1), LDX22, WORK ) + IF ( M-P-I .GT. 0 ) THEN + CALL DLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, TAUQ2(I), + $ X22(I,I+1), LDX22, WORK ) + END IF * END DO * @@ -575,8 +649,10 @@ CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) ) X12(I,I) = ONE * - CALL DLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I), + IF ( P .GT. I ) THEN + CALL DLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I), $ X12(I,I+1), LDX12, WORK ) + END IF IF( M-P-Q .GE. 1 ) $ CALL DLARF( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1, TAUQ2(I), $ X22(I,Q+1), LDX22, WORK ) @@ -588,12 +664,16 @@ DO I = 1, M - P - Q * CALL DSCAL( M-P-Q-I+1, Z2*Z4, X22(P+I,Q+I), 1 ) - CALL DLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), 1, - $ TAUQ2(P+I) ) - X22(P+I,Q+I) = ONE -* - CALL DLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1, + IF ( M-P-Q .EQ. I ) THEN + CALL DLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I,Q+I), 1, + $ TAUQ2(P+I) ) + ELSE + CALL DLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), 1, + $ TAUQ2(P+I) ) + CALL DLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1, $ TAUQ2(P+I), X22(P+I,Q+I+1), LDX22, WORK ) + END IF + X22(P+I,Q+I) = ONE * END DO * diff --git a/lapack-netlib/SRC/dorbdb1.f b/lapack-netlib/SRC/dorbdb1.f new file mode 100644 index 000000000..b5675f71d --- /dev/null +++ b/lapack-netlib/SRC/dorbdb1.f @@ -0,0 +1,324 @@ +*> \brief \b DORBDB1 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORBDB1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION PHI(*), THETA(*) +* DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> DORBDB1 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonomal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. Q must be no larger than P, +*> M-P, or M-Q. Routines DORBDB2, DORBDB3, and DORBDB4 handle cases in +*> which Q is not the minimum dimension. +*> +*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are Q-by-Q bidiagonal matrices represented implicitly by +*> angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= +*> MIN(P,M-P,M-Q). +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is DOUBLE PRECISION array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is DOUBLE PRECISION array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is DOUBLE PRECISION array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +*> +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or DORCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR +*> and DORGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + DOUBLE PRECISION PHI(*), THETA(*) + DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, + $ LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( P .LT. Q .OR. M-P .LT. Q ) THEN + INFO = -2 + ELSE IF( Q .LT. 0 .OR. M-Q .LT. Q ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( P-1, M-P-1, Q-1 ) + IORBDB5 = 2 + LORBDB5 = Q-2 + LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'DORBDB1', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce columns 1, ..., Q of X11 and X21 +* + DO I = 1, Q +* + CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + THETA(I) = ATAN2( X21(I,I), X11(I,I) ) + C = COS( THETA(I) ) + S = SIN( THETA(I) ) + X11(I,I) = ONE + X21(I,I) = ONE + CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1), + $ LDX11, WORK(ILARF) ) + CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), + $ X21(I,I+1), LDX21, WORK(ILARF) ) +* + IF( I .LT. Q ) THEN + CALL DROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C, S ) + CALL DLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, TAUQ1(I) ) + S = X21(I,I+1) + X21(I,I+1) = ONE + CALL DLARF( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), + $ X11(I+1,I+1), LDX11, WORK(ILARF) ) + CALL DLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), + $ X21(I+1,I+1), LDX21, WORK(ILARF) ) + C = SQRT( DNRM2( P-I, X11(I+1,I+1), 1, X11(I+1,I+1), + $ 1 )**2 + DNRM2( M-P-I, X21(I+1,I+1), 1, X21(I+1,I+1), + $ 1 )**2 ) + PHI(I) = ATAN2( S, C ) + CALL DORBDB5( P-I, M-P-I, Q-I-1, X11(I+1,I+1), 1, + $ X21(I+1,I+1), 1, X11(I+1,I+2), LDX11, + $ X21(I+1,I+2), LDX21, WORK(IORBDB5), LORBDB5, + $ CHILDINFO ) + END IF +* + END DO +* + RETURN +* +* End of DORBDB1 +* + END + diff --git a/lapack-netlib/SRC/dorbdb2.f b/lapack-netlib/SRC/dorbdb2.f new file mode 100644 index 000000000..3cf82cf40 --- /dev/null +++ b/lapack-netlib/SRC/dorbdb2.f @@ -0,0 +1,333 @@ +*> \brief \b DORBDB2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORBDB2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION PHI(*), THETA(*) +* DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> DORBDB2 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonomal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. P must be no larger than M-P, +*> Q, or M-Q. Routines DORBDB1, DORBDB3, and DORBDB4 handle cases in +*> which P is not the minimum dimension. +*> +*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are P-by-P bidiagonal matrices represented implicitly by +*> angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= min(M-P,Q,M-Q). +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M. +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is DOUBLE PRECISION array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is DOUBLE PRECISION array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is DOUBLE PRECISION array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +*> +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or DORCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR +*> and DORGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + DOUBLE PRECISION PHI(*), THETA(*) + DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + DOUBLE PRECISION NEGONE, ONE + PARAMETER ( NEGONE = -1.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, + $ LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, DSCAL, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( P .LT. 0 .OR. P .GT. M-P ) THEN + INFO = -2 + ELSE IF( Q .LT. 0 .OR. Q .LT. P .OR. M-Q .LT. P ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( P-1, M-P, Q-1 ) + IORBDB5 = 2 + LORBDB5 = Q-1 + LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'DORBDB2', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce rows 1, ..., P of X11 and X21 +* + DO I = 1, P +* + IF( I .GT. 1 ) THEN + CALL DROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C, S ) + END IF + CALL DLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) ) + C = X11(I,I) + X11(I,I) = ONE + CALL DLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL DLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X21(I,I), LDX21, WORK(ILARF) ) + S = SQRT( DNRM2( P-I, X11(I+1,I), 1, X11(I+1,I), + $ 1 )**2 + DNRM2( M-P-I+1, X21(I,I), 1, X21(I,I), 1 )**2 ) + THETA(I) = ATAN2( S, C ) +* + CALL DORBDB5( P-I, M-P-I+1, Q-I, X11(I+1,I), 1, X21(I,I), 1, + $ X11(I+1,I+1), LDX11, X21(I,I+1), LDX21, + $ WORK(IORBDB5), LORBDB5, CHILDINFO ) + CALL DSCAL( P-I, NEGONE, X11(I+1,I), 1 ) + CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + IF( I .LT. P ) THEN + CALL DLARFGP( P-I, X11(I+1,I), X11(I+2,I), 1, TAUP1(I) ) + PHI(I) = ATAN2( X11(I+1,I), X21(I,I) ) + C = COS( PHI(I) ) + S = SIN( PHI(I) ) + X11(I+1,I) = ONE + CALL DLARF( 'L', P-I, Q-I, X11(I+1,I), 1, TAUP1(I), + $ X11(I+1,I+1), LDX11, WORK(ILARF) ) + END IF + X21(I,I) = ONE + CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), + $ X21(I,I+1), LDX21, WORK(ILARF) ) +* + END DO +* +* Reduce the bottom-right portion of X21 to the identity matrix +* + DO I = P + 1, Q + CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + X21(I,I) = ONE + CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), + $ X21(I,I+1), LDX21, WORK(ILARF) ) + END DO +* + RETURN +* +* End of DORBDB2 +* + END + diff --git a/lapack-netlib/SRC/dorbdb3.f b/lapack-netlib/SRC/dorbdb3.f new file mode 100644 index 000000000..03be504fa --- /dev/null +++ b/lapack-netlib/SRC/dorbdb3.f @@ -0,0 +1,332 @@ +*> \brief \b DORBDB3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORBDB3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION PHI(*), THETA(*) +* DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> DORBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonomal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-P must be no larger than P, +*> Q, or M-Q. Routines DORBDB1, DORBDB2, and DORBDB4 handle cases in +*> which M-P is not the minimum dimension. +*> +*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are (M-P)-by-(M-P) bidiagonal matrices represented +*> implicitly by angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= M. M-P <= min(P,Q,M-Q). +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M. +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is DOUBLE PRECISION array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is DOUBLE PRECISION array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is DOUBLE PRECISION array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or DORCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR +*> and DORGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + DOUBLE PRECISION PHI(*), THETA(*) + DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, + $ LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( 2*P .LT. M .OR. P .GT. M ) THEN + INFO = -2 + ELSE IF( Q .LT. M-P .OR. M-Q .LT. M-P ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( P, M-P-1, Q-1 ) + IORBDB5 = 2 + LORBDB5 = Q-1 + LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'DORBDB3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce rows 1, ..., M-P of X11 and X21 +* + DO I = 1, M-P +* + IF( I .GT. 1 ) THEN + CALL DROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C, S ) + END IF +* + CALL DLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) ) + S = X21(I,I) + X21(I,I) = ONE + CALL DLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X11(I,I), LDX11, WORK(ILARF) ) + CALL DLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X21(I+1,I), LDX21, WORK(ILARF) ) + C = SQRT( DNRM2( P-I+1, X11(I,I), 1, X11(I,I), + $ 1 )**2 + DNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), 1 )**2 ) + THETA(I) = ATAN2( S, C ) +* + CALL DORBDB5( P-I+1, M-P-I, Q-I, X11(I,I), 1, X21(I+1,I), 1, + $ X11(I,I+1), LDX11, X21(I+1,I+1), LDX21, + $ WORK(IORBDB5), LORBDB5, CHILDINFO ) + CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + IF( I .LT. M-P ) THEN + CALL DLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, TAUP2(I) ) + PHI(I) = ATAN2( X21(I+1,I), X11(I,I) ) + C = COS( PHI(I) ) + S = SIN( PHI(I) ) + X21(I+1,I) = ONE + CALL DLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1, TAUP2(I), + $ X21(I+1,I+1), LDX21, WORK(ILARF) ) + END IF + X11(I,I) = ONE + CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1), + $ LDX11, WORK(ILARF) ) +* + END DO +* +* Reduce the bottom-right portion of X11 to the identity matrix +* + DO I = M-P + 1, Q + CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + X11(I,I) = ONE + CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1), + $ LDX11, WORK(ILARF) ) + END DO +* + RETURN +* +* End of DORBDB3 +* + END + diff --git a/lapack-netlib/SRC/dorbdb4.f b/lapack-netlib/SRC/dorbdb4.f new file mode 100644 index 000000000..8c7236054 --- /dev/null +++ b/lapack-netlib/SRC/dorbdb4.f @@ -0,0 +1,378 @@ +*> \brief \b DORBDB4 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORBDB4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION PHI(*), THETA(*) +* DOUBLE PRECISION PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*), +* $ WORK(*), X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> DORBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonomal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-Q must be no larger than P, +*> M-P, or Q. Routines DORBDB1, DORBDB2, and DORBDB3 handle cases in +*> which M-Q is not the minimum dimension. +*> +*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are (M-Q)-by-(M-Q) bidiagonal matrices represented +*> implicitly by angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M and +*> M-Q <= min(P,M-P,Q). +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is DOUBLE PRECISION array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is DOUBLE PRECISION array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is DOUBLE PRECISION array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] PHANTOM +*> \verbatim +*> PHANTOM is DOUBLE PRECISION array, dimension (M) +*> The routine computes an M-by-1 column vector Y that is +*> orthogonal to the columns of [ X11; X21 ]. PHANTOM(1:P) and +*> PHANTOM(P+1:M) contain Householder vectors for Y(1:P) and +*> Y(P+1:M), respectively. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or DORCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR +*> and DORGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + $ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + DOUBLE PRECISION PHI(*), THETA(*) + DOUBLE PRECISION PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*), + $ WORK(*), X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + DOUBLE PRECISION NEGONE, ONE, ZERO + PARAMETER ( NEGONE = -1.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, J, LLARF, + $ LORBDB5, LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, DSCAL, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( P .LT. M-Q .OR. M-P .LT. M-Q ) THEN + INFO = -2 + ELSE IF( Q .LT. M-Q .OR. Q .GT. M ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( Q-1, P-1, M-P-1 ) + IORBDB5 = 2 + LORBDB5 = Q + LWORKOPT = ILARF + LLARF - 1 + LWORKOPT = MAX( LWORKOPT, IORBDB5 + LORBDB5 - 1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'DORBDB4', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce columns 1, ..., M-Q of X11 and X21 +* + DO I = 1, M-Q +* + IF( I .EQ. 1 ) THEN + DO J = 1, M + PHANTOM(J) = ZERO + END DO + CALL DORBDB5( P, M-P, Q, PHANTOM(1), 1, PHANTOM(P+1), 1, + $ X11, LDX11, X21, LDX21, WORK(IORBDB5), + $ LORBDB5, CHILDINFO ) + CALL DSCAL( P, NEGONE, PHANTOM(1), 1 ) + CALL DLARFGP( P, PHANTOM(1), PHANTOM(2), 1, TAUP1(1) ) + CALL DLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, TAUP2(1) ) + THETA(I) = ATAN2( PHANTOM(1), PHANTOM(P+1) ) + C = COS( THETA(I) ) + S = SIN( THETA(I) ) + PHANTOM(1) = ONE + PHANTOM(P+1) = ONE + CALL DLARF( 'L', P, Q, PHANTOM(1), 1, TAUP1(1), X11, LDX11, + $ WORK(ILARF) ) + CALL DLARF( 'L', M-P, Q, PHANTOM(P+1), 1, TAUP2(1), X21, + $ LDX21, WORK(ILARF) ) + ELSE + CALL DORBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1, + $ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I), + $ LDX21, WORK(IORBDB5), LORBDB5, CHILDINFO ) + CALL DSCAL( P-I+1, NEGONE, X11(I,I-1), 1 ) + CALL DLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, TAUP1(I) ) + CALL DLARFGP( M-P-I+1, X21(I,I-1), X21(I+1,I-1), 1, + $ TAUP2(I) ) + THETA(I) = ATAN2( X11(I,I-1), X21(I,I-1) ) + C = COS( THETA(I) ) + S = SIN( THETA(I) ) + X11(I,I-1) = ONE + X21(I,I-1) = ONE + CALL DLARF( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, TAUP1(I), + $ X11(I,I), LDX11, WORK(ILARF) ) + CALL DLARF( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, TAUP2(I), + $ X21(I,I), LDX21, WORK(ILARF) ) + END IF +* + CALL DROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C ) + CALL DLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) ) + C = X21(I,I) + X21(I,I) = ONE + CALL DLARF( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL DLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X21(I+1,I), LDX21, WORK(ILARF) ) + IF( I .LT. M-Q ) THEN + S = SQRT( DNRM2( P-I, X11(I+1,I), 1, X11(I+1,I), + $ 1 )**2 + DNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), + $ 1 )**2 ) + PHI(I) = ATAN2( S, C ) + END IF +* + END DO +* +* Reduce the bottom-right portion of X11 to [ I 0 ] +* + DO I = M - Q + 1, P + CALL DLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) ) + X11(I,I) = ONE + CALL DLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL DLARF( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X21(M-Q+1,I), LDX21, WORK(ILARF) ) + END DO +* +* Reduce the bottom-right portion of X21 to [ 0 I ] +* + DO I = P + 1, Q + CALL DLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), LDX21, + $ TAUQ1(I) ) + X21(M-Q+I-P,I) = ONE + CALL DLARF( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, TAUQ1(I), + $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) ) + END DO +* + RETURN +* +* End of DORBDB4 +* + END + diff --git a/lapack-netlib/SRC/dorbdb5.f b/lapack-netlib/SRC/dorbdb5.f new file mode 100644 index 000000000..8fd8e6e37 --- /dev/null +++ b/lapack-netlib/SRC/dorbdb5.f @@ -0,0 +1,274 @@ +*> \brief \b DORBDB5 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORBDB5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, +* LDQ2, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, +* $ N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> DORBDB5 orthogonalizes the column vector +*> X = [ X1 ] +*> [ X2 ] +*> with respect to the columns of +*> Q = [ Q1 ] . +*> [ Q2 ] +*> The columns of Q must be orthonormal. +*> +*> If the projection is zero according to Kahan's "twice is enough" +*> criterion, then some other vector from the orthogonal complement +*> is returned. This vector is chosen in an arbitrary but deterministic +*> way. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M1 +*> \verbatim +*> M1 is INTEGER +*> The dimension of X1 and the number of rows in Q1. 0 <= M1. +*> \endverbatim +*> +*> \param[in] M2 +*> \verbatim +*> M2 is INTEGER +*> The dimension of X2 and the number of rows in Q2. 0 <= M2. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns in Q1 and Q2. 0 <= N. +*> \endverbatim +*> +*> \param[in,out] X1 +*> \verbatim +*> X1 is DOUBLE PRECISION array, dimension (M1) +*> On entry, the top part of the vector to be orthogonalized. +*> On exit, the top part of the projected vector. +*> \endverbatim +*> +*> \param[in] INCX1 +*> \verbatim +*> INCX1 is INTEGER +*> Increment for entries of X1. +*> \endverbatim +*> +*> \param[in,out] X2 +*> \verbatim +*> X2 is DOUBLE PRECISION array, dimension (M2) +*> On entry, the bottom part of the vector to be +*> orthogonalized. On exit, the bottom part of the projected +*> vector. +*> \endverbatim +*> +*> \param[in] INCX2 +*> \verbatim +*> INCX2 is INTEGER +*> Increment for entries of X2. +*> \endverbatim +*> +*> \param[in] Q1 +*> \verbatim +*> Q1 is DOUBLE PRECISION array, dimension (LDQ1, N) +*> The top part of the orthonormal basis matrix. +*> \endverbatim +*> +*> \param[in] LDQ1 +*> \verbatim +*> LDQ1 is INTEGER +*> The leading dimension of Q1. LDQ1 >= M1. +*> \endverbatim +*> +*> \param[in] Q2 +*> \verbatim +*> Q2 is DOUBLE PRECISION array, dimension (LDQ2, N) +*> The bottom part of the orthonormal basis matrix. +*> \endverbatim +*> +*> \param[in] LDQ2 +*> \verbatim +*> LDQ2 is INTEGER +*> The leading dimension of Q2. LDQ2 >= M2. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= N. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, + $ LDQ2, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, + $ N +* .. +* .. Array Arguments .. + DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + INTEGER CHILDINFO, I, J +* .. +* .. External Subroutines .. + EXTERNAL DORBDB6, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + IF( M1 .LT. 0 ) THEN + INFO = -1 + ELSE IF( M2 .LT. 0 ) THEN + INFO = -2 + ELSE IF( N .LT. 0 ) THEN + INFO = -3 + ELSE IF( INCX1 .LT. 1 ) THEN + INFO = -5 + ELSE IF( INCX2 .LT. 1 ) THEN + INFO = -7 + ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN + INFO = -9 + ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN + INFO = -11 + ELSE IF( LWORK .LT. N ) THEN + INFO = -13 + END IF +* + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'DORBDB5', -INFO ) + RETURN + END IF +* +* Project X onto the orthogonal complement of Q +* + CALL DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, LDQ2, + $ WORK, LWORK, CHILDINFO ) +* +* If the projection is nonzero, then return +* + IF( DNRM2(M1,X1,INCX1) .NE. ZERO + $ .OR. DNRM2(M2,X2,INCX2) .NE. ZERO ) THEN + RETURN + END IF +* +* Project each standard basis vector e_1,...,e_M1 in turn, stopping +* when a nonzero projection is found +* + DO I = 1, M1 + DO J = 1, M1 + X1(J) = ZERO + END DO + X1(I) = ONE + DO J = 1, M2 + X2(J) = ZERO + END DO + CALL DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, + $ LDQ2, WORK, LWORK, CHILDINFO ) + IF( DNRM2(M1,X1,INCX1) .NE. ZERO + $ .OR. DNRM2(M2,X2,INCX2) .NE. ZERO ) THEN + RETURN + END IF + END DO +* +* Project each standard basis vector e_(M1+1),...,e_(M1+M2) in turn, +* stopping when a nonzero projection is found +* + DO I = 1, M2 + DO J = 1, M1 + X1(J) = ZERO + END DO + DO J = 1, M2 + X2(J) = ZERO + END DO + X2(I) = ONE + CALL DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, + $ LDQ2, WORK, LWORK, CHILDINFO ) + IF( DNRM2(M1,X1,INCX1) .NE. ZERO + $ .OR. DNRM2(M2,X2,INCX2) .NE. ZERO ) THEN + RETURN + END IF + END DO +* + RETURN +* +* End of DORBDB5 +* + END + diff --git a/lapack-netlib/SRC/dorbdb6.f b/lapack-netlib/SRC/dorbdb6.f new file mode 100644 index 000000000..59fd863bf --- /dev/null +++ b/lapack-netlib/SRC/dorbdb6.f @@ -0,0 +1,312 @@ +*> \brief \b DORBDB6 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORBDB6 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, +* LDQ2, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, +* $ N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> DORBDB6 orthogonalizes the column vector +*> X = [ X1 ] +*> [ X2 ] +*> with respect to the columns of +*> Q = [ Q1 ] . +*> [ Q2 ] +*> The columns of Q must be orthonormal. +*> +*> If the projection is zero according to Kahan's "twice is enough" +*> criterion, then the zero vector is returned. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M1 +*> \verbatim +*> M1 is INTEGER +*> The dimension of X1 and the number of rows in Q1. 0 <= M1. +*> \endverbatim +*> +*> \param[in] M2 +*> \verbatim +*> M2 is INTEGER +*> The dimension of X2 and the number of rows in Q2. 0 <= M2. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns in Q1 and Q2. 0 <= N. +*> \endverbatim +*> +*> \param[in,out] X1 +*> \verbatim +*> X1 is DOUBLE PRECISION array, dimension (M1) +*> On entry, the top part of the vector to be orthogonalized. +*> On exit, the top part of the projected vector. +*> \endverbatim +*> +*> \param[in] INCX1 +*> \verbatim +*> INCX1 is INTEGER +*> Increment for entries of X1. +*> \endverbatim +*> +*> \param[in,out] X2 +*> \verbatim +*> X2 is DOUBLE PRECISION array, dimension (M2) +*> On entry, the bottom part of the vector to be +*> orthogonalized. On exit, the bottom part of the projected +*> vector. +*> \endverbatim +*> +*> \param[in] INCX2 +*> \verbatim +*> INCX2 is INTEGER +*> Increment for entries of X2. +*> \endverbatim +*> +*> \param[in] Q1 +*> \verbatim +*> Q1 is DOUBLE PRECISION array, dimension (LDQ1, N) +*> The top part of the orthonormal basis matrix. +*> \endverbatim +*> +*> \param[in] LDQ1 +*> \verbatim +*> LDQ1 is INTEGER +*> The leading dimension of Q1. LDQ1 >= M1. +*> \endverbatim +*> +*> \param[in] Q2 +*> \verbatim +*> Q2 is DOUBLE PRECISION array, dimension (LDQ2, N) +*> The bottom part of the orthonormal basis matrix. +*> \endverbatim +*> +*> \param[in] LDQ2 +*> \verbatim +*> LDQ2 is INTEGER +*> The leading dimension of Q2. LDQ2 >= M2. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= N. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup doubleOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, + $ LDQ2, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, + $ N +* .. +* .. Array Arguments .. + DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ALPHASQ, REALONE, REALZERO + PARAMETER ( ALPHASQ = 0.01D0, REALONE = 1.0D0, + $ REALZERO = 0.0D0 ) + DOUBLE PRECISION NEGONE, ONE, ZERO + PARAMETER ( NEGONE = -1.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION NORMSQ1, NORMSQ2, SCL1, SCL2, SSQ1, SSQ2 +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DLASSQ, XERBLA +* .. +* .. Intrinsic Function .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + IF( M1 .LT. 0 ) THEN + INFO = -1 + ELSE IF( M2 .LT. 0 ) THEN + INFO = -2 + ELSE IF( N .LT. 0 ) THEN + INFO = -3 + ELSE IF( INCX1 .LT. 1 ) THEN + INFO = -5 + ELSE IF( INCX2 .LT. 1 ) THEN + INFO = -7 + ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN + INFO = -9 + ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN + INFO = -11 + ELSE IF( LWORK .LT. N ) THEN + INFO = -13 + END IF +* + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'DORBDB6', -INFO ) + RETURN + END IF +* +* First, project X onto the orthogonal complement of Q's column +* space +* + SCL1 = REALZERO + SSQ1 = REALONE + CALL DLASSQ( M1, X1, INCX1, SCL1, SSQ1 ) + SCL2 = REALZERO + SSQ2 = REALONE + CALL DLASSQ( M2, X2, INCX2, SCL2, SSQ2 ) + NORMSQ1 = SCL1**2*SSQ1 + SCL2**2*SSQ2 +* + IF( M1 .EQ. 0 ) THEN + DO I = 1, N + WORK(I) = ZERO + END DO + ELSE + CALL DGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK, + $ 1 ) + END IF +* + CALL DGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 ) +* + CALL DGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1, + $ INCX1 ) + CALL DGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2, + $ INCX2 ) +* + SCL1 = REALZERO + SSQ1 = REALONE + CALL DLASSQ( M1, X1, INCX1, SCL1, SSQ1 ) + SCL2 = REALZERO + SSQ2 = REALONE + CALL DLASSQ( M2, X2, INCX2, SCL2, SSQ2 ) + NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2 +* +* If projection is sufficiently large in norm, then stop. +* If projection is zero, then stop. +* Otherwise, project again. +* + IF( NORMSQ2 .GE. ALPHASQ*NORMSQ1 ) THEN + RETURN + END IF +* + IF( NORMSQ2 .EQ. ZERO ) THEN + RETURN + END IF +* + NORMSQ1 = NORMSQ2 +* + DO I = 1, N + WORK(I) = ZERO + END DO +* + IF( M1 .EQ. 0 ) THEN + DO I = 1, N + WORK(I) = ZERO + END DO + ELSE + CALL DGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK, + $ 1 ) + END IF +* + CALL DGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 ) +* + CALL DGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1, + $ INCX1 ) + CALL DGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2, + $ INCX2 ) +* + SCL1 = REALZERO + SSQ1 = REALONE + CALL DLASSQ( M1, X1, INCX1, SCL1, SSQ1 ) + SCL2 = REALZERO + SSQ2 = REALONE + CALL DLASSQ( M1, X1, INCX1, SCL1, SSQ1 ) + NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2 +* +* If second projection is sufficiently large in norm, then do +* nothing more. Alternatively, if it shrunk significantly, then +* truncate it to zero. +* + IF( NORMSQ2 .LT. ALPHASQ*NORMSQ1 ) THEN + DO I = 1, M1 + X1(I) = ZERO + END DO + DO I = 1, M2 + X2(I) = ZERO + END DO + END IF +* + RETURN +* +* End of DORBDB6 +* + END + diff --git a/lapack-netlib/SRC/dorcsd.f b/lapack-netlib/SRC/dorcsd.f index 927bf664a..d5d48eb9e 100644 --- a/lapack-netlib/SRC/dorcsd.f +++ b/lapack-netlib/SRC/dorcsd.f @@ -289,7 +289,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup doubleOTHERcomputational * @@ -300,10 +300,10 @@ $ U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, $ LDV2T, WORK, LWORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS @@ -368,9 +368,22 @@ INFO = -8 ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN INFO = -9 - ELSE IF( ( COLMAJOR .AND. LDX11 .LT. MAX(1,P) ) .OR. - $ ( .NOT.COLMAJOR .AND. LDX11 .LT. MAX(1,Q) ) ) THEN - INFO = -11 + ELSE IF ( COLMAJOR .AND. LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF (.NOT. COLMAJOR .AND. LDX11 .LT. MAX( 1, Q ) ) THEN + INFO = -11 + ELSE IF (COLMAJOR .AND. LDX12 .LT. MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF (.NOT. COLMAJOR .AND. LDX12 .LT. MAX( 1, M-Q ) ) THEN + INFO = -13 + ELSE IF (COLMAJOR .AND. LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -15 + ELSE IF (.NOT. COLMAJOR .AND. LDX21 .LT. MAX( 1, Q ) ) THEN + INFO = -15 + ELSE IF (COLMAJOR .AND. LDX22 .LT. MAX( 1, M-P ) ) THEN + INFO = -17 + ELSE IF (.NOT. COLMAJOR .AND. LDX22 .LT. MAX( 1, M-Q ) ) THEN + INFO = -17 ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN INFO = -20 ELSE IF( WANTU2 .AND. LDU2 .LT. M-P ) THEN @@ -427,19 +440,19 @@ ITAUQ1 = ITAUP2 + MAX( 1, M - P ) ITAUQ2 = ITAUQ1 + MAX( 1, Q ) IORGQR = ITAUQ2 + MAX( 1, M - Q ) - CALL DORGQR( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), 0, WORK, -1, + CALL DORGQR( M-Q, M-Q, M-Q, U1, MAX(1,M-Q), U1, WORK, -1, $ CHILDINFO ) LORGQRWORKOPT = INT( WORK(1) ) LORGQRWORKMIN = MAX( 1, M - Q ) IORGLQ = ITAUQ2 + MAX( 1, M - Q ) - CALL DORGLQ( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), 0, WORK, -1, + CALL DORGLQ( M-Q, M-Q, M-Q, U1, MAX(1,M-Q), U1, WORK, -1, $ CHILDINFO ) LORGLQWORKOPT = INT( WORK(1) ) LORGLQWORKMIN = MAX( 1, M - Q ) IORBDB = ITAUQ2 + MAX( 1, M - Q ) CALL DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, - $ X21, LDX21, X22, LDX22, 0, 0, 0, 0, 0, 0, WORK, - $ -1, CHILDINFO ) + $ X21, LDX21, X22, LDX22, THETA, V1T, U1, U2, V1T, + $ V2T, WORK, -1, CHILDINFO ) LORBDBWORKOPT = INT( WORK(1) ) LORBDBWORKMIN = LORBDBWORKOPT IB11D = ITAUQ2 + MAX( 1, M - Q ) @@ -451,9 +464,10 @@ IB22D = IB21E + MAX( 1, Q - 1 ) IB22E = IB22D + MAX( 1, Q ) IBBCSD = IB22E + MAX( 1, Q - 1 ) - CALL DBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, 0, - $ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, 0, - $ 0, 0, 0, 0, 0, 0, 0, WORK, -1, CHILDINFO ) + CALL DBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, + $ THETA, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, + $ LDV2T, U1, U1, U1, U1, U1, U1, U1, U1, WORK, -1, + $ CHILDINFO ) LBBCSDWORKOPT = INT( WORK(1) ) LBBCSDWORKMIN = LBBCSDWORKOPT LWORKOPT = MAX( IORGQR + LORGQRWORKOPT, IORGLQ + LORGLQWORKOPT, @@ -514,10 +528,14 @@ END IF IF( WANTV2T .AND. M-Q .GT. 0 ) THEN CALL DLACPY( 'U', P, M-Q, X12, LDX12, V2T, LDV2T ) - CALL DLACPY( 'U', M-P-Q, M-P-Q, X22(Q+1,P+1), LDX22, - $ V2T(P+1,P+1), LDV2T ) - CALL DORGLQ( M-Q, M-Q, M-Q, V2T, LDV2T, WORK(ITAUQ2), - $ WORK(IORGLQ), LORGLQWORK, INFO ) + IF (M-P .GT. Q) Then + CALL DLACPY( 'U', M-P-Q, M-P-Q, X22(Q+1,P+1), LDX22, + $ V2T(P+1,P+1), LDV2T ) + END IF + IF (M .GT. Q) THEN + CALL DORGLQ( M-Q, M-Q, M-Q, V2T, LDV2T, WORK(ITAUQ2), + $ WORK(IORGLQ), LORGLQWORK, INFO ) + END IF END IF ELSE IF( WANTU1 .AND. P .GT. 0 ) THEN diff --git a/lapack-netlib/SRC/dorcsd2by1.f b/lapack-netlib/SRC/dorcsd2by1.f new file mode 100644 index 000000000..f3ac4e546 --- /dev/null +++ b/lapack-netlib/SRC/dorcsd2by1.f @@ -0,0 +1,715 @@ +*> \brief \b DORCSD2BY1 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORCSD2BY1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, +* X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T, +* LDV1T, WORK, LWORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBU1, JOBU2, JOBV1T +* INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21, +* $ M, P, Q +* .. +* .. Array Arguments .. +* DOUBLE PRECISION THETA(*) +* DOUBLE PRECISION U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* INTEGER IWORK(*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> Purpose: +*> ======== +*> +*> DORCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with +*> orthonormal columns that has been partitioned into a 2-by-1 block +*> structure: +*> +*> [ I 0 0 ] +*> [ 0 C 0 ] +*> [ X11 ] [ U1 | ] [ 0 0 0 ] +*> X = [-----] = [---------] [----------] V1**T . +*> [ X21 ] [ | U2 ] [ 0 0 0 ] +*> [ 0 S 0 ] +*> [ 0 0 I ] +*> +*> X11 is P-by-Q. The orthogonal matrices U1, U2, V1, and V2 are P-by-P, +*> (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are +*> R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in +*> which R = MIN(P,M-P,Q,M-Q). +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBU1 +*> \verbatim +*> JOBU1 is CHARACTER +*> = 'Y': U1 is computed; +*> otherwise: U1 is not computed. +*> \endverbatim +*> +*> \param[in] JOBU2 +*> \verbatim +*> JOBU2 is CHARACTER +*> = 'Y': U2 is computed; +*> otherwise: U2 is not computed. +*> \endverbatim +*> +*> \param[in] JOBV1T +*> \verbatim +*> JOBV1T is CHARACTER +*> = 'Y': V1T is computed; +*> otherwise: V1T is not computed. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows and columns in X. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11 and X12. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M. +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q) +*> On entry, part of the orthogonal matrix whose CSD is +*> desired. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= MAX(1,P). +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q) +*> On entry, part of the orthogonal matrix whose CSD is +*> desired. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= MAX(1,M-P). +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (R), in which R = +*> MIN(P,M-P,Q,M-Q). +*> C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and +*> S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ). +*> \endverbatim +*> +*> \param[out] U1 +*> \verbatim +*> U1 is DOUBLE PRECISION array, dimension (P) +*> If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1. +*> \endverbatim +*> +*> \param[in] LDU1 +*> \verbatim +*> LDU1 is INTEGER +*> The leading dimension of U1. If JOBU1 = 'Y', LDU1 >= +*> MAX(1,P). +*> \endverbatim +*> +*> \param[out] U2 +*> \verbatim +*> U2 is DOUBLE PRECISION array, dimension (M-P) +*> If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal +*> matrix U2. +*> \endverbatim +*> +*> \param[in] LDU2 +*> \verbatim +*> LDU2 is INTEGER +*> The leading dimension of U2. If JOBU2 = 'Y', LDU2 >= +*> MAX(1,M-P). +*> \endverbatim +*> +*> \param[out] V1T +*> \verbatim +*> V1T is DOUBLE PRECISION array, dimension (Q) +*> If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal +*> matrix V1**T. +*> \endverbatim +*> +*> \param[in] LDV1T +*> \verbatim +*> LDV1T is INTEGER +*> The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >= +*> MAX(1,Q). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> If INFO > 0 on exit, WORK(2:R) contains the values PHI(1), +*> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R), +*> define the matrix in intermediate bidiagonal-block form +*> remaining after nonconvergence. INFO specifies the number +*> of nonzero PHI's. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> \endverbatim +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the work array, and no error +*> message related to LWORK is issued by XERBLA. +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (M-MIN(P,M-P,Q,M-Q)) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: DBBCSD did not converge. See the description of WORK +*> above for details. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup doubleOTHERcomputational +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, + $ X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T, + $ LDV1T, WORK, LWORK, IWORK, INFO ) +* +* -- LAPACK computational routine (3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + CHARACTER JOBU1, JOBU2, JOBV1T + INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21, + $ M, P, Q +* .. +* .. Array Arguments .. + DOUBLE PRECISION THETA(*) + DOUBLE PRECISION U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) + INTEGER IWORK(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + INTEGER CHILDINFO, I, IB11D, IB11E, IB12D, IB12E, + $ IB21D, IB21E, IB22D, IB22E, IBBCSD, IORBDB, + $ IORGLQ, IORGQR, IPHI, ITAUP1, ITAUP2, ITAUQ1, + $ J, LBBCSD, LORBDB, LORGLQ, LORGLQMIN, + $ LORGLQOPT, LORGQR, LORGQRMIN, LORGQROPT, + $ LWORKMIN, LWORKOPT, R + LOGICAL LQUERY, WANTU1, WANTU2, WANTV1T +* .. +* .. External Subroutines .. + EXTERNAL DBBCSD, DCOPY, DLACPY, DLAPMR, DLAPMT, DORBDB1, + $ DORBDB2, DORBDB3, DORBDB4, DORGLQ, DORGQR, + $ XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Function .. + INTRINSIC INT, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + WANTU1 = LSAME( JOBU1, 'Y' ) + WANTU2 = LSAME( JOBU2, 'Y' ) + WANTV1T = LSAME( JOBV1T, 'Y' ) + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -4 + ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN + INFO = -5 + ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN + INFO = -6 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -8 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -10 + ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN + INFO = -13 + ELSE IF( WANTU2 .AND. LDU2 .LT. M - P ) THEN + INFO = -15 + ELSE IF( WANTV1T .AND. LDV1T .LT. Q ) THEN + INFO = -17 + END IF +* + R = MIN( P, M-P, Q, M-Q ) +* +* Compute workspace +* +* WORK layout: +* |-------------------------------------------------------| +* | LWORKOPT (1) | +* |-------------------------------------------------------| +* | PHI (MAX(1,R-1)) | +* |-------------------------------------------------------| +* | TAUP1 (MAX(1,P)) | B11D (R) | +* | TAUP2 (MAX(1,M-P)) | B11E (R-1) | +* | TAUQ1 (MAX(1,Q)) | B12D (R) | +* |-----------------------------------------| B12E (R-1) | +* | DORBDB WORK | DORGQR WORK | DORGLQ WORK | B21D (R) | +* | | | | B21E (R-1) | +* | | | | B22D (R) | +* | | | | B22E (R-1) | +* | | | | DBBCSD WORK | +* |-------------------------------------------------------| +* + IF( INFO .EQ. 0 ) THEN + IPHI = 2 + IB11D = IPHI + MAX( 1, R-1 ) + IB11E = IB11D + MAX( 1, R ) + IB12D = IB11E + MAX( 1, R - 1 ) + IB12E = IB12D + MAX( 1, R ) + IB21D = IB12E + MAX( 1, R - 1 ) + IB21E = IB21D + MAX( 1, R ) + IB22D = IB21E + MAX( 1, R - 1 ) + IB22E = IB22D + MAX( 1, R ) + IBBCSD = IB22E + MAX( 1, R - 1 ) + ITAUP1 = IPHI + MAX( 1, R-1 ) + ITAUP2 = ITAUP1 + MAX( 1, P ) + ITAUQ1 = ITAUP2 + MAX( 1, M-P ) + IORBDB = ITAUQ1 + MAX( 1, Q ) + IORGQR = ITAUQ1 + MAX( 1, Q ) + IORGLQ = ITAUQ1 + MAX( 1, Q ) + IF( R .EQ. Q ) THEN + CALL DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, + $ 0, 0, WORK, -1, CHILDINFO ) + LORBDB = INT( WORK(1) ) + IF( P .GE. M-P ) THEN + CALL DORGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, P ) + LORGQROPT = INT( WORK(1) ) + ELSE + CALL DORGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, M-P ) + LORGQROPT = INT( WORK(1) ) + END IF + CALL DORGLQ( MAX(0,Q-1), MAX(0,Q-1), MAX(0,Q-1), V1T, LDV1T, + $ 0, WORK(1), -1, CHILDINFO ) + LORGLQMIN = MAX( 1, Q-1 ) + LORGLQOPT = INT( WORK(1) ) + CALL DBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA, + $ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, 0, 0, + $ 0, 0, 0, 0, 0, 0, WORK(1), -1, CHILDINFO ) + LBBCSD = INT( WORK(1) ) + ELSE IF( R .EQ. P ) THEN + CALL DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, + $ 0, 0, WORK(1), -1, CHILDINFO ) + LORBDB = INT( WORK(1) ) + IF( P-1 .GE. M-P ) THEN + CALL DORGQR( P-1, P-1, P-1, U1(2,2), LDU1, 0, WORK(1), + $ -1, CHILDINFO ) + LORGQRMIN = MAX( 1, P-1 ) + LORGQROPT = INT( WORK(1) ) + ELSE + CALL DORGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, M-P ) + LORGQROPT = INT( WORK(1) ) + END IF + CALL DORGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1, + $ CHILDINFO ) + LORGLQMIN = MAX( 1, Q ) + LORGLQOPT = INT( WORK(1) ) + CALL DBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA, + $ 0, V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, 0, 0, + $ 0, 0, 0, 0, 0, 0, WORK(1), -1, CHILDINFO ) + LBBCSD = INT( WORK(1) ) + ELSE IF( R .EQ. M-P ) THEN + CALL DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, + $ 0, 0, WORK(1), -1, CHILDINFO ) + LORBDB = INT( WORK(1) ) + IF( P .GE. M-P-1 ) THEN + CALL DORGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, P ) + LORGQROPT = INT( WORK(1) ) + ELSE + CALL DORGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, 0, + $ WORK(1), -1, CHILDINFO ) + LORGQRMIN = MAX( 1, M-P-1 ) + LORGQROPT = INT( WORK(1) ) + END IF + CALL DORGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1, + $ CHILDINFO ) + LORGLQMIN = MAX( 1, Q ) + LORGLQOPT = INT( WORK(1) ) + CALL DBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P, + $ THETA, 0, 0, 1, V1T, LDV1T, U2, LDU2, U1, LDU1, + $ 0, 0, 0, 0, 0, 0, 0, 0, WORK(1), -1, + $ CHILDINFO ) + LBBCSD = INT( WORK(1) ) + ELSE + CALL DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, + $ 0, 0, 0, WORK(1), -1, CHILDINFO ) + LORBDB = M + INT( WORK(1) ) + IF( P .GE. M-P ) THEN + CALL DORGQR( P, P, M-Q, U1, LDU1, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, P ) + LORGQROPT = INT( WORK(1) ) + ELSE + CALL DORGQR( M-P, M-P, M-Q, U2, LDU2, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, M-P ) + LORGQROPT = INT( WORK(1) ) + END IF + CALL DORGLQ( Q, Q, Q, V1T, LDV1T, 0, WORK(1), -1, + $ CHILDINFO ) + LORGLQMIN = MAX( 1, Q ) + LORGLQOPT = INT( WORK(1) ) + CALL DBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q, + $ THETA, 0, U2, LDU2, U1, LDU1, 0, 1, V1T, LDV1T, + $ 0, 0, 0, 0, 0, 0, 0, 0, WORK(1), -1, + $ CHILDINFO ) + LBBCSD = INT( WORK(1) ) + END IF + LWORKMIN = MAX( IORBDB+LORBDB-1, + $ IORGQR+LORGQRMIN-1, + $ IORGLQ+LORGLQMIN-1, + $ IBBCSD+LBBCSD-1 ) + LWORKOPT = MAX( IORBDB+LORBDB-1, + $ IORGQR+LORGQROPT-1, + $ IORGLQ+LORGLQOPT-1, + $ IBBCSD+LBBCSD-1 ) + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -19 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'DORCSD2BY1', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF + LORGQR = LWORK-IORGQR+1 + LORGLQ = LWORK-IORGLQ+1 +* +* Handle four cases separately: R = Q, R = P, R = M-P, and R = M-Q, +* in which R = MIN(P,M-P,Q,M-Q) +* + IF( R .EQ. Q ) THEN +* +* Case 1: R = Q +* +* Simultaneously bidiagonalize X11 and X21 +* + CALL DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2), + $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO ) +* +* Accumulate Householder reflectors +* + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL DLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 ) + CALL DORGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR), + $ LORGQR, CHILDINFO ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL DLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 ) + CALL DORGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + V1T(1,1) = ONE + DO J = 2, Q + V1T(1,J) = ZERO + V1T(J,1) = ZERO + END DO + CALL DLACPY( 'U', Q-1, Q-1, X21(1,2), LDX21, V1T(2,2), + $ LDV1T ) + CALL DORGLQ( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1), + $ WORK(IORGLQ), LORGLQ, CHILDINFO ) + END IF +* +* Simultaneously diagonalize X11 and X21. +* + CALL DBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA, + $ WORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, + $ WORK(IB11D), WORK(IB11E), WORK(IB12D), + $ WORK(IB12E), WORK(IB21D), WORK(IB21E), + $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD, + $ CHILDINFO ) +* +* Permute rows and columns to place zero submatrices in +* preferred positions +* + IF( Q .GT. 0 .AND. WANTU2 ) THEN + DO I = 1, Q + IWORK(I) = M - P - Q + I + END DO + DO I = Q + 1, M - P + IWORK(I) = I - Q + END DO + CALL DLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK ) + END IF + ELSE IF( R .EQ. P ) THEN +* +* Case 2: R = P +* +* Simultaneously bidiagonalize X11 and X21 +* + CALL DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2), + $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO ) +* +* Accumulate Householder reflectors +* + IF( WANTU1 .AND. P .GT. 0 ) THEN + U1(1,1) = ONE + DO J = 2, P + U1(1,J) = ZERO + U1(J,1) = ZERO + END DO + CALL DLACPY( 'L', P-1, P-1, X11(2,1), LDX11, U1(2,2), LDU1 ) + CALL DORGQR( P-1, P-1, P-1, U1(2,2), LDU1, WORK(ITAUP1), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL DLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 ) + CALL DORGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL DLACPY( 'U', P, Q, X11, LDX11, V1T, LDV1T ) + CALL DORGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1), + $ WORK(IORGLQ), LORGLQ, CHILDINFO ) + END IF +* +* Simultaneously diagonalize X11 and X21. +* + CALL DBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA, + $ WORK(IPHI), V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, + $ WORK(IB11D), WORK(IB11E), WORK(IB12D), + $ WORK(IB12E), WORK(IB21D), WORK(IB21E), + $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD, + $ CHILDINFO ) +* +* Permute rows and columns to place identity submatrices in +* preferred positions +* + IF( Q .GT. 0 .AND. WANTU2 ) THEN + DO I = 1, Q + IWORK(I) = M - P - Q + I + END DO + DO I = Q + 1, M - P + IWORK(I) = I - Q + END DO + CALL DLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK ) + END IF + ELSE IF( R .EQ. M-P ) THEN +* +* Case 3: R = M-P +* +* Simultaneously bidiagonalize X11 and X21 +* + CALL DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2), + $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO ) +* +* Accumulate Householder reflectors +* + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL DLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 ) + CALL DORGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR), + $ LORGQR, CHILDINFO ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + U2(1,1) = ONE + DO J = 2, M-P + U2(1,J) = ZERO + U2(J,1) = ZERO + END DO + CALL DLACPY( 'L', M-P-1, M-P-1, X21(2,1), LDX21, U2(2,2), + $ LDU2 ) + CALL DORGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, + $ WORK(ITAUP2), WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL DLACPY( 'U', M-P, Q, X21, LDX21, V1T, LDV1T ) + CALL DORGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1), + $ WORK(IORGLQ), LORGLQ, CHILDINFO ) + END IF +* +* Simultaneously diagonalize X11 and X21. +* + CALL DBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P, + $ THETA, WORK(IPHI), 0, 1, V1T, LDV1T, U2, LDU2, U1, + $ LDU1, WORK(IB11D), WORK(IB11E), WORK(IB12D), + $ WORK(IB12E), WORK(IB21D), WORK(IB21E), + $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD, + $ CHILDINFO ) +* +* Permute rows and columns to place identity submatrices in +* preferred positions +* + IF( Q .GT. R ) THEN + DO I = 1, R + IWORK(I) = Q - R + I + END DO + DO I = R + 1, Q + IWORK(I) = I - R + END DO + IF( WANTU1 ) THEN + CALL DLAPMT( .FALSE., P, Q, U1, LDU1, IWORK ) + END IF + IF( WANTV1T ) THEN + CALL DLAPMR( .FALSE., Q, Q, V1T, LDV1T, IWORK ) + END IF + END IF + ELSE +* +* Case 4: R = M-Q +* +* Simultaneously bidiagonalize X11 and X21 +* + CALL DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2), + $ WORK(ITAUQ1), WORK(IORBDB), WORK(IORBDB+M), + $ LORBDB-M, CHILDINFO ) +* +* Accumulate Householder reflectors +* + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL DCOPY( P, WORK(IORBDB), 1, U1, 1 ) + DO J = 2, P + U1(1,J) = ZERO + END DO + CALL DLACPY( 'L', P-1, M-Q-1, X11(2,1), LDX11, U1(2,2), + $ LDU1 ) + CALL DORGQR( P, P, M-Q, U1, LDU1, WORK(ITAUP1), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL DCOPY( M-P, WORK(IORBDB+P), 1, U2, 1 ) + DO J = 2, M-P + U2(1,J) = ZERO + END DO + CALL DLACPY( 'L', M-P-1, M-Q-1, X21(2,1), LDX21, U2(2,2), + $ LDU2 ) + CALL DORGQR( M-P, M-P, M-Q, U2, LDU2, WORK(ITAUP2), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL DLACPY( 'U', M-Q, Q, X21, LDX21, V1T, LDV1T ) + CALL DLACPY( 'U', P-(M-Q), Q-(M-Q), X11(M-Q+1,M-Q+1), LDX11, + $ V1T(M-Q+1,M-Q+1), LDV1T ) + CALL DLACPY( 'U', -P+Q, Q-P, X21(M-Q+1,P+1), LDX21, + $ V1T(P+1,P+1), LDV1T ) + CALL DORGLQ( Q, Q, Q, V1T, LDV1T, WORK(ITAUQ1), + $ WORK(IORGLQ), LORGLQ, CHILDINFO ) + END IF +* +* Simultaneously diagonalize X11 and X21. +* + CALL DBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q, + $ THETA, WORK(IPHI), U2, LDU2, U1, LDU1, 0, 1, V1T, + $ LDV1T, WORK(IB11D), WORK(IB11E), WORK(IB12D), + $ WORK(IB12E), WORK(IB21D), WORK(IB21E), + $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD, + $ CHILDINFO ) +* +* Permute rows and columns to place identity submatrices in +* preferred positions +* + IF( P .GT. R ) THEN + DO I = 1, R + IWORK(I) = P - R + I + END DO + DO I = R + 1, P + IWORK(I) = I - R + END DO + IF( WANTU1 ) THEN + CALL DLAPMT( .FALSE., P, P, U1, LDU1, IWORK ) + END IF + IF( WANTV1T ) THEN + CALL DLAPMR( .FALSE., P, Q, V1T, LDV1T, IWORK ) + END IF + END IF + END IF +* + RETURN +* +* End of DORCSD2BY1 +* + END + diff --git a/lapack-netlib/SRC/dstemr.f b/lapack-netlib/SRC/dstemr.f index 5930465e3..8967c18fc 100644 --- a/lapack-netlib/SRC/dstemr.f +++ b/lapack-netlib/SRC/dstemr.f @@ -294,7 +294,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup doubleOTHERcomputational * @@ -312,10 +312,10 @@ $ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, $ IWORK, LIWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE @@ -391,6 +391,7 @@ WU = ZERO IIL = 0 IIU = 0 + NSPLIT = 0 IF( VALEIG ) THEN * We do not reference VL, VU in the cases RANGE = 'I','A' diff --git a/lapack-netlib/SRC/dsycon_rook.f b/lapack-netlib/SRC/dsycon_rook.f new file mode 100644 index 000000000..2b8b6f901 --- /dev/null +++ b/lapack-netlib/SRC/dsycon_rook.f @@ -0,0 +1,258 @@ +*> \brief \b DSYCON_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYCON_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, +* WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYCON_ROOK estimates the reciprocal of the condition number (in the +*> 1-norm) of a real symmetric matrix A using the factorization +*> A = U*D*U**T or A = L*D*L**T computed by DSYTRF_ROOK. +*> +*> An estimate is obtained for norm(inv(A)), and the reciprocal of the +*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by DSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] ANORM +*> \verbatim +*> ANORM is DOUBLE PRECISION +*> The 1-norm of the original matrix A. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an +*> estimate of the 1-norm of inv(A) computed in this routine. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> April 2012, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, + $ IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N + DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, KASE + DOUBLE PRECISION AINVNM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLACN2, DSYTRS_ROOK, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( ANORM.LT.ZERO ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYCON_ROOK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + RCOND = ZERO + IF( N.EQ.0 ) THEN + RCOND = ONE + RETURN + ELSE IF( ANORM.LE.ZERO ) THEN + RETURN + END IF +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO 10 I = N, 1, -1 + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) + $ RETURN + 10 CONTINUE + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO 20 I = 1, N + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) + $ RETURN + 20 CONTINUE + END IF +* +* Estimate the 1-norm of the inverse. +* + KASE = 0 + 30 CONTINUE + CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN +* +* Multiply by inv(L*D*L**T) or inv(U*D*U**T). +* + CALL DSYTRS_ROOK( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO ) + GO TO 30 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM.NE.ZERO ) + $ RCOND = ( ONE / AINVNM ) / ANORM +* + RETURN +* +* End of DSYCON_ROOK +* + END diff --git a/lapack-netlib/SRC/dsysv_rook.f b/lapack-netlib/SRC/dsysv_rook.f new file mode 100644 index 000000000..4db3a98ef --- /dev/null +++ b/lapack-netlib/SRC/dsysv_rook.f @@ -0,0 +1,293 @@ +*> \brief DSYSV_ROOK computes the solution to system of linear equations A * X = B for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYSV_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYSV_ROOK computes the solution to a real system of linear +*> equations +*> A * X = B, +*> where A is an N-by-N symmetric matrix and X and B are N-by-NRHS +*> matrices. +*> +*> The diagonal pivoting method is used to factor A as +*> A = U * D * U**T, if UPLO = 'U', or +*> A = L * D * L**T, if UPLO = 'L', +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and D is symmetric and block diagonal with +*> 1-by-1 and 2-by-2 diagonal blocks. +*> +*> DSYTRF_ROOK is called to compute the factorization of a real +*> symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal +*> pivoting method. +*> +*> The factored form of A is then used to solve the system +*> of equations A * X = B by calling DSYTRS_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, the block diagonal matrix D and the +*> multipliers used to obtain the factor U or L from the +*> factorization A = U*D*U**T or A = L*D*L**T as computed by +*> DSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, +*> as determined by DSYTRF_ROOK. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= 1, and for best performance +*> LWORK >= max(1,N*NB), where NB is the optimal blocksize for +*> DSYTRF_ROOK. +*> +*> TRS will be done with Level 2 BLAS +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, so the solution could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleSYsolve +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> April 2012, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DSYTRF_ROOK, DSYTRS_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + CALL DSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, -1, INFO ) + LWKOPT = WORK(1) + END IF + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYSV_ROOK ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = U*D*U**T or A = L*D*L**T. +* + CALL DSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* +* Solve with TRS_ROOK ( Use Level 2 BLAS) +* + CALL DSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DSYSV_ROOK +* + END diff --git a/lapack-netlib/SRC/dsytf2.f b/lapack-netlib/SRC/dsytf2.f index 23d8889d4..27a676b84 100644 --- a/lapack-netlib/SRC/dsytf2.f +++ b/lapack-netlib/SRC/dsytf2.f @@ -90,13 +90,22 @@ *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D. -*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were -*> interchanged and D(k,k) is a 1-by-1 diagonal block. -*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and -*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) -*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = -*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were -*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns +*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) +*> is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns +*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1) +*> is a 2-by-2 diagonal block. *> \endverbatim *> *> \param[out] INFO @@ -118,7 +127,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup doubleSYcomputational * @@ -185,10 +194,10 @@ * ===================================================================== SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER UPLO @@ -268,7 +277,8 @@ ABSAKK = ABS( A( K, K ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. * IF( K.GT.1 ) THEN IMAX = IDAMAX( K-1, A( 1, K ), 1 ) @@ -279,7 +289,8 @@ * IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN * -* Column K is zero or contains a NaN: set INFO and continue +* Column K is zero or underflow, or contains a NaN: +* set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K @@ -436,7 +447,8 @@ ABSAKK = ABS( A( K, K ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. * IF( K.LT.N ) THEN IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 ) @@ -447,7 +459,8 @@ * IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN * -* Column K is zero or contains a NaN: set INFO and continue +* Column K is zero or underflow, or contains a NaN: +* set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K diff --git a/lapack-netlib/SRC/dsytf2_rook.f b/lapack-netlib/SRC/dsytf2_rook.f new file mode 100644 index 000000000..237c9984c --- /dev/null +++ b/lapack-netlib/SRC/dsytf2_rook.f @@ -0,0 +1,813 @@ +*> \brief \b DSYTF2_ROOK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTF2_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTF2_ROOK computes the factorization of a real symmetric matrix A +*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method: +*> +*> A = U*D*U**T or A = L*D*L**T +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, U**T is the transpose of U, and D is symmetric and +*> block diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the unblocked version of the algorithm, calling Level 2 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> n-by-n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading n-by-n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, the block diagonal matrix D and the multipliers used +*> to obtain the factor U or L (see below for further details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup doubleSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', then A = U*D*U**T, where +*> U = P(n)*U(n)* ... *P(k)U(k)* ..., +*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to +*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I v 0 ) k-s +*> U(k) = ( 0 I 0 ) s +*> ( 0 0 I ) n-k +*> k-s s n-k +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). +*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), +*> and A(k,k), and v overwrites A(1:k-2,k-1:k). +*> +*> If UPLO = 'L', then A = L*D*L**T, where +*> L = P(1)*L(1)* ... *P(k)*L(k)* ..., +*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to +*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I 0 0 ) k-1 +*> L(k) = ( 0 I 0 ) s +*> ( 0 v I ) n-k-s+1 +*> k-1 s n-k-s+1 +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). +*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), +*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> 01-01-96 - Based on modifications by +*> J. Lewis, Boeing Computer Services Company +*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville abd , USA +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER, DONE + INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP, + $ P, II + DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, + $ ROWMAX, DTEMP, T, WK, WKM1, WKP1, SFMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, IDAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSWAP, DSYR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTF2_ROOK', -INFO ) + RETURN + END IF +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = DLAMCH( 'S' ) +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2 +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 70 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( A( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = IDAMAX( K-1, A( 1, K ), 1 ) + COLMAX = ABS( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + ELSE +* +* Test for interchange +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABSAKK.GE.ALPHA*COLMAX +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, +* use 1-by-1 pivot block +* + KP = K + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* Begin pivot search loop body +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + IDAMAX( K-IMAX, A( IMAX, IMAX+1 ), + $ LDA ) + ROWMAX = ABS( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = IDAMAX( IMAX-1, A( 1, IMAX ), 1 ) + DTEMP = ABS( A( ITEMP, IMAX ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX +* + IF( .NOT.( ABS( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX .EQ. COLMAX, +* used to handle NaN and Inf +* + ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot NOT found, set variables and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 12 +* + END IF +* +* Swap TWO rows and TWO columns +* +* First swap +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Interchange rows and column K and P in the leading +* submatrix A(1:k,1:k) if we have a 2-by-2 pivot +* + IF( P.GT.1 ) + $ CALL DSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 ) + IF( P.LT.(K-1) ) + $ CALL DSWAP( K-P-1, A( P+1, K ), 1, A( P, P+1 ), + $ LDA ) + T = A( K, K ) + A( K, K ) = A( P, P ) + A( P, P ) = T + END IF +* +* Second swap +* + KK = K - KSTEP + 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the leading +* submatrix A(1:k,1:k) +* + IF( KP.GT.1 ) + $ CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) + IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) ) + $ CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K-1, K ) + A( K-1, K ) = A( KP, K ) + A( KP, K ) = T + END IF + END IF +* +* Update the leading submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* + IF( K.GT.1 ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) and +* store U(k) in column k +* + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*1/D(k)*W(k)**T +* + D11 = ONE / A( K, K ) + CALL DSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) +* +* Store U(k) in column k +* + CALL DSCAL( K-1, D11, A( 1, K ), 1 ) + ELSE +* +* Store L(k) in column K +* + D11 = A( K, K ) + DO 16 II = 1, K - 1 + A( II, K ) = A( II, K ) / D11 + 16 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL DSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k-1 now hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* +* Perform a rank-2 update of A(1:k-2,1:k-2) as +* +* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T +* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.GT.2 ) THEN +* + D12 = A( K-1, K ) + D22 = A( K-1, K-1 ) / D12 + D11 = A( K, K ) / D12 + T = ONE / ( D11*D22-ONE ) +* + DO 30 J = K - 2, 1, -1 +* + WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) + WK = T*( D22*A( J, K )-A( J, K-1 ) ) +* + DO 20 I = J, 1, -1 + A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - + $ ( A( I, K-1 ) / D12 )*WKM1 + 20 CONTINUE +* +* Store U(k) and U(k-1) in cols k and k-1 for row J +* + A( J, K ) = WK / D12 + A( J, K-1 ) = WKM1 / D12 +* + 30 CONTINUE +* + END IF +* + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2 +* + K = 1 + 40 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 70 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( A( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 ) + COLMAX = ABS( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + ELSE +* +* Test for interchange +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABSAKK.GE.ALPHA*COLMAX +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 42 CONTINUE +* +* Begin pivot search loop body +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA ) + ROWMAX = ABS( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ), + $ 1 ) + DTEMP = ABS( A( ITEMP, IMAX ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX +* + IF( .NOT.( ABS( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX .EQ. COLMAX, +* used to handle NaN and Inf +* + ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot NOT found, set variables and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 42 +* + END IF +* +* Swap TWO rows and TWO columns +* +* First swap +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Interchange rows and column K and P in the trailing +* submatrix A(k:n,k:n) if we have a 2-by-2 pivot +* + IF( P.LT.N ) + $ CALL DSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) + IF( P.GT.(K+1) ) + $ CALL DSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA ) + T = A( K, K ) + A( K, K ) = A( P, P ) + A( P, P ) = T + END IF +* +* Second swap +* + KK = K + KSTEP - 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the trailing +* submatrix A(k:n,k:n) +* + IF( KP.LT.N ) + $ CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) ) + $ CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K+1, K ) + A( K+1, K ) = A( KP, K ) + A( KP, K ) = T + END IF + END IF +* +* Update the trailing submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* + IF( K.LT.N ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) and +* store L(k) in column k +* + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* + D11 = ONE / A( K, K ) + CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) +* +* Store L(k) in column k +* + CALL DSCAL( N-K, D11, A( K+1, K ), 1 ) + ELSE +* +* Store L(k) in column k +* + D11 = A( K, K ) + DO 46 II = K + 1, N + A( II, K ) = A( II, K ) / D11 + 46 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* +* +* Perform a rank-2 update of A(k+2:n,k+2:n) as +* +* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T +* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.LT.N-1 ) THEN +* + D21 = A( K+1, K ) + D11 = A( K+1, K+1 ) / D21 + D22 = A( K, K ) / D21 + T = ONE / ( D11*D22-ONE ) +* + DO 60 J = K + 2, N +* +* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* + WK = T*( D11*A( J, K )-A( J, K+1 ) ) + WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) +* +* Perform a rank-2 update of A(k+2:n,k+2:n) +* + DO 50 I = J, N + A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - + $ ( A( I, K+1 ) / D21 )*WKP1 + 50 CONTINUE +* +* Store L(k) and L(k+1) in cols k and k+1 for row J +* + A( J, K ) = WK / D21 + A( J, K+1 ) = WKP1 / D21 +* + 60 CONTINUE +* + END IF +* + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 40 +* + END IF +* + 70 CONTINUE +* + RETURN +* +* End of DSYTF2_ROOK +* + END diff --git a/lapack-netlib/SRC/dsytrf_rook.f b/lapack-netlib/SRC/dsytrf_rook.f new file mode 100644 index 000000000..81264872a --- /dev/null +++ b/lapack-netlib/SRC/dsytrf_rook.f @@ -0,0 +1,393 @@ +*> \brief \b DSYTRF_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRF_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTRF_ROOK computes the factorization of a real symmetric matrix A +*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. +*> The form of the factorization is +*> +*> A = U*D*U**T or A = L*D*L**T +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and D is symmetric and block diagonal with +*> 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, the block diagonal matrix D and the multipliers used +*> to obtain the factor U or L (see below for further details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)). +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >=1. For best performance +*> LWORK >= N*NB, where NB is the block size returned by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', then A = U*D*U**T, where +*> U = P(n)*U(n)* ... *P(k)U(k)* ..., +*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to +*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I v 0 ) k-s +*> U(k) = ( 0 I 0 ) s +*> ( 0 0 I ) n-k +*> k-s s n-k +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). +*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), +*> and A(k,k), and v overwrites A(1:k-2,k-1:k). +*> +*> If UPLO = 'L', then A = L*D*L**T, where +*> L = P(1)*L(1)* ... *P(k)*L(k)* ..., +*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to +*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I 0 0 ) k-1 +*> L(k) = ( 0 I 0 ) s +*> ( 0 v I ) n-k-s+1 +*> k-1 s n-k-s+1 +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). +*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), +*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> April 2012, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLASYF_ROOK, DSYTF2_ROOK, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size +* + NB = ILAENV( 1, 'DSYTRF_ROOK', UPLO, N, -1, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRF_ROOK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* + NBMIN = 2 + LDWORK = N + IF( NB.GT.1 .AND. NB.LT.N ) THEN + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN + NB = MAX( LWORK / LDWORK, 1 ) + NBMIN = MAX( 2, ILAENV( 2, 'DSYTRF_ROOK', + $ UPLO, N, -1, -1, -1 ) ) + END IF + ELSE + IWS = 1 + END IF + IF( NB.LT.NBMIN ) + $ NB = N +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* KB, where KB is the number of columns factorized by DLASYF_ROOK; +* KB is either NB or NB-1, or K for the last block +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 40 +* + IF( K.GT.NB ) THEN +* +* Factorize columns k-kb+1:k of A and use blocked code to +* update columns 1:k-kb +* + CALL DLASYF_ROOK( UPLO, K, NB, KB, A, LDA, + $ IPIV, WORK, LDWORK, IINFO ) + ELSE +* +* Use unblocked code to factorize columns 1:k of A +* + CALL DSYTF2_ROOK( UPLO, K, A, LDA, IPIV, IINFO ) + KB = K + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO +* +* No need to adjust IPIV +* +* Decrease K and return to the start of the main loop +* + K = K - KB + GO TO 10 +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* KB, where KB is the number of columns factorized by DLASYF_ROOK; +* KB is either NB or NB-1, or N-K+1 for the last block +* + K = 1 + 20 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 40 +* + IF( K.LE.N-NB ) THEN +* +* Factorize columns k:k+kb-1 of A and use blocked code to +* update columns k+kb:n +* + CALL DLASYF_ROOK( UPLO, N-K+1, NB, KB, A( K, K ), LDA, + $ IPIV( K ), WORK, LDWORK, IINFO ) + ELSE +* +* Use unblocked code to factorize columns k:n of A +* + CALL DSYTF2_ROOK( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), + $ IINFO ) + KB = N - K + 1 + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + K - 1 +* +* Adjust IPIV +* + DO 30 J = K, K + KB - 1 + IF( IPIV( J ).GT.0 ) THEN + IPIV( J ) = IPIV( J ) + K - 1 + ELSE + IPIV( J ) = IPIV( J ) - K + 1 + END IF + 30 CONTINUE +* +* Increase K and return to the start of the main loop +* + K = K + KB + GO TO 20 +* + END IF +* + 40 CONTINUE + WORK( 1 ) = LWKOPT + RETURN +* +* End of DSYTRF_ROOK +* + END diff --git a/lapack-netlib/SRC/dsytri_rook.f b/lapack-netlib/SRC/dsytri_rook.f new file mode 100644 index 000000000..f5b42a297 --- /dev/null +++ b/lapack-netlib/SRC/dsytri_rook.f @@ -0,0 +1,450 @@ +*> \brief \b DSYTRI_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRI_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTRI_ROOK computes the inverse of a real symmetric +*> matrix A using the factorization A = U*D*U**T or A = L*D*L**T +*> computed by DSYTRF_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the block diagonal matrix D and the multipliers +*> used to obtain the factor U or L as computed by DSYTRF_ROOK. +*> +*> On exit, if INFO = 0, the (symmetric) inverse of the original +*> matrix. If UPLO = 'U', the upper triangular part of the +*> inverse is formed and the part of A below the diagonal is not +*> referenced; if UPLO = 'L' the lower triangular part of the +*> inverse is formed and the part of A above the diagonal is +*> not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF_ROOK. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> April 2012, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER K, KP, KSTEP + DOUBLE PRECISION AK, AKKP1, AKP1, D, T, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DSWAP, DSYMV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRI_ROOK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO 10 INFO = N, 1, -1 + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) + $ RETURN + 10 CONTINUE + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO 20 INFO = 1, N + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) + $ RETURN + 20 CONTINUE + END IF + INFO = 0 +* + IF( UPPER ) THEN +* +* Compute inv(A) from the factorization A = U*D*U**T. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + 30 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 40 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Invert the diagonal block. +* + A( K, K ) = ONE / A( K, K ) +* +* Compute column K of the inverse. +* + IF( K.GT.1 ) THEN + CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 ) + CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, + $ A( 1, K ), 1 ) + A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ), + $ 1 ) + END IF + KSTEP = 1 + ELSE +* +* 2 x 2 diagonal block +* +* Invert the diagonal block. +* + T = ABS( A( K, K+1 ) ) + AK = A( K, K ) / T + AKP1 = A( K+1, K+1 ) / T + AKKP1 = A( K, K+1 ) / T + D = T*( AK*AKP1-ONE ) + A( K, K ) = AKP1 / D + A( K+1, K+1 ) = AK / D + A( K, K+1 ) = -AKKP1 / D +* +* Compute columns K and K+1 of the inverse. +* + IF( K.GT.1 ) THEN + CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 ) + CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, + $ A( 1, K ), 1 ) + A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ), + $ 1 ) + A( K, K+1 ) = A( K, K+1 ) - + $ DDOT( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 ) + CALL DCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 ) + CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, + $ A( 1, K+1 ), 1 ) + A( K+1, K+1 ) = A( K+1, K+1 ) - + $ DDOT( K-1, WORK, 1, A( 1, K+1 ), 1 ) + END IF + KSTEP = 2 + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* Interchange rows and columns K and IPIV(K) in the leading +* submatrix A(1:k+1,1:k+1) +* + KP = IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.GT.1 ) + $ CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) + CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + ELSE +* +* Interchange rows and columns K and K+1 with -IPIV(K) and +* -IPIV(K+1)in the leading submatrix A(1:k+1,1:k+1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.GT.1 ) + $ CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) + CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) +* + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + TEMP = A( K, K+1 ) + A( K, K+1 ) = A( KP, K+1 ) + A( KP, K+1 ) = TEMP + END IF +* + K = K + 1 + KP = -IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.GT.1 ) + $ CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) + CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + END IF +* + K = K + 1 + GO TO 30 + 40 CONTINUE +* + ELSE +* +* Compute inv(A) from the factorization A = L*D*L**T. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = N + 50 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 60 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Invert the diagonal block. +* + A( K, K ) = ONE / A( K, K ) +* +* Compute column K of the inverse. +* + IF( K.LT.N ) THEN + CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) + CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, + $ ZERO, A( K+1, K ), 1 ) + A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ), + $ 1 ) + END IF + KSTEP = 1 + ELSE +* +* 2 x 2 diagonal block +* +* Invert the diagonal block. +* + T = ABS( A( K, K-1 ) ) + AK = A( K-1, K-1 ) / T + AKP1 = A( K, K ) / T + AKKP1 = A( K, K-1 ) / T + D = T*( AK*AKP1-ONE ) + A( K-1, K-1 ) = AKP1 / D + A( K, K ) = AK / D + A( K, K-1 ) = -AKKP1 / D +* +* Compute columns K-1 and K of the inverse. +* + IF( K.LT.N ) THEN + CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) + CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, + $ ZERO, A( K+1, K ), 1 ) + A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ), + $ 1 ) + A( K, K-1 ) = A( K, K-1 ) - + $ DDOT( N-K, A( K+1, K ), 1, A( K+1, K-1 ), + $ 1 ) + CALL DCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 ) + CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, + $ ZERO, A( K+1, K-1 ), 1 ) + A( K-1, K-1 ) = A( K-1, K-1 ) - + $ DDOT( N-K, WORK, 1, A( K+1, K-1 ), 1 ) + END IF + KSTEP = 2 + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* Interchange rows and columns K and IPIV(K) in the trailing +* submatrix A(k-1:n,k-1:n) +* + KP = IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.LT.N ) + $ CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) + CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA ) + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + ELSE +* +* Interchange rows and columns K and K-1 with -IPIV(K) and +* -IPIV(K-1) in the trailing submatrix A(k-1:n,k-1:n) +* + KP = -IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.LT.N ) + $ CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) + CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA ) +* + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + TEMP = A( K, K-1 ) + A( K, K-1 ) = A( KP, K-1 ) + A( KP, K-1 ) = TEMP + END IF +* + K = K - 1 + KP = -IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.LT.N ) + $ CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) + CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA ) + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + END IF +* + K = K - 1 + GO TO 50 + 60 CONTINUE + END IF +* + RETURN +* +* End of DSYTRI_ROOK +* + END diff --git a/lapack-netlib/SRC/dsytrs_rook.f b/lapack-netlib/SRC/dsytrs_rook.f new file mode 100644 index 000000000..b1cb9b152 --- /dev/null +++ b/lapack-netlib/SRC/dsytrs_rook.f @@ -0,0 +1,484 @@ +*> \brief \b DSYTRS_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRS_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTRS_ROOK solves a system of linear equations A*X = B with +*> a real symmetric matrix A using the factorization A = U*D*U**T or +*> A = L*D*L**T computed by DSYTRF_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by DSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup doubleSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> April 2012, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + $ INFO ) +* +* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J, K, KP + DOUBLE PRECISION AK, AKM1, AKM1K, BK, BKM1, DENOM +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DGER, DSCAL, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRS_ROOK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Solve A*X = B, where A = U*D*U**T. +* +* First solve U*D*X = B, overwriting B with X. +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 30 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(U(K)), where U(K) is the transformation +* stored in column K of A. +* + CALL DGER( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, + $ B( 1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + CALL DSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB ) + K = K - 1 + ELSE +* +* 2 x 2 diagonal block +* +* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K-1 ) + IF( KP.NE.K-1 ) + $ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(U(K)), where U(K) is the transformation +* stored in columns K-1 and K of A. +* + IF( K.GT.2 ) THEN + CALL DGER( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), + $ LDB, B( 1, 1 ), LDB ) + CALL DGER( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ), + $ LDB, B( 1, 1 ), LDB ) + END IF +* +* Multiply by the inverse of the diagonal block. +* + AKM1K = A( K-1, K ) + AKM1 = A( K-1, K-1 ) / AKM1K + AK = A( K, K ) / AKM1K + DENOM = AKM1*AK - ONE + DO 20 J = 1, NRHS + BKM1 = B( K-1, J ) / AKM1K + BK = B( K, J ) / AKM1K + B( K-1, J ) = ( AK*BKM1-BK ) / DENOM + B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM + 20 CONTINUE + K = K - 2 + END IF +* + GO TO 10 + 30 CONTINUE +* +* Next solve U**T *X = B, overwriting B with X. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + 40 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 50 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Multiply by inv(U**T(K)), where U(K) is the transformation +* stored in column K of A. +* + IF( K.GT.1 ) + $ CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, + $ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB ) +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K + 1 + ELSE +* +* 2 x 2 diagonal block +* +* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation +* stored in columns K and K+1 of A. +* + IF( K.GT.1 ) THEN + CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, + $ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB ) + CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, + $ LDB, A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB ) + END IF +* +* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1). +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K+1 ) + IF( KP.NE.K+1 ) + $ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) +* + K = K + 2 + END IF +* + GO TO 40 + 50 CONTINUE +* + ELSE +* +* Solve A*X = B, where A = L*D*L**T. +* +* First solve L*D*X = B, overwriting B with X. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + 60 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 80 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(L(K)), where L(K) is the transformation +* stored in column K of A. +* + IF( K.LT.N ) + $ CALL DGER( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ), + $ LDB, B( K+1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + CALL DSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB ) + K = K + 1 + ELSE +* +* 2 x 2 diagonal block +* +* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K+1 ) + IF( KP.NE.K+1 ) + $ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(L(K)), where L(K) is the transformation +* stored in columns K and K+1 of A. +* + IF( K.LT.N-1 ) THEN + CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ), + $ LDB, B( K+2, 1 ), LDB ) + CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1, + $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) + END IF +* +* Multiply by the inverse of the diagonal block. +* + AKM1K = A( K+1, K ) + AKM1 = A( K, K ) / AKM1K + AK = A( K+1, K+1 ) / AKM1K + DENOM = AKM1*AK - ONE + DO 70 J = 1, NRHS + BKM1 = B( K, J ) / AKM1K + BK = B( K+1, J ) / AKM1K + B( K, J ) = ( AK*BKM1-BK ) / DENOM + B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM + 70 CONTINUE + K = K + 2 + END IF +* + GO TO 60 + 80 CONTINUE +* +* Next solve L**T *X = B, overwriting B with X. +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = N + 90 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 100 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Multiply by inv(L**T(K)), where L(K) is the transformation +* stored in column K of A. +* + IF( K.LT.N ) + $ CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), + $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K - 1 + ELSE +* +* 2 x 2 diagonal block +* +* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation +* stored in columns K-1 and K of A. +* + IF( K.LT.N ) THEN + CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), + $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) + CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), + $ LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ), + $ LDB ) + END IF +* +* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K-1 ) + IF( KP.NE.K-1 ) + $ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) +* + K = K - 2 + END IF +* + GO TO 90 + 100 CONTINUE + END IF +* + RETURN +* +* End of DSYTRS_ROOK +* + END diff --git a/lapack-netlib/SRC/dtpmqrt.f b/lapack-netlib/SRC/dtpmqrt.f index baeffa0f7..b8bf7ce97 100644 --- a/lapack-netlib/SRC/dtpmqrt.f +++ b/lapack-netlib/SRC/dtpmqrt.f @@ -175,7 +175,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup doubleOTHERcomputational * @@ -216,10 +216,10 @@ SUBROUTINE DTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, $ A, LDA, B, LDB, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -235,7 +235,7 @@ * .. * .. Local Scalars .. LOGICAL LEFT, RIGHT, TRAN, NOTRAN - INTEGER I, IB, MB, LB, KF, Q + INTEGER I, IB, MB, LB, KF, LDAQ, LDVQ * .. * .. External Functions .. LOGICAL LSAME @@ -257,10 +257,12 @@ TRAN = LSAME( TRANS, 'T' ) NOTRAN = LSAME( TRANS, 'N' ) * - IF( LEFT ) THEN - Q = M + IF ( LEFT ) THEN + LDVQ = MAX( 1, M ) + LDAQ = MAX( 1, K ) ELSE IF ( RIGHT ) THEN - Q = N + LDVQ = MAX( 1, N ) + LDAQ = MAX( 1, M ) END IF IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN INFO = -1 @@ -274,13 +276,13 @@ INFO = -5 ELSE IF( L.LT.0 .OR. L.GT.K ) THEN INFO = -6 - ELSE IF( NB.LT.1 .OR. NB.GT.K ) THEN + ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0) ) THEN INFO = -7 - ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN + ELSE IF( LDV.LT.LDVQ ) THEN INFO = -9 ELSE IF( LDT.LT.NB ) THEN INFO = -11 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + ELSE IF( LDA.LT.LDAQ ) THEN INFO = -13 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -15 diff --git a/lapack-netlib/SRC/dtpqrt.f b/lapack-netlib/SRC/dtpqrt.f index 95f6fde2d..c8f2e14c1 100644 --- a/lapack-netlib/SRC/dtpqrt.f +++ b/lapack-netlib/SRC/dtpqrt.f @@ -132,7 +132,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup doubleOTHERcomputational * @@ -189,10 +189,10 @@ SUBROUTINE DTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDT, N, M, L, NB @@ -219,9 +219,9 @@ INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 - ELSE IF( L.LT.0 .OR. L.GT.MIN(M,N) ) THEN + ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN INFO = -3 - ELSE IF( NB.LT.1 .OR. NB.GT.N ) THEN + ELSE IF( NB.LT.1 .OR. (NB.GT.N .AND. N.GT.0)) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 diff --git a/lapack-netlib/SRC/ilaver.f b/lapack-netlib/SRC/ilaver.f index a00cbbccf..0f1ee5d87 100644 --- a/lapack-netlib/SRC/ilaver.f +++ b/lapack-netlib/SRC/ilaver.f @@ -48,18 +48,18 @@ * ===================================================================== SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * ===================================================================== * INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH * ===================================================================== VERS_MAJOR = 3 - VERS_MINOR = 4 - VERS_PATCH = 2 + VERS_MINOR = 5 + VERS_PATCH = 0 * ===================================================================== * RETURN diff --git a/lapack-netlib/SRC/sbbcsd.f b/lapack-netlib/SRC/sbbcsd.f index 162d5336f..759d331f6 100644 --- a/lapack-netlib/SRC/sbbcsd.f +++ b/lapack-netlib/SRC/sbbcsd.f @@ -322,7 +322,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup realOTHERcomputational * @@ -332,10 +332,10 @@ $ V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, $ B22D, B22E, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS @@ -358,8 +358,8 @@ PARAMETER ( HUNDRED = 100.0E0, MEIGHTH = -0.125E0, $ ONE = 1.0E0, PIOVER2 = 1.57079632679489662E0, $ TEN = 10.0E0, ZERO = 0.0E0 ) - REAL NEGONECOMPLEX - PARAMETER ( NEGONECOMPLEX = -1.0E0 ) + REAL NEGONE + PARAMETER ( NEGONE = -1.0E0 ) * .. * .. Local Scalars .. LOGICAL COLMAJOR, LQUERY, RESTART11, RESTART12, @@ -477,7 +477,10 @@ * Initial deflation * IMAX = Q - DO WHILE( ( IMAX .GT. 1 ) .AND. ( PHI(IMAX-1) .EQ. ZERO ) ) + DO WHILE( IMAX .GT. 1 ) + IF( PHI(IMAX-1) .NE. ZERO ) THEN + EXIT + END IF IMAX = IMAX - 1 END DO IMIN = IMAX - 1 @@ -939,9 +942,9 @@ B21D(IMAX) = -B21D(IMAX) IF( WANTV1T ) THEN IF( COLMAJOR ) THEN - CALL SSCAL( Q, NEGONECOMPLEX, V1T(IMAX,1), LDV1T ) + CALL SSCAL( Q, NEGONE, V1T(IMAX,1), LDV1T ) ELSE - CALL SSCAL( Q, NEGONECOMPLEX, V1T(1,IMAX), 1 ) + CALL SSCAL( Q, NEGONE, V1T(1,IMAX), 1 ) END IF END IF END IF @@ -962,9 +965,9 @@ B12D(IMAX) = -B12D(IMAX) IF( WANTU1 ) THEN IF( COLMAJOR ) THEN - CALL SSCAL( P, NEGONECOMPLEX, U1(1,IMAX), 1 ) + CALL SSCAL( P, NEGONE, U1(1,IMAX), 1 ) ELSE - CALL SSCAL( P, NEGONECOMPLEX, U1(IMAX,1), LDU1 ) + CALL SSCAL( P, NEGONE, U1(IMAX,1), LDU1 ) END IF END IF END IF @@ -972,9 +975,9 @@ B22D(IMAX) = -B22D(IMAX) IF( WANTU2 ) THEN IF( COLMAJOR ) THEN - CALL SSCAL( M-P, NEGONECOMPLEX, U2(1,IMAX), 1 ) + CALL SSCAL( M-P, NEGONE, U2(1,IMAX), 1 ) ELSE - CALL SSCAL( M-P, NEGONECOMPLEX, U2(IMAX,1), LDU2 ) + CALL SSCAL( M-P, NEGONE, U2(IMAX,1), LDU2 ) END IF END IF END IF @@ -984,9 +987,9 @@ IF( B12D(IMAX)+B22D(IMAX) .LT. 0 ) THEN IF( WANTV2T ) THEN IF( COLMAJOR ) THEN - CALL SSCAL( M-Q, NEGONECOMPLEX, V2T(IMAX,1), LDV2T ) + CALL SSCAL( M-Q, NEGONE, V2T(IMAX,1), LDV2T ) ELSE - CALL SSCAL( M-Q, NEGONECOMPLEX, V2T(1,IMAX), 1 ) + CALL SSCAL( M-Q, NEGONE, V2T(1,IMAX), 1 ) END IF END IF END IF diff --git a/lapack-netlib/SRC/sgebal.f b/lapack-netlib/SRC/sgebal.f index 853ff20e2..6c5d1482e 100644 --- a/lapack-netlib/SRC/sgebal.f +++ b/lapack-netlib/SRC/sgebal.f @@ -121,7 +121,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup realGEcomputational * @@ -160,10 +160,10 @@ * ===================================================================== SUBROUTINE SGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER JOB @@ -192,8 +192,8 @@ * .. External Functions .. LOGICAL SISNAN, LSAME INTEGER ISAMAX - REAL SLAMCH - EXTERNAL SISNAN, LSAME, ISAMAX, SLAMCH + REAL SLAMCH, SNRM2 + EXTERNAL SISNAN, LSAME, ISAMAX, SLAMCH, SNRM2 * .. * .. External Subroutines .. EXTERNAL SSCAL, SSWAP, XERBLA @@ -316,15 +316,9 @@ NOCONV = .FALSE. * DO 200 I = K, L - C = ZERO - R = ZERO -* - DO 150 J = K, L - IF( J.EQ.I ) - $ GO TO 150 - C = C + ABS( A( J, I ) ) - R = R + ABS( A( I, J ) ) - 150 CONTINUE +* + C = SNRM2( L-K+1, A( K, I ), 1 ) + R = SNRM2( L-K+1, A( I, K ), LDA ) ICA = ISAMAX( L, A( 1, I ), 1 ) CA = ABS( A( ICA, I ) ) IRA = ISAMAX( N-K+1, A( I, K ), LDA ) diff --git a/lapack-netlib/SRC/sgemqrt.f b/lapack-netlib/SRC/sgemqrt.f index 443c9d1e8..3b29f765f 100644 --- a/lapack-netlib/SRC/sgemqrt.f +++ b/lapack-netlib/SRC/sgemqrt.f @@ -160,7 +160,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup realGEcomputational * @@ -168,10 +168,10 @@ SUBROUTINE SGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, $ C, LDC, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -225,7 +225,7 @@ INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.Q ) THEN INFO = -5 - ELSE IF( NB.LT.1 .OR. NB.GT.K ) THEN + ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0)) THEN INFO = -6 ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN INFO = -8 diff --git a/lapack-netlib/SRC/sgeqrt.f b/lapack-netlib/SRC/sgeqrt.f index 0efc07b86..e995212a3 100644 --- a/lapack-netlib/SRC/sgeqrt.f +++ b/lapack-netlib/SRC/sgeqrt.f @@ -108,7 +108,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup realGEcomputational * @@ -141,10 +141,10 @@ * ===================================================================== SUBROUTINE SGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDT, M, N, NB @@ -173,7 +173,7 @@ INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 - ELSE IF( NB.LT.1 .OR. NB.GT.MIN(M,N) ) THEN + ELSE IF( NB.LT.1 .OR. ( NB.GT.MIN(M,N) .AND. MIN(M,N).GT.0 ) )THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 diff --git a/lapack-netlib/SRC/sgesdd.f b/lapack-netlib/SRC/sgesdd.f index 821767aaa..746fd3bab 100644 --- a/lapack-netlib/SRC/sgesdd.f +++ b/lapack-netlib/SRC/sgesdd.f @@ -175,8 +175,7 @@ *> LWORK >= 3*min(M,N) + *> max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)). *> If JOBZ = 'S' or 'A' -*> LWORK >= 3*min(M,N) + -*> max(max(M,N),4*min(M,N)*min(M,N)+3*min(M,N)+max(M,N)). +*> LWORK >= min(M,N)*(6+4*min(M,N))+max(M,N) *> For good performance, LWORK should generally be larger. *> If LWORK = -1 but other input arguments are legal, WORK(1) *> returns the optimal LWORK. @@ -203,7 +202,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup realGEsing * @@ -217,10 +216,10 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, $ LWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.4.2) -- +* -- LAPACK driver routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER JOBZ diff --git a/lapack-netlib/SRC/sgetc2.f b/lapack-netlib/SRC/sgetc2.f index 7e9d48507..3c3880d4e 100644 --- a/lapack-netlib/SRC/sgetc2.f +++ b/lapack-netlib/SRC/sgetc2.f @@ -98,7 +98,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup realGEauxiliary * @@ -111,10 +111,10 @@ * ===================================================================== SUBROUTINE SGETC2( N, A, LDA, IPIV, JPIV, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. INTEGER INFO, LDA, N @@ -203,6 +203,11 @@ INFO = N A( N, N ) = SMIN END IF +* +* Set last pivots to N +* + IPIV( N ) = N + JPIV( N ) = N * RETURN * diff --git a/lapack-netlib/SRC/shgeqz.f b/lapack-netlib/SRC/shgeqz.f index 4bd1a1de6..254e65fcf 100644 --- a/lapack-netlib/SRC/shgeqz.f +++ b/lapack-netlib/SRC/shgeqz.f @@ -282,7 +282,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup realGEcomputational * @@ -304,10 +304,10 @@ $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, $ LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOB @@ -739,9 +739,9 @@ * Exceptional shift. Chosen for no particularly good reason. * (Single shift only.) * - IF( ( REAL( MAXIT )*SAFMIN )*ABS( H( ILAST-1, ILAST ) ).LT. + IF( ( REAL( MAXIT )*SAFMIN )*ABS( H( ILAST, ILAST-1 ) ).LT. $ ABS( T( ILAST-1, ILAST-1 ) ) ) THEN - ESHIFT = ESHIFT + H( ILAST, ILAST-1 ) / + ESHIFT = H( ILAST, ILAST-1 ) / $ T( ILAST-1, ILAST-1 ) ELSE ESHIFT = ESHIFT + ONE / ( SAFMIN*REAL( MAXIT ) ) @@ -759,6 +759,16 @@ $ T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1, $ S2, WR, WR2, WI ) * + IF ( ABS( (WR/S1)*T( ILAST, ILAST ) - H( ILAST, ILAST ) ) + $ .GT. ABS( (WR2/S2)*T( ILAST, ILAST ) + $ - H( ILAST, ILAST ) ) ) THEN + TEMP = WR + WR = WR2 + WR2 = TEMP + TEMP = S1 + S1 = S2 + S2 = TEMP + END IF TEMP = MAX( S1, SAFMIN*MAX( ONE, ABS( WR ), ABS( WI ) ) ) IF( WI.NE.ZERO ) $ GO TO 200 diff --git a/lapack-netlib/SRC/shsein.f b/lapack-netlib/SRC/shsein.f index 0c69e2cf8..ffae353e0 100644 --- a/lapack-netlib/SRC/shsein.f +++ b/lapack-netlib/SRC/shsein.f @@ -108,6 +108,7 @@ *> \verbatim *> H is REAL array, dimension (LDH,N) *> The upper Hessenberg matrix H. +*> If a NaN is detected in H, the routine will return with INFO=-6. *> \endverbatim *> *> \param[in] LDH @@ -243,7 +244,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup realOTHERcomputational * @@ -262,10 +263,10 @@ $ VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, $ IFAILR, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER EIGSRC, INITV, SIDE @@ -291,9 +292,9 @@ $ WKR * .. * .. External Functions .. - LOGICAL LSAME + LOGICAL LSAME, SISNAN REAL SLAMCH, SLANHS - EXTERNAL LSAME, SLAMCH, SLANHS + EXTERNAL LSAME, SLAMCH, SLANHS, SISNAN * .. * .. External Subroutines .. EXTERNAL SLAEIN, XERBLA @@ -423,7 +424,10 @@ * has not ben computed before. * HNORM = SLANHS( 'I', KR-KL+1, H( KL, KL ), LDH, WORK ) - IF( HNORM.GT.ZERO ) THEN + IF( SISNAN( HNORM ) ) THEN + INFO = -6 + RETURN + ELSE IF( HNORM.GT.ZERO ) THEN EPS3 = HNORM*ULP ELSE EPS3 = SMLNUM diff --git a/lapack-netlib/SRC/sladiv.f b/lapack-netlib/SRC/sladiv.f index eace5c728..6d26da20c 100644 --- a/lapack-netlib/SRC/sladiv.f +++ b/lapack-netlib/SRC/sladiv.f @@ -36,8 +36,9 @@ *> p + i*q = --------- *> c + i*d *> -*> The algorithm is due to Robert L. Smith and can be found -*> in D. Knuth, The art of Computer Programming, Vol.2, p.195 +*> The algorithm is due to Michael Baudin and Robert L. Smith +*> and can be found in the paper +*> "A Robust Complex Division in Scilab" *> \endverbatim * * Arguments: @@ -83,17 +84,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date January 2013 * *> \ingroup auxOTHERauxiliary * * ===================================================================== SUBROUTINE SLADIV( A, B, C, D, P, Q ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* January 2013 * * .. Scalar Arguments .. REAL A, B, C, D, P, Q @@ -101,24 +102,148 @@ * * ===================================================================== * +* .. Parameters .. + REAL BS + PARAMETER ( BS = 2.0E0 ) + REAL HALF + PARAMETER ( HALF = 0.5E0 ) + REAL TWO + PARAMETER ( TWO = 2.0E0 ) +* * .. Local Scalars .. - REAL E, F + REAL AA, BB, CC, DD, AB, CD, S, OV, UN, BE, EPS +* .. +* .. External Functions .. + REAL SLAMCH + EXTERNAL SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL SLADIV1 * .. * .. Intrinsic Functions .. - INTRINSIC ABS + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + AA = A + BB = B + CC = C + DD = D + AB = MAX( ABS(A), ABS(B) ) + CD = MAX( ABS(C), ABS(D) ) + S = 1.0E0 + + OV = SLAMCH( 'Overflow threshold' ) + UN = SLAMCH( 'Safe minimum' ) + EPS = SLAMCH( 'Epsilon' ) + BE = BS / (EPS*EPS) + + IF( AB >= HALF*OV ) THEN + AA = HALF * AA + BB = HALF * BB + S = TWO * S + END IF + IF( CD >= HALF*OV ) THEN + CC = HALF * CC + DD = HALF * DD + S = HALF * S + END IF + IF( AB <= UN*BS/EPS ) THEN + AA = AA * BE + BB = BB * BE + S = S / BE + END IF + IF( CD <= UN*BS/EPS ) THEN + CC = CC * BE + DD = DD * BE + S = S * BE + END IF + IF( ABS( D ).LE.ABS( C ) ) THEN + CALL SLADIV1(AA, BB, CC, DD, P, Q) + ELSE + CALL SLADIV1(BB, AA, DD, CC, P, Q) + Q = -Q + END IF + P = P * S + Q = Q * S +* + RETURN +* +* End of SLADIV +* + END + + + + SUBROUTINE SLADIV1( A, B, C, D, P, Q ) +* +* -- LAPACK auxiliary routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2013 +* +* .. Scalar Arguments .. + REAL A, B, C, D, P, Q +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E0 ) +* +* .. Local Scalars .. + REAL R, T +* .. +* .. External Functions .. + REAL SLADIV2 + EXTERNAL SLADIV2 +* .. +* .. Executable Statements .. +* + R = D / C + T = ONE / (C + D * R) + P = SLADIV2(A, B, C, D, R, T) + A = -A + Q = SLADIV2(B, A, C, D, R, T) +* + RETURN +* +* End of SLADIV1 +* + END + + REAL FUNCTION SLADIV2( A, B, C, D, R, T ) +* +* -- LAPACK auxiliary routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2013 +* +* .. Scalar Arguments .. + REAL A, B, C, D, R, T +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER ( ZERO = 0.0E0 ) +* +* .. Local Scalars .. + REAL BR * .. * .. Executable Statements .. * - IF( ABS( D ).LT.ABS( C ) ) THEN - E = D / C - F = C + D*E - P = ( A+B*E ) / F - Q = ( B-A*E ) / F + IF( R.NE.ZERO ) THEN + BR = B * R + if( BR.NE.ZERO ) THEN + SLADIV2 = (A + BR) * T + ELSE + SLADIV2 = A * T + (B * T) * R + END IF ELSE - E = C / D - F = D + C*E - P = ( B+A*E ) / F - Q = ( -A+B*E ) / F + SLADIV2 = (A + D * (B / C)) * T END IF * RETURN diff --git a/lapack-netlib/SRC/slarfb.f b/lapack-netlib/SRC/slarfb.f index 7694801e0..78b121d24 100644 --- a/lapack-netlib/SRC/slarfb.f +++ b/lapack-netlib/SRC/slarfb.f @@ -159,7 +159,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2013 * *> \ingroup realOTHERauxiliary * @@ -195,10 +195,10 @@ SUBROUTINE SLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2013 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS @@ -217,12 +217,11 @@ * .. * .. Local Scalars .. CHARACTER TRANST - INTEGER I, J, LASTV, LASTC + INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILASLR, ILASLC - EXTERNAL LSAME, ILASLR, ILASLC + EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL SCOPY, SGEMM, STRMM @@ -252,58 +251,53 @@ * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) -* - LASTV = MAX( K, ILASLR( M, K, V, LDV ) ) - LASTC = ILASLC( LASTV, N, C, LDC ) * * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) * * W := C1**T * DO 10 J = 1, K - CALL SCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL SCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 10 CONTINUE * * W := W * V1 * - CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN * -* W := W + C2**T *V2 +* W := W + C2**T * V2 * - CALL SGEMM( 'Transpose', 'No transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) + CALL SGEMM( 'Transpose', 'No transpose', N, K, M-K, + $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) END IF * * W := W * T**T or W * T * - CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**T * - IF( LASTV.GT.K ) THEN + IF( M.GT.K ) THEN * * C2 := C2 - V2 * W**T * - CALL SGEMM( 'No transpose', 'Transpose', - $ LASTV-K, LASTC, K, - $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, - $ C( K+1, 1 ), LDC ) + CALL SGEMM( 'No transpose', 'Transpose', M-K, N, K, + $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) END IF * * W := W * V1**T * - CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, + $ ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**T * DO 30 J = 1, K - DO 20 I = 1, LASTC + DO 20 I = 1, N C( J, I ) = C( J, I ) - WORK( I, J ) 20 CONTINUE 30 CONTINUE @@ -311,58 +305,53 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILASLR( N, K, V, LDV ) ) - LASTC = ILASLR( M, LASTV, C, LDC ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C1 * DO 40 J = 1, K - CALL SCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + CALL SCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 40 CONTINUE * * W := W * V1 * - CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN * * W := W + C2 * V2 * - CALL SGEMM( 'No transpose', 'No transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) + CALL SGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * - CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**T * - IF( LASTV.GT.K ) THEN + IF( N.GT.K ) THEN * * C2 := C2 - W * V2**T * - CALL SGEMM( 'No transpose', 'Transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, - $ C( 1, K+1 ), LDC ) + CALL SGEMM( 'No transpose', 'Transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) END IF * * W := W * V1**T * - CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, + $ ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 60 J = 1, K - DO 50 I = 1, LASTC + DO 50 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 50 CONTINUE 60 CONTINUE @@ -378,36 +367,31 @@ * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) -* - LASTC = ILASLC( M, N, C, LDC ) * * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) * * W := C2**T * DO 70 J = 1, K - CALL SCOPY( LASTC, C( M-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) + CALL SCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 70 CONTINUE * * W := W * V2 * - CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( M-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * -* W := W + C1**T*V1 +* W := W + C1**T * V1 * - CALL SGEMM( 'Transpose', 'No transpose', - $ LASTC, K, M-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL SGEMM( 'Transpose', 'No transpose', N, K, M-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**T or W * T * - CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**T * @@ -415,57 +399,51 @@ * * C1 := C1 - V1 * W**T * - CALL SGEMM( 'No transpose', 'Transpose', - $ M-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) + CALL SGEMM( 'No transpose', 'Transpose', M-K, N, K, + $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2**T * - CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( M-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W**T * DO 90 J = 1, K - DO 80 I = 1, LASTC - C( M-K+J, I ) = C( M-K+J, I ) - WORK(I, J) + DO 80 I = 1, N + C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) 80 CONTINUE 90 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTC = ILASLR( M, N, C, LDC ) +* Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C2 * DO 100 J = 1, K - CALL SCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) + CALL SCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 100 CONTINUE * * W := W * V2 * - CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( N-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1 * - CALL SGEMM( 'No transpose', 'No transpose', - $ LASTC, K, N-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL SGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * - CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**T * @@ -473,22 +451,20 @@ * * C1 := C1 - W * V1**T * - CALL SGEMM( 'No transpose', 'Transpose', - $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) + CALL SGEMM( 'No transpose', 'Transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2**T * - CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( N-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, + $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W * DO 120 J = 1, K - DO 110 I = 1, LASTC - C( I, N-K+J ) = C( I, N-K+J ) - WORK(I, J) + DO 110 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 110 CONTINUE 120 CONTINUE END IF @@ -505,58 +481,53 @@ * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) -* - LASTV = MAX( K, ILASLC( K, M, V, LDV ) ) - LASTC = ILASLC( LASTV, N, C, LDC ) * * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) * * W := C1**T * DO 130 J = 1, K - CALL SCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL SCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 130 CONTINUE * * W := W * V1**T * - CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN * -* W := W + C2**T*V2**T +* W := W + C2**T * V2**T * - CALL SGEMM( 'Transpose', 'Transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) + CALL SGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, + $ WORK, LDWORK ) END IF * * W := W * T**T or W * T * - CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**T * W**T * - IF( LASTV.GT.K ) THEN + IF( M.GT.K ) THEN * * C2 := C2 - V2**T * W**T * - CALL SGEMM( 'Transpose', 'Transpose', - $ LASTV-K, LASTC, K, - $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, - $ ONE, C( K+1, 1 ), LDC ) + CALL SGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, + $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) END IF * * W := W * V1 * - CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**T * DO 150 J = 1, K - DO 140 I = 1, LASTC + DO 140 I = 1, N C( J, I ) = C( J, I ) - WORK( I, J ) 140 CONTINUE 150 CONTINUE @@ -564,58 +535,53 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILASLC( K, N, V, LDV ) ) - LASTC = ILASLR( M, LASTV, C, LDC ) * * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) * * W := C1 * DO 160 J = 1, K - CALL SCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + CALL SCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 160 CONTINUE * * W := W * V1**T * - CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, + $ ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN * * W := W + C2 * V2**T * - CALL SGEMM( 'No transpose', 'Transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) + CALL SGEMM( 'No transpose', 'Transpose', M, K, N-K, + $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, + $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * - CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * - IF( LASTV.GT.K ) THEN + IF( N.GT.K ) THEN * * C2 := C2 - W * V2 * - CALL SGEMM( 'No transpose', 'No transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, - $ ONE, C( 1, K+1 ), LDC ) + CALL SGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) END IF * * W := W * V1 * - CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 180 J = 1, K - DO 170 I = 1, LASTC + DO 170 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 170 CONTINUE 180 CONTINUE @@ -631,36 +597,31 @@ * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) -* - LASTC = ILASLC( M, N, C, LDC ) * * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) * * W := C2**T * DO 190 J = 1, K - CALL SCOPY( LASTC, C( M-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) + CALL SCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 190 CONTINUE * * W := W * V2**T * - CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( 1, M-K+1 ), LDV, - $ WORK, LDWORK ) + CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, + $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C1**T * V1**T * - CALL SGEMM( 'Transpose', 'Transpose', - $ LASTC, K, M-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL SGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**T or W * T * - CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**T * W**T * @@ -668,58 +629,51 @@ * * C1 := C1 - V1**T * W**T * - CALL SGEMM( 'Transpose', 'Transpose', - $ M-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) + CALL SGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, + $ V, LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2 * - CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, M-K+1 ), LDV, - $ WORK, LDWORK ) + CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W**T * DO 210 J = 1, K - DO 200 I = 1, LASTC - C( M-K+J, I ) = C( M-K+J, I ) - WORK(I, J) + DO 200 I = 1, N + C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) 200 CONTINUE 210 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTC = ILASLR( M, N, C, LDC ) * * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) * * W := C2 * DO 220 J = 1, K - CALL SCOPY( LASTC, C( 1, N-K+J ), 1, - $ WORK( 1, J ), 1 ) + CALL SCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 220 CONTINUE * * W := W * V2**T * - CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( 1, N-K+1 ), LDV, - $ WORK, LDWORK ) + CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, + $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1**T * - CALL SGEMM( 'No transpose', 'Transpose', - $ LASTC, K, N-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL SGEMM( 'No transpose', 'Transpose', M, K, N-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * - CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * @@ -727,21 +681,19 @@ * * C1 := C1 - W * V1 * - CALL SGEMM( 'No transpose', 'No transpose', - $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) + CALL SGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2 * - CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, N-K+1 ), LDV, - $ WORK, LDWORK ) + CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 240 J = 1, K - DO 230 I = 1, LASTC + DO 230 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 230 CONTINUE 240 CONTINUE diff --git a/lapack-netlib/SRC/slasd4.f b/lapack-netlib/SRC/slasd4.f index bf0f2cf3e..0c5daca03 100644 --- a/lapack-netlib/SRC/slasd4.f +++ b/lapack-netlib/SRC/slasd4.f @@ -140,7 +140,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup auxOTHERauxiliary * @@ -153,10 +153,10 @@ * ===================================================================== SUBROUTINE SLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. INTEGER I, INFO, N diff --git a/lapack-netlib/SRC/slasyf.f b/lapack-netlib/SRC/slasyf.f index 20c8ffaec..58dace2ee 100644 --- a/lapack-netlib/SRC/slasyf.f +++ b/lapack-netlib/SRC/slasyf.f @@ -1,25 +1,25 @@ -*> \brief \b SLASYF computes a partial factorization of a real symmetric matrix, using the diagonal pivoting method. +*> \brief \b SLASYF computes a partial factorization of a real symmetric matrix using the Bunch-Kaufman diagonal pivoting method. * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download SLASYF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download SLASYF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KB, LDA, LDW, N, NB @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ), W( LDW, * ) * .. -* +* * *> \par Purpose: * ============= @@ -109,16 +109,26 @@ *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D. -*> If UPLO = 'U', only the last KB elements of IPIV are set; -*> if UPLO = 'L', only the first KB elements are set. *> -*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were -*> interchanged and D(k,k) is a 1-by-1 diagonal block. -*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and -*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) -*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = -*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were -*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> If UPLO = 'U': +*> Only the last KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns +*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) +*> is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> Only the first KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns +*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1) +*> is a 2-by-2 diagonal block. *> \endverbatim *> *> \param[out] W @@ -144,22 +154,32 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup realSYcomputational * +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> \endverbatim +* * ===================================================================== SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER UPLO @@ -237,7 +257,8 @@ ABSAKK = ABS( W( K, KW ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. * IF( K.GT.1 ) THEN IMAX = ISAMAX( K-1, W( 1, KW ), 1 ) @@ -248,7 +269,7 @@ * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * -* Column K is zero: set INFO and continue +* Column K is zero or underflow: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K @@ -293,7 +314,7 @@ * KP = IMAX * -* copy column KW-1 of W to column KW +* copy column KW-1 of W to column KW of W * CALL SCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) ELSE @@ -305,60 +326,118 @@ KSTEP = 2 END IF END IF +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped * KK = K - KSTEP + 1 +* +* KKW is the column of W which corresponds to column KK of A +* KKW = NB + KK - N * -* Updated column KP is already stored in column KKW of W +* Interchange rows and columns KP and KK. +* Updated column KP is already stored in column KKW of W. * IF( KP.NE.KK ) THEN * -* Copy non-updated column KK to column KP +* Copy non-updated column KK to column KP of submatrix A +* at step K. No need to copy element into column K +* (or K and K-1 for 2-by-2 pivot) of A, since these columns +* will be later overwritten. * - A( KP, K ) = A( KK, K ) - CALL SCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), + A( KP, KP ) = A( KK, KK ) + CALL SCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), $ LDA ) - CALL SCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 ) + IF( KP.GT.1 ) + $ CALL SCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) * -* Interchange rows KK and KP in last KK columns of A and W +* Interchange rows KK and KP in last K+1 to N columns of A +* (columns K (or K and K-1 for 2-by-2 pivot) of A will be +* later overwritten). Interchange rows KK and KP +* in last KKW to NB columns of W. * - CALL SSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA ) + IF( K.LT.N ) + $ CALL SSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ), + $ LDA ) CALL SSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), $ LDW ) END IF * IF( KSTEP.EQ.1 ) THEN * -* 1-by-1 pivot block D(k): column KW of W now holds +* 1-by-1 pivot block D(k): column kw of W now holds * -* W(k) = U(k)*D(k) +* W(kw) = U(k)*D(k), * * where U(k) is the k-th column of U * -* Store U(k) in column k of A +* Store subdiag. elements of column U(k) +* and 1-by-1 block D(k) in column k of A. +* NOTE: Diagonal element U(k,k) is a UNIT element +* and not stored. +* A(k,k) := D(k,k) = W(k,kw) +* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k) * CALL SCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) R1 = ONE / A( K, K ) CALL SSCAL( K-1, R1, A( 1, K ), 1 ) +* ELSE * -* 2-by-2 pivot block D(k): columns KW and KW-1 of W now -* hold +* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold * -* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k) * * where U(k) and U(k-1) are the k-th and (k-1)-th columns * of U +* +* Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2 +* block D(k-1:k,k-1:k) in columns k-1 and k of A. +* NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT +* block and not stored. +* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw) +* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) = +* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) ) * IF( K.GT.2 ) THEN * -* Store U(k) and U(k-1) in columns k and k-1 of A +* Compose the columns of the inverse of 2-by-2 pivot +* block D in the following way to reduce the number +* of FLOPS when we myltiply panel ( W(kw-1) W(kw) ) by +* this inverse +* +* D**(-1) = ( d11 d21 )**(-1) = +* ( d21 d22 ) +* +* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = +* ( (-d21 ) ( d11 ) ) +* +* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * +* +* * ( ( d22/d21 ) ( -1 ) ) = +* ( ( -1 ) ( d11/d21 ) ) +* +* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = 1/d21 * T * ( ( D11 ) ( -1 ) ) +* ( ( -1 ) ( D22 ) ) +* +* = D21 * ( ( D11 ) ( -1 ) ) +* ( ( -1 ) ( D22 ) ) * D21 = W( K-1, KW ) D11 = W( K, KW ) / D21 D22 = W( K-1, KW-1 ) / D21 T = ONE / ( D11*D22-ONE ) D21 = T / D21 +* +* Update elements in columns A(k-1) and A(k) as +* dot products of rows of ( W(kw-1) W(kw) ) and columns +* of D**(-1) +* DO 20 J = 1, K - 2 A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) ) @@ -370,7 +449,9 @@ A( K-1, K-1 ) = W( K-1, KW-1 ) A( K-1, K ) = W( K-1, KW ) A( K, K ) = W( K, KW ) +* END IF +* END IF * * Store details of the interchanges in IPIV @@ -414,20 +495,28 @@ 50 CONTINUE * * Put U12 in standard form by partially undoing the interchanges -* in columns k+1:n +* in columns k+1:n looping backwards from k+1 to n * J = K + 1 60 CONTINUE - JJ = J - JP = IPIV( J ) - IF( JP.LT.0 ) THEN - JP = -JP +* +* Undo the interchanges (if any) of rows JJ and JP at each +* step J +* +* (Here, J is a diagonal index) + JJ = J + JP = IPIV( J ) + IF( JP.LT.0 ) THEN + JP = -JP +* (Here, J is a diagonal index) + J = J + 1 + END IF +* (NOTE: Here, J is used to determine row length. Length N-J+1 +* of the rows to swap back doesn't include diagonal element) J = J + 1 - END IF - J = J + 1 - IF( JP.NE.JJ .AND. J.LE.N ) - $ CALL SSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA ) - IF( J.LE.N ) + IF( JP.NE.JJ .AND. J.LE.N ) + $ CALL SSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA ) + IF( J.LT.N ) $ GO TO 60 * * Set KB to the number of columns factorized @@ -464,7 +553,8 @@ ABSAKK = ABS( W( K, K ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. * IF( K.LT.N ) THEN IMAX = K + ISAMAX( N-K, W( K+1, K ), 1 ) @@ -475,7 +565,7 @@ * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * -* Column K is zero: set INFO and continue +* Column K is zero or underflow: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K @@ -518,7 +608,7 @@ * KP = IMAX * -* copy column K+1 of W to column K +* copy column K+1 of W to column K of W * CALL SCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) ELSE @@ -530,22 +620,36 @@ KSTEP = 2 END IF END IF +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped * KK = K + KSTEP - 1 * -* Updated column KP is already stored in column KK of W +* Interchange rows and columns KP and KK. +* Updated column KP is already stored in column KK of W. * IF( KP.NE.KK ) THEN * -* Copy non-updated column KK to column KP +* Copy non-updated column KK to column KP of submatrix A +* at step K. No need to copy element into column K +* (or K and K+1 for 2-by-2 pivot) of A, since these columns +* will be later overwritten. * - A( KP, K ) = A( KK, K ) - CALL SCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA ) - CALL SCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 ) + A( KP, KP ) = A( KK, KK ) + CALL SCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ LDA ) + IF( KP.LT.N ) + $ CALL SCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) * -* Interchange rows KK and KP in first KK columns of A and W +* Interchange rows KK and KP in first K-1 columns of A +* (columns K (or K and K+1 for 2-by-2 pivot) of A will be +* later overwritten). Interchange rows KK and KP +* in first KK columns of W. * - CALL SSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) + IF( K.GT.1 ) + $ CALL SSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) CALL SSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) END IF * @@ -553,17 +657,23 @@ * * 1-by-1 pivot block D(k): column k of W now holds * -* W(k) = L(k)*D(k) +* W(k) = L(k)*D(k), * * where L(k) is the k-th column of L * -* Store L(k) in column k of A +* Store subdiag. elements of column L(k) +* and 1-by-1 block D(k) in column k of A. +* (NOTE: Diagonal element L(k,k) is a UNIT element +* and not stored) +* A(k,k) := D(k,k) = W(k,k) +* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k) * CALL SCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) IF( K.LT.N ) THEN R1 = ONE / A( K, K ) CALL SSCAL( N-K, R1, A( K+1, K ), 1 ) END IF +* ELSE * * 2-by-2 pivot block D(k): columns k and k+1 of W now hold @@ -572,16 +682,52 @@ * * where L(k) and L(k+1) are the k-th and (k+1)-th columns * of L +* +* Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2 +* block D(k:k+1,k:k+1) in columns k and k+1 of A. +* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT +* block and not stored) +* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1) +* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) = +* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) ) * IF( K.LT.N-1 ) THEN * -* Store L(k) and L(k+1) in columns k and k+1 of A +* Compose the columns of the inverse of 2-by-2 pivot +* block D in the following way to reduce the number +* of FLOPS when we myltiply panel ( W(k) W(k+1) ) by +* this inverse +* +* D**(-1) = ( d11 d21 )**(-1) = +* ( d21 d22 ) +* +* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = +* ( (-d21 ) ( d11 ) ) +* +* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * +* +* * ( ( d22/d21 ) ( -1 ) ) = +* ( ( -1 ) ( d11/d21 ) ) +* +* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = 1/d21 * T * ( ( D11 ) ( -1 ) ) +* ( ( -1 ) ( D22 ) ) +* +* = D21 * ( ( D11 ) ( -1 ) ) +* ( ( -1 ) ( D22 ) ) * D21 = W( K+1, K ) D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / D21 T = ONE / ( D11*D22-ONE ) D21 = T / D21 +* +* Update elements in columns A(k) and A(k+1) as +* dot products of rows of ( W(k) W(k+1) ) and columns +* of D**(-1) +* DO 80 J = K + 2, N A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) ) A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) @@ -593,7 +739,9 @@ A( K, K ) = W( K, K ) A( K+1, K ) = W( K+1, K ) A( K+1, K+1 ) = W( K+1, K+1 ) +* END IF +* END IF * * Store details of the interchanges in IPIV @@ -638,20 +786,28 @@ 110 CONTINUE * * Put L21 in standard form by partially undoing the interchanges -* in columns 1:k-1 +* of rows in columns 1:k-1 looping backwards from k-1 to 1 * J = K - 1 120 CONTINUE - JJ = J - JP = IPIV( J ) - IF( JP.LT.0 ) THEN - JP = -JP +* +* Undo the interchanges (if any) of rows JJ and JP at each +* step J +* +* (Here, J is a diagonal index) + JJ = J + JP = IPIV( J ) + IF( JP.LT.0 ) THEN + JP = -JP +* (Here, J is a diagonal index) + J = J - 1 + END IF +* (NOTE: Here, J is used to determine row length. Length J +* of the rows to swap back doesn't include diagonal element) J = J - 1 - END IF - J = J - 1 - IF( JP.NE.JJ .AND. J.GE.1 ) - $ CALL SSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA ) - IF( J.GE.1 ) + IF( JP.NE.JJ .AND. J.GE.1 ) + $ CALL SSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA ) + IF( J.GT.1 ) $ GO TO 120 * * Set KB to the number of columns factorized diff --git a/lapack-netlib/SRC/slasyf_rook.f b/lapack-netlib/SRC/slasyf_rook.f new file mode 100644 index 000000000..65bb2ad9d --- /dev/null +++ b/lapack-netlib/SRC/slasyf_rook.f @@ -0,0 +1,892 @@ +*> \brief \b SLASYF_ROOK computes a partial factorization of a real symmetric matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SLASYF_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), W( LDW, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLASYF_ROOK computes a partial factorization of a real symmetric +*> matrix A using the bounded Bunch-Kaufman ("rook") diagonal +*> pivoting method. The partial factorization has the form: +*> +*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: +*> ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) +*> +*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L' +*> ( L21 I ) ( 0 A22 ) ( 0 I ) +*> +*> where the order of D is at most NB. The actual order is returned in +*> the argument KB, and is either NB or NB-1, or N if N <= NB. +*> +*> SLASYF_ROOK is an auxiliary routine called by SSYTRF_ROOK. It uses +*> blocked code (calling Level 3 BLAS) to update the submatrix +*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The maximum number of columns of the matrix A that should be +*> factored. NB should be at least 2 to allow for 2-by-2 pivot +*> blocks. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> The number of columns of A that were actually factored. +*> KB is either NB-1 or NB, or N if N <= NB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> n-by-n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading n-by-n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> On exit, A contains details of the partial factorization. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> Only the last KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> Only the first KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is REAL array, dimension (LDW,NB) +*> \endverbatim +*> +*> \param[in] LDW +*> \verbatim +*> LDW is INTEGER +*> The leading dimension of the array W. LDW >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup realSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, + $ INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), W( LDW, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL DONE + INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, JP1, JP2, K, KK, + $ KW, KKW, KP, KSTEP, P, II + + REAL ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, + $ STEMP, R1, ROWMAX, T, SFMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ISAMAX + REAL SLAMCH + EXTERNAL LSAME, ISAMAX, SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL SCOPY, SGEMM, SGEMV, SSCAL, SSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = SLAMCH( 'S' ) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Factorize the trailing columns of A using the upper triangle +* of A and working backwards, and compute the matrix W = U12*D +* for use in updating A11 +* +* K is the main loop index, decreasing from N in steps of 1 or 2 +* + K = N + 10 CONTINUE +* +* KW is the column of W which corresponds to column K of A +* + KW = NB + K - N +* +* Exit from loop +* + IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) + $ GO TO 30 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column KW of W and update it +* + CALL SCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 ) + IF( K.LT.N ) + $ CALL SGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), + $ LDA, W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 ) +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( W( K, KW ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = ISAMAX( K-1, W( 1, KW ), 1 ) + COLMAX = ABS( W( IMAX, KW ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + CALL SCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) + ELSE +* +* ============================================================ +* +* Test for interchange +* +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* Begin pivot search loop body +* +* +* Copy column IMAX to column KW-1 of W and update it +* + CALL SCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 ) + CALL SCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, + $ W( IMAX+1, KW-1 ), 1 ) +* + IF( K.LT.N ) + $ CALL SGEMV( 'No transpose', K, N-K, -ONE, + $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW, + $ ONE, W( 1, KW-1 ), 1 ) +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + ISAMAX( K-IMAX, W( IMAX+1, KW-1 ), + $ 1 ) + ROWMAX = ABS( W( JMAX, KW-1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = ISAMAX( IMAX-1, W( 1, KW-1 ), 1 ) + STEMP = ABS( W( ITEMP, KW-1 ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for +* ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.(ABS( W( IMAX, KW-1 ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column KW-1 of W to column KW of W +* + CALL SCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K-1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL SCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 12 +* + END IF +* +* ============================================================ +* + KK = K - KSTEP + 1 +* +* KKW is the column of W which corresponds to column KK of A +* + KKW = NB + KK - N +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P +* + CALL SCOPY( K-P, A( P+1, K ), 1, A( P, P+1 ), LDA ) + CALL SCOPY( P, A( 1, K ), 1, A( 1, P ), 1 ) +* +* Interchange rows K and P in last N-K+1 columns of A +* and last N-K+2 columns of W +* + CALL SSWAP( N-K+1, A( K, K ), LDA, A( P, K ), LDA ) + CALL SSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), LDW ) + END IF +* +* Updated column KP is already stored in column KKW of W +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP +* + A( KP, K ) = A( KK, K ) + CALL SCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + CALL SCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 ) +* +* Interchange rows KK and KP in last N-KK+1 columns +* of A and W +* + CALL SSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA ) + CALL SSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), + $ LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column KW of W now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* +* Store U(k) in column k of A +* + CALL SCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) + IF( K.GT.1 ) THEN + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN + R1 = ONE / A( K, K ) + CALL SSCAL( K-1, R1, A( 1, K ), 1 ) + ELSE IF( A( K, K ).NE.ZERO ) THEN + DO 14 II = 1, K - 1 + A( II, K ) = A( II, K ) / A( K, K ) + 14 CONTINUE + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns KW and KW-1 of W now +* hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* + IF( K.GT.2 ) THEN +* +* Store U(k) and U(k-1) in columns k and k-1 of A +* + D12 = W( K-1, KW ) + D11 = W( K, KW ) / D12 + D22 = W( K-1, KW-1 ) / D12 + T = ONE / ( D11*D22-ONE ) + DO 20 J = 1, K - 2 + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D12 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D12 ) + 20 CONTINUE + END IF +* +* Copy D(k) to A +* + A( K-1, K-1 ) = W( K-1, KW-1 ) + A( K-1, K ) = W( K-1, KW ) + A( K, K ) = W( K, KW ) + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + 30 CONTINUE +* +* Update the upper triangle of A11 (= A(1:k,1:k)) as +* +* A11 := A11 - U12*D*U12**T = A11 - U12*W**T +* +* computing blocks of NB columns at a time +* + DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB + JB = MIN( NB, K-J+1 ) +* +* Update the upper triangle of the diagonal block +* + DO 40 JJ = J, J + JB - 1 + CALL SGEMV( 'No transpose', JJ-J+1, N-K, -ONE, + $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE, + $ A( J, JJ ), 1 ) + 40 CONTINUE +* +* Update the rectangular superdiagonal block +* + IF( J.GE.2 ) + $ CALL SGEMM( 'No transpose', 'Transpose', J-1, JB, + $ N-K, -ONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, + $ ONE, A( 1, J ), LDA ) + 50 CONTINUE +* +* Put U12 in standard form by partially undoing the interchanges +* in columns k+1:n +* + J = K + 1 + 60 CONTINUE +* + KSTEP = 1 + JP1 = 1 + JJ = J + JP2 = IPIV( J ) + IF( JP2.LT.0 ) THEN + JP2 = -JP2 + J = J + 1 + JP1 = -IPIV( J ) + KSTEP = 2 + END IF +* + J = J + 1 + IF( JP2.NE.JJ .AND. J.LE.N ) + $ CALL SSWAP( N-J+1, A( JP2, J ), LDA, A( JJ, J ), LDA ) + JJ = J - 1 + IF( JP1.NE.JJ .AND. KSTEP.EQ.2 ) + $ CALL SSWAP( N-J+1, A( JP1, J ), LDA, A( JJ, J ), LDA ) + IF( J.LE.N ) + $ GO TO 60 +* +* Set KB to the number of columns factorized +* + KB = N - K +* + ELSE +* +* Factorize the leading columns of A using the lower triangle +* of A and working forwards, and compute the matrix W = L21*D +* for use in updating A22 +* +* K is the main loop index, increasing from 1 in steps of 1 or 2 +* + K = 1 + 70 CONTINUE +* +* Exit from loop +* + IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) + $ GO TO 90 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column K of W and update it +* + CALL SCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 ) + IF( K.GT.1 ) + $ CALL SGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), + $ LDA, W( K, 1 ), LDW, ONE, W( K, K ), 1 ) +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( W( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + ISAMAX( N-K, W( K+1, K ), 1 ) + COLMAX = ABS( W( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + CALL SCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) + ELSE +* +* ============================================================ +* +* Test for interchange +* +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 72 CONTINUE +* +* Begin pivot search loop body +* +* +* Copy column IMAX to column K+1 of W and update it +* + CALL SCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1) + CALL SCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, + $ W( IMAX, K+1 ), 1 ) + IF( K.GT.1 ) + $ CALL SGEMV( 'No transpose', N-K+1, K-1, -ONE, + $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW, + $ ONE, W( K, K+1 ), 1 ) +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + ISAMAX( IMAX-K, W( K, K+1 ), 1 ) + ROWMAX = ABS( W( JMAX, K+1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + ISAMAX( N-IMAX, W( IMAX+1, K+1 ), 1) + STEMP = ABS( W( ITEMP, K+1 ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for +* ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABS( W( IMAX, K+1 ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column K+1 of W to column K of W +* + CALL SCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL SCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 72 +* + END IF +* +* ============================================================ +* + KK = K + KSTEP - 1 +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P +* + CALL SCOPY( P-K, A( K, K ), 1, A( P, K ), LDA ) + CALL SCOPY( N-P+1, A( P, K ), 1, A( P, P ), 1 ) +* +* Interchange rows K and P in first K columns of A +* and first K+1 columns of W +* + CALL SSWAP( K, A( K, 1 ), LDA, A( P, 1 ), LDA ) + CALL SSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW ) + END IF +* +* Updated column KP is already stored in column KK of W +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP +* + A( KP, K ) = A( KK, K ) + CALL SCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA ) + CALL SCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 ) +* +* Interchange rows KK and KP in first KK columns of A and W +* + CALL SSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) + CALL SSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k of W now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* +* Store L(k) in column k of A +* + CALL SCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) + IF( K.LT.N ) THEN + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN + R1 = ONE / A( K, K ) + CALL SSCAL( N-K, R1, A( K+1, K ), 1 ) + ELSE IF( A( K, K ).NE.ZERO ) THEN + DO 74 II = K + 1, N + A( II, K ) = A( II, K ) / A( K, K ) + 74 CONTINUE + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 of W now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* + IF( K.LT.N-1 ) THEN +* +* Store L(k) and L(k+1) in columns k and k+1 of A +* + D21 = W( K+1, K ) + D11 = W( K+1, K+1 ) / D21 + D22 = W( K, K ) / D21 + T = ONE / ( D11*D22-ONE ) + DO 80 J = K + 2, N + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) + 80 CONTINUE + END IF +* +* Copy D(k) to A +* + A( K, K ) = W( K, K ) + A( K+1, K ) = W( K+1, K ) + A( K+1, K+1 ) = W( K+1, K+1 ) + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 70 +* + 90 CONTINUE +* +* Update the lower triangle of A22 (= A(k:n,k:n)) as +* +* A22 := A22 - L21*D*L21**T = A22 - L21*W**T +* +* computing blocks of NB columns at a time +* + DO 110 J = K, N, NB + JB = MIN( NB, N-J+1 ) +* +* Update the lower triangle of the diagonal block +* + DO 100 JJ = J, J + JB - 1 + CALL SGEMV( 'No transpose', J+JB-JJ, K-1, -ONE, + $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE, + $ A( JJ, JJ ), 1 ) + 100 CONTINUE +* +* Update the rectangular subdiagonal block +* + IF( J+JB.LE.N ) + $ CALL SGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, + $ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW, + $ ONE, A( J+JB, J ), LDA ) + 110 CONTINUE +* +* Put L21 in standard form by partially undoing the interchanges +* in columns 1:k-1 +* + J = K - 1 + 120 CONTINUE +* + KSTEP = 1 + JP1 = 1 + JJ = J + JP2 = IPIV( J ) + IF( JP2.LT.0 ) THEN + JP2 = -JP2 + J = J - 1 + JP1 = -IPIV( J ) + KSTEP = 2 + END IF +* + J = J - 1 + IF( JP2.NE.JJ .AND. J.GE.1 ) + $ CALL SSWAP( J, A( JP2, 1 ), LDA, A( JJ, 1 ), LDA ) + JJ = J + 1 + IF( JP1.NE.JJ .AND. KSTEP.EQ.2 ) + $ CALL SSWAP( J, A( JP1, 1 ), LDA, A( JJ, 1 ), LDA ) + IF( J.GE.1 ) + $ GO TO 120 +* +* Set KB to the number of columns factorized +* + KB = K - 1 +* + END IF + RETURN +* +* End of SLASYF_ROOK +* + END diff --git a/lapack-netlib/SRC/sorbdb.f b/lapack-netlib/SRC/sorbdb.f index 433b3c035..f001da63d 100644 --- a/lapack-netlib/SRC/sorbdb.f +++ b/lapack-netlib/SRC/sorbdb.f @@ -255,7 +255,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup realOTHERcomputational * @@ -287,10 +287,10 @@ $ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, $ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER SIGNS, TRANS @@ -415,19 +415,36 @@ THETA(I) = ATAN2( SNRM2( M-P-I+1, X21(I,I), 1 ), $ SNRM2( P-I+1, X11(I,I), 1 ) ) * - CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + IF( P .GT. I ) THEN + CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + ELSE IF( P .EQ. I ) THEN + CALL SLARFGP( P-I+1, X11(I,I), X11(I,I), 1, TAUP1(I) ) + END IF X11(I,I) = ONE - CALL SLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + IF ( M-P .GT. I ) THEN + CALL SLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, + $ TAUP2(I) ) + ELSE IF ( M-P .EQ. I ) THEN + CALL SLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1, TAUP2(I) ) + END IF X21(I,I) = ONE * - CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), - $ X11(I,I+1), LDX11, WORK ) - CALL SLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, TAUP1(I), - $ X12(I,I), LDX12, WORK ) - CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), - $ X21(I,I+1), LDX21, WORK ) - CALL SLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, TAUP2(I), - $ X22(I,I), LDX22, WORK ) + IF ( Q .GT. I ) THEN + CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), + $ X11(I,I+1), LDX11, WORK ) + END IF + IF ( M-Q+1 .GT. I ) THEN + CALL SLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, TAUP1(I), + $ X12(I,I), LDX12, WORK ) + END IF + IF ( Q .GT. I ) THEN + CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), + $ X21(I,I+1), LDX21, WORK ) + END IF + IF ( M-Q+1 .GT. I ) THEN + CALL SLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, TAUP2(I), + $ X22(I,I), LDX22, WORK ) + END IF * IF( I .LT. Q ) THEN CALL SSCAL( Q-I, -Z1*Z3*SIN(THETA(I)), X11(I,I+1), @@ -444,12 +461,24 @@ $ SNRM2( M-Q-I+1, X12(I,I), LDX12 ) ) * IF( I .LT. Q ) THEN - CALL SLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11, - $ TAUQ1(I) ) + IF ( Q-I .EQ. 1 ) THEN + CALL SLARFGP( Q-I, X11(I,I+1), X11(I,I+1), LDX11, + $ TAUQ1(I) ) + ELSE + CALL SLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11, + $ TAUQ1(I) ) + END IF X11(I,I+1) = ONE END IF - CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, - $ TAUQ2(I) ) + IF ( Q+I-1 .LT. M ) THEN + IF ( M-Q .EQ. I ) THEN + CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12, + $ TAUQ2(I) ) + ELSE + CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, + $ TAUQ2(I) ) + END IF + END IF X12(I,I) = ONE * IF( I .LT. Q ) THEN @@ -458,10 +487,14 @@ CALL SLARF( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I), $ X21(I+1,I+1), LDX21, WORK ) END IF - CALL SLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), - $ X12(I+1,I), LDX12, WORK ) - CALL SLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), - $ X22(I+1,I), LDX22, WORK ) + IF ( P .GT. I ) THEN + CALL SLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), + $ X12(I+1,I), LDX12, WORK ) + END IF + IF ( M-P .GT. I ) THEN + CALL SLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), X22(I+1,I), LDX22, WORK ) + END IF * END DO * @@ -470,12 +503,19 @@ DO I = Q + 1, P * CALL SSCAL( M-Q-I+1, -Z1*Z4, X12(I,I), LDX12 ) - CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, - $ TAUQ2(I) ) + IF ( I .GE. M-Q ) THEN + CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12, + $ TAUQ2(I) ) + ELSE + CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, + $ TAUQ2(I) ) + END IF X12(I,I) = ONE * - CALL SLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), - $ X12(I+1,I), LDX12, WORK ) + IF ( P. GT. I ) THEN + CALL SLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), + $ X12(I+1,I), LDX12, WORK ) + END IF IF( M-P-Q .GE. 1 ) $ CALL SLARF( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12, $ TAUQ2(I), X22(Q+1,I), LDX22, WORK ) @@ -487,11 +527,18 @@ DO I = 1, M - P - Q * CALL SSCAL( M-P-Q-I+1, Z2*Z4, X22(Q+I,P+I), LDX22 ) - CALL SLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I+1), - $ LDX22, TAUQ2(P+I) ) + IF ( I .EQ. M-P-Q ) THEN + CALL SLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I), + $ LDX22, TAUQ2(P+I) ) + ELSE + CALL SLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I+1), + $ LDX22, TAUQ2(P+I) ) + END IF X22(Q+I,P+I) = ONE - CALL SLARF( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), LDX22, - $ TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, WORK ) + IF ( I .LT. M-P-Q ) THEN + CALL SLARF( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), LDX22, + $ TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, WORK ) + END IF * END DO * @@ -521,18 +568,31 @@ * CALL SLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, TAUP1(I) ) X11(I,I) = ONE - CALL SLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21, - $ TAUP2(I) ) + IF ( I .EQ. M-P ) THEN + CALL SLARFGP( M-P-I+1, X21(I,I), X21(I,I), LDX21, + $ TAUP2(I) ) + ELSE + CALL SLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21, + $ TAUP2(I) ) + END IF X21(I,I) = ONE * - CALL SLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I), - $ X11(I+1,I), LDX11, WORK ) - CALL SLARF( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, TAUP1(I), - $ X12(I,I), LDX12, WORK ) - CALL SLARF( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, TAUP2(I), - $ X21(I+1,I), LDX21, WORK ) - CALL SLARF( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21, - $ TAUP2(I), X22(I,I), LDX22, WORK ) + IF ( Q .GT. I ) THEN + CALL SLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I), + $ X11(I+1,I), LDX11, WORK ) + END IF + IF ( M-Q+1 .GT. I ) THEN + CALL SLARF( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, + $ TAUP1(I), X12(I,I), LDX12, WORK ) + END IF + IF ( Q .GT. I ) THEN + CALL SLARF( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, TAUP2(I), + $ X21(I+1,I), LDX21, WORK ) + END IF + IF ( M-Q+1 .GT. I ) THEN + CALL SLARF( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21, + $ TAUP2(I), X22(I,I), LDX22, WORK ) + END IF * IF( I .LT. Q ) THEN CALL SSCAL( Q-I, -Z1*Z3*SIN(THETA(I)), X11(I+1,I), 1 ) @@ -548,10 +608,22 @@ $ SNRM2( M-Q-I+1, X12(I,I), 1 ) ) * IF( I .LT. Q ) THEN - CALL SLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1, TAUQ1(I) ) + IF ( Q-I .EQ. 1) THEN + CALL SLARFGP( Q-I, X11(I+1,I), X11(I+1,I), 1, + $ TAUQ1(I) ) + ELSE + CALL SLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1, + $ TAUQ1(I) ) + END IF X11(I+1,I) = ONE END IF - CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) ) + IF ( M-Q .GT. I ) THEN + CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, + $ TAUQ2(I) ) + ELSE + CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I,I), 1, + $ TAUQ2(I) ) + END IF X12(I,I) = ONE * IF( I .LT. Q ) THEN @@ -562,8 +634,10 @@ END IF CALL SLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I), $ X12(I,I+1), LDX12, WORK ) - CALL SLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, TAUQ2(I), - $ X22(I,I+1), LDX22, WORK ) + IF ( M-P-I .GT. 0 ) THEN + CALL SLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, TAUQ2(I), + $ X22(I,I+1), LDX22, WORK ) + END IF * END DO * @@ -575,8 +649,10 @@ CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) ) X12(I,I) = ONE * - CALL SLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I), - $ X12(I,I+1), LDX12, WORK ) + IF ( P .GT. I ) THEN + CALL SLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I), + $ X12(I,I+1), LDX12, WORK ) + END IF IF( M-P-Q .GE. 1 ) $ CALL SLARF( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1, TAUQ2(I), $ X22(I,Q+1), LDX22, WORK ) @@ -588,12 +664,18 @@ DO I = 1, M - P - Q * CALL SSCAL( M-P-Q-I+1, Z2*Z4, X22(P+I,Q+I), 1 ) - CALL SLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), 1, - $ TAUQ2(P+I) ) - X22(P+I,Q+I) = ONE + IF ( M-P-Q .EQ. I ) THEN + CALL SLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I,Q+I), 1, + $ TAUQ2(P+I) ) + X22(P+I,Q+I) = ONE + ELSE + CALL SLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), 1, + $ TAUQ2(P+I) ) + X22(P+I,Q+I) = ONE + CALL SLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1, + $ TAUQ2(P+I), X22(P+I,Q+I+1), LDX22, WORK ) + END IF * - CALL SLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1, - $ TAUQ2(P+I), X22(P+I,Q+I+1), LDX22, WORK ) * END DO * diff --git a/lapack-netlib/SRC/sorbdb1.f b/lapack-netlib/SRC/sorbdb1.f new file mode 100644 index 000000000..b1f5f4628 --- /dev/null +++ b/lapack-netlib/SRC/sorbdb1.f @@ -0,0 +1,324 @@ +*> \brief \b SORBDB1 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SORBDB1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* REAL PHI(*), THETA(*) +* REAL TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> SORBDB1 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonomal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. Q must be no larger than P, +*> M-P, or M-Q. Routines SORBDB2, SORBDB3, and SORBDB4 handle cases in +*> which Q is not the minimum dimension. +*> +*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are Q-by-Q bidiagonal matrices represented implicitly by +*> angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= +*> MIN(P,M-P,M-Q). +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is REAL array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is REAL array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is REAL array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is REAL array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is REAL array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is REAL array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is REAL array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +*> +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup realOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or SORCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See SORCSD2BY1 for details on generating P1, P2, and Q1 using SORGQR +*> and SORGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + REAL PHI(*), THETA(*) + REAL TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E0 ) +* .. +* .. Local Scalars .. + REAL C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, + $ LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, XERBLA +* .. +* .. External Functions .. + REAL SNRM2 + EXTERNAL SNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( P .LT. Q .OR. M-P .LT. Q ) THEN + INFO = -2 + ELSE IF( Q .LT. 0 .OR. M-Q .LT. Q ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( P-1, M-P-1, Q-1 ) + IORBDB5 = 2 + LORBDB5 = Q-2 + LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'SORBDB1', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce columns 1, ..., Q of X11 and X21 +* + DO I = 1, Q +* + CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + CALL SLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + THETA(I) = ATAN2( X21(I,I), X11(I,I) ) + C = COS( THETA(I) ) + S = SIN( THETA(I) ) + X11(I,I) = ONE + X21(I,I) = ONE + CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1), + $ LDX11, WORK(ILARF) ) + CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), + $ X21(I,I+1), LDX21, WORK(ILARF) ) +* + IF( I .LT. Q ) THEN + CALL SROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C, S ) + CALL SLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, TAUQ1(I) ) + S = X21(I,I+1) + X21(I,I+1) = ONE + CALL SLARF( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), + $ X11(I+1,I+1), LDX11, WORK(ILARF) ) + CALL SLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), + $ X21(I+1,I+1), LDX21, WORK(ILARF) ) + C = SQRT( SNRM2( P-I, X11(I+1,I+1), 1, X11(I+1,I+1), + $ 1 )**2 + SNRM2( M-P-I, X21(I+1,I+1), 1, X21(I+1,I+1), + $ 1 )**2 ) + PHI(I) = ATAN2( S, C ) + CALL SORBDB5( P-I, M-P-I, Q-I-1, X11(I+1,I+1), 1, + $ X21(I+1,I+1), 1, X11(I+1,I+2), LDX11, + $ X21(I+1,I+2), LDX21, WORK(IORBDB5), LORBDB5, + $ CHILDINFO ) + END IF +* + END DO +* + RETURN +* +* End of SORBDB1 +* + END + diff --git a/lapack-netlib/SRC/sorbdb2.f b/lapack-netlib/SRC/sorbdb2.f new file mode 100644 index 000000000..582540e34 --- /dev/null +++ b/lapack-netlib/SRC/sorbdb2.f @@ -0,0 +1,332 @@ +*> \brief \b SORBDB2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SORBDB2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* REAL PHI(*), THETA(*) +* REAL TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> SORBDB2 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonomal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. P must be no larger than M-P, +*> Q, or M-Q. Routines SORBDB1, SORBDB3, and SORBDB4 handle cases in +*> which P is not the minimum dimension. +*> +*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are P-by-P bidiagonal matrices represented implicitly by +*> angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= min(M-P,Q,M-Q). +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M. +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is REAL array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is REAL array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is REAL array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is REAL array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is REAL array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is REAL array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is REAL array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup realOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or SORCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See SORCSD2BY1 for details on generating P1, P2, and Q1 using SORGQR +*> and SORGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + REAL PHI(*), THETA(*) + REAL TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + REAL NEGONE, ONE + PARAMETER ( NEGONE = -1.0E0, ONE = 1.0E0 ) +* .. +* .. Local Scalars .. + REAL C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, + $ LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, SSCAL, XERBLA +* .. +* .. External Functions .. + REAL SNRM2 + EXTERNAL SNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( P .LT. 0 .OR. P .GT. M-P ) THEN + INFO = -2 + ELSE IF( Q .LT. 0 .OR. Q .LT. P .OR. M-Q .LT. P ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( P-1, M-P, Q-1 ) + IORBDB5 = 2 + LORBDB5 = Q-1 + LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'SORBDB2', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce rows 1, ..., P of X11 and X21 +* + DO I = 1, P +* + IF( I .GT. 1 ) THEN + CALL SROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C, S ) + END IF + CALL SLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) ) + C = X11(I,I) + X11(I,I) = ONE + CALL SLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL SLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X21(I,I), LDX21, WORK(ILARF) ) + S = SQRT( SNRM2( P-I, X11(I+1,I), 1, X11(I+1,I), + $ 1 )**2 + SNRM2( M-P-I+1, X21(I,I), 1, X21(I,I), 1 )**2 ) + THETA(I) = ATAN2( S, C ) +* + CALL SORBDB5( P-I, M-P-I+1, Q-I, X11(I+1,I), 1, X21(I,I), 1, + $ X11(I+1,I+1), LDX11, X21(I,I+1), LDX21, + $ WORK(IORBDB5), LORBDB5, CHILDINFO ) + CALL SSCAL( P-I, NEGONE, X11(I+1,I), 1 ) + CALL SLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + IF( I .LT. P ) THEN + CALL SLARFGP( P-I, X11(I+1,I), X11(I+2,I), 1, TAUP1(I) ) + PHI(I) = ATAN2( X11(I+1,I), X21(I,I) ) + C = COS( PHI(I) ) + S = SIN( PHI(I) ) + X11(I+1,I) = ONE + CALL SLARF( 'L', P-I, Q-I, X11(I+1,I), 1, TAUP1(I), + $ X11(I+1,I+1), LDX11, WORK(ILARF) ) + END IF + X21(I,I) = ONE + CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), + $ X21(I,I+1), LDX21, WORK(ILARF) ) +* + END DO +* +* Reduce the bottom-right portion of X21 to the identity matrix +* + DO I = P + 1, Q + CALL SLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + X21(I,I) = ONE + CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), + $ X21(I,I+1), LDX21, WORK(ILARF) ) + END DO +* + RETURN +* +* End of SORBDB2 +* + END + diff --git a/lapack-netlib/SRC/sorbdb3.f b/lapack-netlib/SRC/sorbdb3.f new file mode 100644 index 000000000..ea52f4db3 --- /dev/null +++ b/lapack-netlib/SRC/sorbdb3.f @@ -0,0 +1,333 @@ +*> \brief \b SORBDB3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SORBDB3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* REAL PHI(*), THETA(*) +* REAL TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> SORBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonomal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-P must be no larger than P, +*> Q, or M-Q. Routines SORBDB1, SORBDB2, and SORBDB4 handle cases in +*> which M-P is not the minimum dimension. +*> +*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are (M-P)-by-(M-P) bidiagonal matrices represented +*> implicitly by angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= M. M-P <= min(P,Q,M-Q). +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M. +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is REAL array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is REAL array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is REAL array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is REAL array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is REAL array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is REAL array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is REAL array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +*> +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup realOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or SORCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See SORCSD2BY1 for details on generating P1, P2, and Q1 using SORGQR +*> and SORGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + REAL PHI(*), THETA(*) + REAL TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E0 ) +* .. +* .. Local Scalars .. + REAL C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, + $ LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, XERBLA +* .. +* .. External Functions .. + REAL SNRM2 + EXTERNAL SNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( 2*P .LT. M .OR. P .GT. M ) THEN + INFO = -2 + ELSE IF( Q .LT. M-P .OR. M-Q .LT. M-P ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( P, M-P-1, Q-1 ) + IORBDB5 = 2 + LORBDB5 = Q-1 + LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'SORBDB3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce rows 1, ..., M-P of X11 and X21 +* + DO I = 1, M-P +* + IF( I .GT. 1 ) THEN + CALL SROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C, S ) + END IF +* + CALL SLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) ) + S = X21(I,I) + X21(I,I) = ONE + CALL SLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X11(I,I), LDX11, WORK(ILARF) ) + CALL SLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X21(I+1,I), LDX21, WORK(ILARF) ) + C = SQRT( SNRM2( P-I+1, X11(I,I), 1, X11(I,I), + $ 1 )**2 + SNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), 1 )**2 ) + THETA(I) = ATAN2( S, C ) +* + CALL SORBDB5( P-I+1, M-P-I, Q-I, X11(I,I), 1, X21(I+1,I), 1, + $ X11(I,I+1), LDX11, X21(I+1,I+1), LDX21, + $ WORK(IORBDB5), LORBDB5, CHILDINFO ) + CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + IF( I .LT. M-P ) THEN + CALL SLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, TAUP2(I) ) + PHI(I) = ATAN2( X21(I+1,I), X11(I,I) ) + C = COS( PHI(I) ) + S = SIN( PHI(I) ) + X21(I+1,I) = ONE + CALL SLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1, TAUP2(I), + $ X21(I+1,I+1), LDX21, WORK(ILARF) ) + END IF + X11(I,I) = ONE + CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1), + $ LDX11, WORK(ILARF) ) +* + END DO +* +* Reduce the bottom-right portion of X11 to the identity matrix +* + DO I = M-P + 1, Q + CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + X11(I,I) = ONE + CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1), + $ LDX11, WORK(ILARF) ) + END DO +* + RETURN +* +* End of SORBDB3 +* + END + diff --git a/lapack-netlib/SRC/sorbdb4.f b/lapack-netlib/SRC/sorbdb4.f new file mode 100644 index 000000000..9ed16a714 --- /dev/null +++ b/lapack-netlib/SRC/sorbdb4.f @@ -0,0 +1,379 @@ +*> \brief \b SORBDB4 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SORBDB4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* REAL PHI(*), THETA(*) +* REAL PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*), +* $ WORK(*), X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> SORBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonomal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-Q must be no larger than P, +*> M-P, or Q. Routines SORBDB1, SORBDB2, and SORBDB3 handle cases in +*> which M-Q is not the minimum dimension. +*> +*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are (M-Q)-by-(M-Q) bidiagonal matrices represented +*> implicitly by angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M and +*> M-Q <= min(P,M-P,Q). +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is REAL array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is REAL array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is REAL array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is REAL array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is REAL array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is REAL array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is REAL array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] PHANTOM +*> \verbatim +*> PHANTOM is REAL array, dimension (M) +*> The routine computes an M-by-1 column vector Y that is +*> orthogonal to the columns of [ X11; X21 ]. PHANTOM(1:P) and +*> PHANTOM(P+1:M) contain Householder vectors for Y(1:P) and +*> Y(P+1:M), respectively. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +*> +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup realOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or SORCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See SORCSD2BY1 for details on generating P1, P2, and Q1 using SORGQR +*> and SORGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + $ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + REAL PHI(*), THETA(*) + REAL PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*), + $ WORK(*), X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + REAL NEGONE, ONE, ZERO + PARAMETER ( NEGONE = -1.0E0, ONE = 1.0E0, ZERO = 0.0E0 ) +* .. +* .. Local Scalars .. + REAL C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, J, LLARF, + $ LORBDB5, LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, SSCAL, XERBLA +* .. +* .. External Functions .. + REAL SNRM2 + EXTERNAL SNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( P .LT. M-Q .OR. M-P .LT. M-Q ) THEN + INFO = -2 + ELSE IF( Q .LT. M-Q .OR. Q .GT. M ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( Q-1, P-1, M-P-1 ) + IORBDB5 = 2 + LORBDB5 = Q + LWORKOPT = ILARF + LLARF - 1 + LWORKOPT = MAX( LWORKOPT, IORBDB5 + LORBDB5 - 1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'SORBDB4', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce columns 1, ..., M-Q of X11 and X21 +* + DO I = 1, M-Q +* + IF( I .EQ. 1 ) THEN + DO J = 1, M + PHANTOM(J) = ZERO + END DO + CALL SORBDB5( P, M-P, Q, PHANTOM(1), 1, PHANTOM(P+1), 1, + $ X11, LDX11, X21, LDX21, WORK(IORBDB5), + $ LORBDB5, CHILDINFO ) + CALL SSCAL( P, NEGONE, PHANTOM(1), 1 ) + CALL SLARFGP( P, PHANTOM(1), PHANTOM(2), 1, TAUP1(1) ) + CALL SLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, TAUP2(1) ) + THETA(I) = ATAN2( PHANTOM(1), PHANTOM(P+1) ) + C = COS( THETA(I) ) + S = SIN( THETA(I) ) + PHANTOM(1) = ONE + PHANTOM(P+1) = ONE + CALL SLARF( 'L', P, Q, PHANTOM(1), 1, TAUP1(1), X11, LDX11, + $ WORK(ILARF) ) + CALL SLARF( 'L', M-P, Q, PHANTOM(P+1), 1, TAUP2(1), X21, + $ LDX21, WORK(ILARF) ) + ELSE + CALL SORBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1, + $ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I), + $ LDX21, WORK(IORBDB5), LORBDB5, CHILDINFO ) + CALL SSCAL( P-I+1, NEGONE, X11(I,I-1), 1 ) + CALL SLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, TAUP1(I) ) + CALL SLARFGP( M-P-I+1, X21(I,I-1), X21(I+1,I-1), 1, + $ TAUP2(I) ) + THETA(I) = ATAN2( X11(I,I-1), X21(I,I-1) ) + C = COS( THETA(I) ) + S = SIN( THETA(I) ) + X11(I,I-1) = ONE + X21(I,I-1) = ONE + CALL SLARF( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, TAUP1(I), + $ X11(I,I), LDX11, WORK(ILARF) ) + CALL SLARF( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, TAUP2(I), + $ X21(I,I), LDX21, WORK(ILARF) ) + END IF +* + CALL SROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C ) + CALL SLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) ) + C = X21(I,I) + X21(I,I) = ONE + CALL SLARF( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL SLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X21(I+1,I), LDX21, WORK(ILARF) ) + IF( I .LT. M-Q ) THEN + S = SQRT( SNRM2( P-I, X11(I+1,I), 1, X11(I+1,I), + $ 1 )**2 + SNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), + $ 1 )**2 ) + PHI(I) = ATAN2( S, C ) + END IF +* + END DO +* +* Reduce the bottom-right portion of X11 to [ I 0 ] +* + DO I = M - Q + 1, P + CALL SLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) ) + X11(I,I) = ONE + CALL SLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL SLARF( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X21(M-Q+1,I), LDX21, WORK(ILARF) ) + END DO +* +* Reduce the bottom-right portion of X21 to [ 0 I ] +* + DO I = P + 1, Q + CALL SLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), LDX21, + $ TAUQ1(I) ) + X21(M-Q+I-P,I) = ONE + CALL SLARF( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, TAUQ1(I), + $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) ) + END DO +* + RETURN +* +* End of SORBDB4 +* + END + diff --git a/lapack-netlib/SRC/sorbdb5.f b/lapack-netlib/SRC/sorbdb5.f new file mode 100644 index 000000000..a0b6672c0 --- /dev/null +++ b/lapack-netlib/SRC/sorbdb5.f @@ -0,0 +1,274 @@ +*> \brief \b SORBDB5 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SORBDB5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SORBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, +* LDQ2, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, +* $ N +* .. +* .. Array Arguments .. +* REAL Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> SORBDB5 orthogonalizes the column vector +*> X = [ X1 ] +*> [ X2 ] +*> with respect to the columns of +*> Q = [ Q1 ] . +*> [ Q2 ] +*> The columns of Q must be orthonormal. +*> +*> If the projection is zero according to Kahan's "twice is enough" +*> criterion, then some other vector from the orthogonal complement +*> is returned. This vector is chosen in an arbitrary but deterministic +*> way. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M1 +*> \verbatim +*> M1 is INTEGER +*> The dimension of X1 and the number of rows in Q1. 0 <= M1. +*> \endverbatim +*> +*> \param[in] M2 +*> \verbatim +*> M2 is INTEGER +*> The dimension of X2 and the number of rows in Q2. 0 <= M2. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns in Q1 and Q2. 0 <= N. +*> \endverbatim +*> +*> \param[in,out] X1 +*> \verbatim +*> X1 is REAL array, dimension (M1) +*> On entry, the top part of the vector to be orthogonalized. +*> On exit, the top part of the projected vector. +*> \endverbatim +*> +*> \param[in] INCX1 +*> \verbatim +*> INCX1 is INTEGER +*> Increment for entries of X1. +*> \endverbatim +*> +*> \param[in,out] X2 +*> \verbatim +*> X2 is REAL array, dimension (M2) +*> On entry, the bottom part of the vector to be +*> orthogonalized. On exit, the bottom part of the projected +*> vector. +*> \endverbatim +*> +*> \param[in] INCX2 +*> \verbatim +*> INCX2 is INTEGER +*> Increment for entries of X2. +*> \endverbatim +*> +*> \param[in] Q1 +*> \verbatim +*> Q1 is REAL array, dimension (LDQ1, N) +*> The top part of the orthonormal basis matrix. +*> \endverbatim +*> +*> \param[in] LDQ1 +*> \verbatim +*> LDQ1 is INTEGER +*> The leading dimension of Q1. LDQ1 >= M1. +*> \endverbatim +*> +*> \param[in] Q2 +*> \verbatim +*> Q2 is REAL array, dimension (LDQ2, N) +*> The bottom part of the orthonormal basis matrix. +*> \endverbatim +*> +*> \param[in] LDQ2 +*> \verbatim +*> LDQ2 is INTEGER +*> The leading dimension of Q2. LDQ2 >= M2. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= N. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup realOTHERcomputational +* +* ===================================================================== + SUBROUTINE SORBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, + $ LDQ2, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, + $ N +* .. +* .. Array Arguments .. + REAL Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 ) +* .. +* .. Local Scalars .. + INTEGER CHILDINFO, I, J +* .. +* .. External Subroutines .. + EXTERNAL SORBDB6, XERBLA +* .. +* .. External Functions .. + REAL SNRM2 + EXTERNAL SNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + IF( M1 .LT. 0 ) THEN + INFO = -1 + ELSE IF( M2 .LT. 0 ) THEN + INFO = -2 + ELSE IF( N .LT. 0 ) THEN + INFO = -3 + ELSE IF( INCX1 .LT. 1 ) THEN + INFO = -5 + ELSE IF( INCX2 .LT. 1 ) THEN + INFO = -7 + ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN + INFO = -9 + ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN + INFO = -11 + ELSE IF( LWORK .LT. N ) THEN + INFO = -13 + END IF +* + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'SORBDB5', -INFO ) + RETURN + END IF +* +* Project X onto the orthogonal complement of Q +* + CALL SORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, LDQ2, + $ WORK, LWORK, CHILDINFO ) +* +* If the projection is nonzero, then return +* + IF( SNRM2(M1,X1,INCX1) .NE. ZERO + $ .OR. SNRM2(M2,X2,INCX2) .NE. ZERO ) THEN + RETURN + END IF +* +* Project each standard basis vector e_1,...,e_M1 in turn, stopping +* when a nonzero projection is found +* + DO I = 1, M1 + DO J = 1, M1 + X1(J) = ZERO + END DO + X1(I) = ONE + DO J = 1, M2 + X2(J) = ZERO + END DO + CALL SORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, + $ LDQ2, WORK, LWORK, CHILDINFO ) + IF( SNRM2(M1,X1,INCX1) .NE. ZERO + $ .OR. SNRM2(M2,X2,INCX2) .NE. ZERO ) THEN + RETURN + END IF + END DO +* +* Project each standard basis vector e_(M1+1),...,e_(M1+M2) in turn, +* stopping when a nonzero projection is found +* + DO I = 1, M2 + DO J = 1, M1 + X1(J) = ZERO + END DO + DO J = 1, M2 + X2(J) = ZERO + END DO + X2(I) = ONE + CALL SORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, + $ LDQ2, WORK, LWORK, CHILDINFO ) + IF( SNRM2(M1,X1,INCX1) .NE. ZERO + $ .OR. SNRM2(M2,X2,INCX2) .NE. ZERO ) THEN + RETURN + END IF + END DO +* + RETURN +* +* End of SORBDB5 +* + END + diff --git a/lapack-netlib/SRC/sorbdb6.f b/lapack-netlib/SRC/sorbdb6.f new file mode 100644 index 000000000..900316ee8 --- /dev/null +++ b/lapack-netlib/SRC/sorbdb6.f @@ -0,0 +1,312 @@ +*> \brief \b SORBDB6 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SORBDB6 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, +* LDQ2, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, +* $ N +* .. +* .. Array Arguments .. +* REAL Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> SORBDB6 orthogonalizes the column vector +*> X = [ X1 ] +*> [ X2 ] +*> with respect to the columns of +*> Q = [ Q1 ] . +*> [ Q2 ] +*> The columns of Q must be orthonormal. +*> +*> If the projection is zero according to Kahan's "twice is enough" +*> criterion, then the zero vector is returned. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M1 +*> \verbatim +*> M1 is INTEGER +*> The dimension of X1 and the number of rows in Q1. 0 <= M1. +*> \endverbatim +*> +*> \param[in] M2 +*> \verbatim +*> M2 is INTEGER +*> The dimension of X2 and the number of rows in Q2. 0 <= M2. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns in Q1 and Q2. 0 <= N. +*> \endverbatim +*> +*> \param[in,out] X1 +*> \verbatim +*> X1 is REAL array, dimension (M1) +*> On entry, the top part of the vector to be orthogonalized. +*> On exit, the top part of the projected vector. +*> \endverbatim +*> +*> \param[in] INCX1 +*> \verbatim +*> INCX1 is INTEGER +*> Increment for entries of X1. +*> \endverbatim +*> +*> \param[in,out] X2 +*> \verbatim +*> X2 is REAL array, dimension (M2) +*> On entry, the bottom part of the vector to be +*> orthogonalized. On exit, the bottom part of the projected +*> vector. +*> \endverbatim +*> +*> \param[in] INCX2 +*> \verbatim +*> INCX2 is INTEGER +*> Increment for entries of X2. +*> \endverbatim +*> +*> \param[in] Q1 +*> \verbatim +*> Q1 is REAL array, dimension (LDQ1, N) +*> The top part of the orthonormal basis matrix. +*> \endverbatim +*> +*> \param[in] LDQ1 +*> \verbatim +*> LDQ1 is INTEGER +*> The leading dimension of Q1. LDQ1 >= M1. +*> \endverbatim +*> +*> \param[in] Q2 +*> \verbatim +*> Q2 is REAL array, dimension (LDQ2, N) +*> The bottom part of the orthonormal basis matrix. +*> \endverbatim +*> +*> \param[in] LDQ2 +*> \verbatim +*> LDQ2 is INTEGER +*> The leading dimension of Q2. LDQ2 >= M2. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= N. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup realOTHERcomputational +* +* ===================================================================== + SUBROUTINE SORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, + $ LDQ2, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, + $ N +* .. +* .. Array Arguments .. + REAL Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ALPHASQ, REALONE, REALZERO + PARAMETER ( ALPHASQ = 0.01E0, REALONE = 1.0E0, + $ REALZERO = 0.0E0 ) + REAL NEGONE, ONE, ZERO + PARAMETER ( NEGONE = -1.0E0, ONE = 1.0E0, ZERO = 0.0E0 ) +* .. +* .. Local Scalars .. + INTEGER I + REAL NORMSQ1, NORMSQ2, SCL1, SCL2, SSQ1, SSQ2 +* .. +* .. External Subroutines .. + EXTERNAL SGEMV, SLASSQ, XERBLA +* .. +* .. Intrinsic Function .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + IF( M1 .LT. 0 ) THEN + INFO = -1 + ELSE IF( M2 .LT. 0 ) THEN + INFO = -2 + ELSE IF( N .LT. 0 ) THEN + INFO = -3 + ELSE IF( INCX1 .LT. 1 ) THEN + INFO = -5 + ELSE IF( INCX2 .LT. 1 ) THEN + INFO = -7 + ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN + INFO = -9 + ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN + INFO = -11 + ELSE IF( LWORK .LT. N ) THEN + INFO = -13 + END IF +* + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'SORBDB6', -INFO ) + RETURN + END IF +* +* First, project X onto the orthogonal complement of Q's column +* space +* + SCL1 = REALZERO + SSQ1 = REALONE + CALL SLASSQ( M1, X1, INCX1, SCL1, SSQ1 ) + SCL2 = REALZERO + SSQ2 = REALONE + CALL SLASSQ( M2, X2, INCX2, SCL2, SSQ2 ) + NORMSQ1 = SCL1**2*SSQ1 + SCL2**2*SSQ2 +* + IF( M1 .EQ. 0 ) THEN + DO I = 1, N + WORK(I) = ZERO + END DO + ELSE + CALL SGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK, + $ 1 ) + END IF +* + CALL SGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 ) +* + CALL SGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1, + $ INCX1 ) + CALL SGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2, + $ INCX2 ) +* + SCL1 = REALZERO + SSQ1 = REALONE + CALL SLASSQ( M1, X1, INCX1, SCL1, SSQ1 ) + SCL2 = REALZERO + SSQ2 = REALONE + CALL SLASSQ( M2, X2, INCX2, SCL2, SSQ2 ) + NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2 +* +* If projection is sufficiently large in norm, then stop. +* If projection is zero, then stop. +* Otherwise, project again. +* + IF( NORMSQ2 .GE. ALPHASQ*NORMSQ1 ) THEN + RETURN + END IF +* + IF( NORMSQ2 .EQ. ZERO ) THEN + RETURN + END IF +* + NORMSQ1 = NORMSQ2 +* + DO I = 1, N + WORK(I) = ZERO + END DO +* + IF( M1 .EQ. 0 ) THEN + DO I = 1, N + WORK(I) = ZERO + END DO + ELSE + CALL SGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK, + $ 1 ) + END IF +* + CALL SGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 ) +* + CALL SGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1, + $ INCX1 ) + CALL SGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2, + $ INCX2 ) +* + SCL1 = REALZERO + SSQ1 = REALONE + CALL SLASSQ( M1, X1, INCX1, SCL1, SSQ1 ) + SCL2 = REALZERO + SSQ2 = REALONE + CALL SLASSQ( M1, X1, INCX1, SCL1, SSQ1 ) + NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2 +* +* If second projection is sufficiently large in norm, then do +* nothing more. Alternatively, if it shrunk significantly, then +* truncate it to zero. +* + IF( NORMSQ2 .LT. ALPHASQ*NORMSQ1 ) THEN + DO I = 1, M1 + X1(I) = ZERO + END DO + DO I = 1, M2 + X2(I) = ZERO + END DO + END IF +* + RETURN +* +* End of SORBDB6 +* + END + diff --git a/lapack-netlib/SRC/sorcsd.f b/lapack-netlib/SRC/sorcsd.f index f9a47d6ac..ff4e80579 100644 --- a/lapack-netlib/SRC/sorcsd.f +++ b/lapack-netlib/SRC/sorcsd.f @@ -289,7 +289,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup realOTHERcomputational * @@ -300,10 +300,10 @@ $ U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, $ LDV2T, WORK, LWORK, IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS @@ -371,9 +371,22 @@ INFO = -8 ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN INFO = -9 - ELSE IF( ( COLMAJOR .AND. LDX11 .LT. MAX(1,P) ) .OR. - $ ( .NOT.COLMAJOR .AND. LDX11 .LT. MAX(1,Q) ) ) THEN - INFO = -11 + ELSE IF ( COLMAJOR .AND. LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF (.NOT. COLMAJOR .AND. LDX11 .LT. MAX( 1, Q ) ) THEN + INFO = -11 + ELSE IF (COLMAJOR .AND. LDX12 .LT. MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF (.NOT. COLMAJOR .AND. LDX12 .LT. MAX( 1, M-Q ) ) THEN + INFO = -13 + ELSE IF (COLMAJOR .AND. LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -15 + ELSE IF (.NOT. COLMAJOR .AND. LDX21 .LT. MAX( 1, Q ) ) THEN + INFO = -15 + ELSE IF (COLMAJOR .AND. LDX22 .LT. MAX( 1, M-P ) ) THEN + INFO = -17 + ELSE IF (.NOT. COLMAJOR .AND. LDX22 .LT. MAX( 1, M-Q ) ) THEN + INFO = -17 ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN INFO = -20 ELSE IF( WANTU2 .AND. LDU2 .LT. M-P ) THEN diff --git a/lapack-netlib/SRC/sorcsd2by1.f b/lapack-netlib/SRC/sorcsd2by1.f new file mode 100644 index 000000000..9f02a7c16 --- /dev/null +++ b/lapack-netlib/SRC/sorcsd2by1.f @@ -0,0 +1,711 @@ +*> \brief \b SORCSD2BY1 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SORCSD2BY1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, +* X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T, +* LDV1T, WORK, LWORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBU1, JOBU2, JOBV1T +* INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21, +* $ M, P, Q +* .. +* .. Array Arguments .. +* REAL THETA(*) +* REAL U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* INTEGER IWORK(*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> SORCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with +*> orthonormal columns that has been partitioned into a 2-by-1 block +*> structure: +*> +*> [ I 0 0 ] +*> [ 0 C 0 ] +*> [ X11 ] [ U1 | ] [ 0 0 0 ] +*> X = [-----] = [---------] [----------] V1**T . +*> [ X21 ] [ | U2 ] [ 0 0 0 ] +*> [ 0 S 0 ] +*> [ 0 0 I ] +*> +*> X11 is P-by-Q. The orthogonal matrices U1, U2, V1, and V2 are P-by-P, +*> (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are +*> R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in +*> which R = MIN(P,M-P,Q,M-Q). +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBU1 +*> \verbatim +*> JOBU1 is CHARACTER +*> = 'Y': U1 is computed; +*> otherwise: U1 is not computed. +*> \endverbatim +*> +*> \param[in] JOBU2 +*> \verbatim +*> JOBU2 is CHARACTER +*> = 'Y': U2 is computed; +*> otherwise: U2 is not computed. +*> \endverbatim +*> +*> \param[in] JOBV1T +*> \verbatim +*> JOBV1T is CHARACTER +*> = 'Y': V1T is computed; +*> otherwise: V1T is not computed. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows and columns in X. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11 and X12. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M. +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is REAL array, dimension (LDX11,Q) +*> On entry, part of the orthogonal matrix whose CSD is +*> desired. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= MAX(1,P). +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is REAL array, dimension (LDX21,Q) +*> On entry, part of the orthogonal matrix whose CSD is +*> desired. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= MAX(1,M-P). +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is REAL array, dimension (R), in which R = +*> MIN(P,M-P,Q,M-Q). +*> C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and +*> S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ). +*> \endverbatim +*> +*> \param[out] U1 +*> \verbatim +*> U1 is REAL array, dimension (P) +*> If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1. +*> \endverbatim +*> +*> \param[in] LDU1 +*> \verbatim +*> LDU1 is INTEGER +*> The leading dimension of U1. If JOBU1 = 'Y', LDU1 >= +*> MAX(1,P). +*> \endverbatim +*> +*> \param[out] U2 +*> \verbatim +*> U2 is REAL array, dimension (M-P) +*> If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal +*> matrix U2. +*> \endverbatim +*> +*> \param[in] LDU2 +*> \verbatim +*> LDU2 is INTEGER +*> The leading dimension of U2. If JOBU2 = 'Y', LDU2 >= +*> MAX(1,M-P). +*> \endverbatim +*> +*> \param[out] V1T +*> \verbatim +*> V1T is REAL array, dimension (Q) +*> If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal +*> matrix V1**T. +*> \endverbatim +*> +*> \param[in] LDV1T +*> \verbatim +*> LDV1T is INTEGER +*> The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >= +*> MAX(1,Q). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> If INFO > 0 on exit, WORK(2:R) contains the values PHI(1), +*> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R), +*> define the matrix in intermediate bidiagonal-block form +*> remaining after nonconvergence. INFO specifies the number +*> of nonzero PHI's. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> \endverbatim +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the work array, and no error +*> message related to LWORK is issued by XERBLA. +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (M-MIN(P,M-P,Q,M-Q)) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: SBBCSD did not converge. See the description of WORK +*> above for details. +*> \endverbatim +*> +*> \par Reference: +* =============== +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup realOTHERcomputational +* +* ===================================================================== + SUBROUTINE SORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, + $ X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T, + $ LDV1T, WORK, LWORK, IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + CHARACTER JOBU1, JOBU2, JOBV1T + INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21, + $ M, P, Q +* .. +* .. Array Arguments .. + REAL THETA(*) + REAL U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) + INTEGER IWORK(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 ) +* .. +* .. Local Scalars .. + INTEGER CHILDINFO, I, IB11D, IB11E, IB12D, IB12E, + $ IB21D, IB21E, IB22D, IB22E, IBBCSD, IORBDB, + $ IORGLQ, IORGQR, IPHI, ITAUP1, ITAUP2, ITAUQ1, + $ J, LBBCSD, LORBDB, LORGLQ, LORGLQMIN, + $ LORGLQOPT, LORGQR, LORGQRMIN, LORGQROPT, + $ LWORKMIN, LWORKOPT, R + LOGICAL LQUERY, WANTU1, WANTU2, WANTV1T +* .. +* .. External Subroutines .. + EXTERNAL SBBCSD, SCOPY, SLACPY, SLAPMR, SLAPMT, SORBDB1, + $ SORBDB2, SORBDB3, SORBDB4, SORGLQ, SORGQR, + $ XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Function .. + INTRINSIC INT, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + WANTU1 = LSAME( JOBU1, 'Y' ) + WANTU2 = LSAME( JOBU2, 'Y' ) + WANTV1T = LSAME( JOBV1T, 'Y' ) + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -4 + ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN + INFO = -5 + ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN + INFO = -6 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -8 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -10 + ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN + INFO = -13 + ELSE IF( WANTU2 .AND. LDU2 .LT. M - P ) THEN + INFO = -15 + ELSE IF( WANTV1T .AND. LDV1T .LT. Q ) THEN + INFO = -17 + END IF +* + R = MIN( P, M-P, Q, M-Q ) +* +* Compute workspace +* +* WORK layout: +* |-------------------------------------------------------| +* | LWORKOPT (1) | +* |-------------------------------------------------------| +* | PHI (MAX(1,R-1)) | +* |-------------------------------------------------------| +* | TAUP1 (MAX(1,P)) | B11D (R) | +* | TAUP2 (MAX(1,M-P)) | B11E (R-1) | +* | TAUQ1 (MAX(1,Q)) | B12D (R) | +* |-----------------------------------------| B12E (R-1) | +* | SORBDB WORK | SORGQR WORK | SORGLQ WORK | B21D (R) | +* | | | | B21E (R-1) | +* | | | | B22D (R) | +* | | | | B22E (R-1) | +* | | | | SBBCSD WORK | +* |-------------------------------------------------------| +* + IF( INFO .EQ. 0 ) THEN + IPHI = 2 + IB11D = IPHI + MAX( 1, R-1 ) + IB11E = IB11D + MAX( 1, R ) + IB12D = IB11E + MAX( 1, R - 1 ) + IB12E = IB12D + MAX( 1, R ) + IB21D = IB12E + MAX( 1, R - 1 ) + IB21E = IB21D + MAX( 1, R ) + IB22D = IB21E + MAX( 1, R - 1 ) + IB22E = IB22D + MAX( 1, R ) + IBBCSD = IB22E + MAX( 1, R - 1 ) + ITAUP1 = IPHI + MAX( 1, R-1 ) + ITAUP2 = ITAUP1 + MAX( 1, P ) + ITAUQ1 = ITAUP2 + MAX( 1, M-P ) + IORBDB = ITAUQ1 + MAX( 1, Q ) + IORGQR = ITAUQ1 + MAX( 1, Q ) + IORGLQ = ITAUQ1 + MAX( 1, Q ) + IF( R .EQ. Q ) THEN + CALL SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, + $ 0, 0, WORK, -1, CHILDINFO ) + LORBDB = INT( WORK(1) ) + IF( P .GE. M-P ) THEN + CALL SORGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, P ) + LORGQROPT = INT( WORK(1) ) + ELSE + CALL SORGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, M-P ) + LORGQROPT = INT( WORK(1) ) + END IF + CALL SORGLQ( MAX(0,Q-1), MAX(0,Q-1), MAX(0,Q-1), V1T, LDV1T, + $ 0, WORK(1), -1, CHILDINFO ) + LORGLQMIN = MAX( 1, Q-1 ) + LORGLQOPT = INT( WORK(1) ) + CALL SBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA, + $ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, 0, 0, + $ 0, 0, 0, 0, 0, 0, WORK(1), -1, CHILDINFO ) + LBBCSD = INT( WORK(1) ) + ELSE IF( R .EQ. P ) THEN + CALL SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, + $ 0, 0, WORK(1), -1, CHILDINFO ) + LORBDB = INT( WORK(1) ) + IF( P-1 .GE. M-P ) THEN + CALL SORGQR( P-1, P-1, P-1, U1(2,2), LDU1, 0, WORK(1), + $ -1, CHILDINFO ) + LORGQRMIN = MAX( 1, P-1 ) + LORGQROPT = INT( WORK(1) ) + ELSE + CALL SORGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, M-P ) + LORGQROPT = INT( WORK(1) ) + END IF + CALL SORGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1, + $ CHILDINFO ) + LORGLQMIN = MAX( 1, Q ) + LORGLQOPT = INT( WORK(1) ) + CALL SBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA, + $ 0, V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, 0, 0, + $ 0, 0, 0, 0, 0, 0, WORK(1), -1, CHILDINFO ) + LBBCSD = INT( WORK(1) ) + ELSE IF( R .EQ. M-P ) THEN + CALL SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, + $ 0, 0, WORK(1), -1, CHILDINFO ) + LORBDB = INT( WORK(1) ) + IF( P .GE. M-P-1 ) THEN + CALL SORGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, P ) + LORGQROPT = INT( WORK(1) ) + ELSE + CALL SORGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, 0, + $ WORK(1), -1, CHILDINFO ) + LORGQRMIN = MAX( 1, M-P-1 ) + LORGQROPT = INT( WORK(1) ) + END IF + CALL SORGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1, + $ CHILDINFO ) + LORGLQMIN = MAX( 1, Q ) + LORGLQOPT = INT( WORK(1) ) + CALL SBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P, + $ THETA, 0, 0, 1, V1T, LDV1T, U2, LDU2, U1, LDU1, + $ 0, 0, 0, 0, 0, 0, 0, 0, WORK(1), -1, + $ CHILDINFO ) + LBBCSD = INT( WORK(1) ) + ELSE + CALL SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, + $ 0, 0, 0, WORK(1), -1, CHILDINFO ) + LORBDB = M + INT( WORK(1) ) + IF( P .GE. M-P ) THEN + CALL SORGQR( P, P, M-Q, U1, LDU1, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, P ) + LORGQROPT = INT( WORK(1) ) + ELSE + CALL SORGQR( M-P, M-P, M-Q, U2, LDU2, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, M-P ) + LORGQROPT = INT( WORK(1) ) + END IF + CALL SORGLQ( Q, Q, Q, V1T, LDV1T, 0, WORK(1), -1, + $ CHILDINFO ) + LORGLQMIN = MAX( 1, Q ) + LORGLQOPT = INT( WORK(1) ) + CALL SBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q, + $ THETA, 0, U2, LDU2, U1, LDU1, 0, 1, V1T, LDV1T, + $ 0, 0, 0, 0, 0, 0, 0, 0, WORK(1), -1, + $ CHILDINFO ) + LBBCSD = INT( WORK(1) ) + END IF + LWORKMIN = MAX( IORBDB+LORBDB-1, + $ IORGQR+LORGQRMIN-1, + $ IORGLQ+LORGLQMIN-1, + $ IBBCSD+LBBCSD-1 ) + LWORKOPT = MAX( IORBDB+LORBDB-1, + $ IORGQR+LORGQROPT-1, + $ IORGLQ+LORGLQOPT-1, + $ IBBCSD+LBBCSD-1 ) + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -19 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'SORCSD2BY1', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF + LORGQR = LWORK-IORGQR+1 + LORGLQ = LWORK-IORGLQ+1 +* +* Handle four cases separately: R = Q, R = P, R = M-P, and R = M-Q, +* in which R = MIN(P,M-P,Q,M-Q) +* + IF( R .EQ. Q ) THEN +* +* Case 1: R = Q +* +* Simultaneously bidiagonalize X11 and X21 +* + CALL SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2), + $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO ) +* +* Accumulate Householder reflectors +* + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL SLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 ) + CALL SORGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR), + $ LORGQR, CHILDINFO ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL SLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 ) + CALL SORGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + V1T(1,1) = ONE + DO J = 2, Q + V1T(1,J) = ZERO + V1T(J,1) = ZERO + END DO + CALL SLACPY( 'U', Q-1, Q-1, X21(1,2), LDX21, V1T(2,2), + $ LDV1T ) + CALL SORGLQ( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1), + $ WORK(IORGLQ), LORGLQ, CHILDINFO ) + END IF +* +* Simultaneously diagonalize X11 and X21. +* + CALL SBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA, + $ WORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, + $ WORK(IB11D), WORK(IB11E), WORK(IB12D), + $ WORK(IB12E), WORK(IB21D), WORK(IB21E), + $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD, + $ CHILDINFO ) +* +* Permute rows and columns to place zero submatrices in +* preferred positions +* + IF( Q .GT. 0 .AND. WANTU2 ) THEN + DO I = 1, Q + IWORK(I) = M - P - Q + I + END DO + DO I = Q + 1, M - P + IWORK(I) = I - Q + END DO + CALL SLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK ) + END IF + ELSE IF( R .EQ. P ) THEN +* +* Case 2: R = P +* +* Simultaneously bidiagonalize X11 and X21 +* + CALL SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2), + $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO ) +* +* Accumulate Householder reflectors +* + IF( WANTU1 .AND. P .GT. 0 ) THEN + U1(1,1) = ONE + DO J = 2, P + U1(1,J) = ZERO + U1(J,1) = ZERO + END DO + CALL SLACPY( 'L', P-1, P-1, X11(2,1), LDX11, U1(2,2), LDU1 ) + CALL SORGQR( P-1, P-1, P-1, U1(2,2), LDU1, WORK(ITAUP1), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL SLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 ) + CALL SORGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL SLACPY( 'U', P, Q, X11, LDX11, V1T, LDV1T ) + CALL SORGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1), + $ WORK(IORGLQ), LORGLQ, CHILDINFO ) + END IF +* +* Simultaneously diagonalize X11 and X21. +* + CALL SBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA, + $ WORK(IPHI), V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, + $ WORK(IB11D), WORK(IB11E), WORK(IB12D), + $ WORK(IB12E), WORK(IB21D), WORK(IB21E), + $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD, + $ CHILDINFO ) +* +* Permute rows and columns to place identity submatrices in +* preferred positions +* + IF( Q .GT. 0 .AND. WANTU2 ) THEN + DO I = 1, Q + IWORK(I) = M - P - Q + I + END DO + DO I = Q + 1, M - P + IWORK(I) = I - Q + END DO + CALL SLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK ) + END IF + ELSE IF( R .EQ. M-P ) THEN +* +* Case 3: R = M-P +* +* Simultaneously bidiagonalize X11 and X21 +* + CALL SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2), + $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO ) +* +* Accumulate Householder reflectors +* + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL SLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 ) + CALL SORGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR), + $ LORGQR, CHILDINFO ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + U2(1,1) = ONE + DO J = 2, M-P + U2(1,J) = ZERO + U2(J,1) = ZERO + END DO + CALL SLACPY( 'L', M-P-1, M-P-1, X21(2,1), LDX21, U2(2,2), + $ LDU2 ) + CALL SORGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, + $ WORK(ITAUP2), WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL SLACPY( 'U', M-P, Q, X21, LDX21, V1T, LDV1T ) + CALL SORGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1), + $ WORK(IORGLQ), LORGLQ, CHILDINFO ) + END IF +* +* Simultaneously diagonalize X11 and X21. +* + CALL SBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P, + $ THETA, WORK(IPHI), 0, 1, V1T, LDV1T, U2, LDU2, U1, + $ LDU1, WORK(IB11D), WORK(IB11E), WORK(IB12D), + $ WORK(IB12E), WORK(IB21D), WORK(IB21E), + $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD, + $ CHILDINFO ) +* +* Permute rows and columns to place identity submatrices in +* preferred positions +* + IF( Q .GT. R ) THEN + DO I = 1, R + IWORK(I) = Q - R + I + END DO + DO I = R + 1, Q + IWORK(I) = I - R + END DO + IF( WANTU1 ) THEN + CALL SLAPMT( .FALSE., P, Q, U1, LDU1, IWORK ) + END IF + IF( WANTV1T ) THEN + CALL SLAPMR( .FALSE., Q, Q, V1T, LDV1T, IWORK ) + END IF + END IF + ELSE +* +* Case 4: R = M-Q +* +* Simultaneously bidiagonalize X11 and X21 +* + CALL SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2), + $ WORK(ITAUQ1), WORK(IORBDB), WORK(IORBDB+M), + $ LORBDB-M, CHILDINFO ) +* +* Accumulate Householder reflectors +* + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL SCOPY( P, WORK(IORBDB), 1, U1, 1 ) + DO J = 2, P + U1(1,J) = ZERO + END DO + CALL SLACPY( 'L', P-1, M-Q-1, X11(2,1), LDX11, U1(2,2), + $ LDU1 ) + CALL SORGQR( P, P, M-Q, U1, LDU1, WORK(ITAUP1), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL SCOPY( M-P, WORK(IORBDB+P), 1, U2, 1 ) + DO J = 2, M-P + U2(1,J) = ZERO + END DO + CALL SLACPY( 'L', M-P-1, M-Q-1, X21(2,1), LDX21, U2(2,2), + $ LDU2 ) + CALL SORGQR( M-P, M-P, M-Q, U2, LDU2, WORK(ITAUP2), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL SLACPY( 'U', M-Q, Q, X21, LDX21, V1T, LDV1T ) + CALL SLACPY( 'U', P-(M-Q), Q-(M-Q), X11(M-Q+1,M-Q+1), LDX11, + $ V1T(M-Q+1,M-Q+1), LDV1T ) + CALL SLACPY( 'U', -P+Q, Q-P, X21(M-Q+1,P+1), LDX21, + $ V1T(P+1,P+1), LDV1T ) + CALL SORGLQ( Q, Q, Q, V1T, LDV1T, WORK(ITAUQ1), + $ WORK(IORGLQ), LORGLQ, CHILDINFO ) + END IF +* +* Simultaneously diagonalize X11 and X21. +* + CALL SBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q, + $ THETA, WORK(IPHI), U2, LDU2, U1, LDU1, 0, 1, V1T, + $ LDV1T, WORK(IB11D), WORK(IB11E), WORK(IB12D), + $ WORK(IB12E), WORK(IB21D), WORK(IB21E), + $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD, + $ CHILDINFO ) +* +* Permute rows and columns to place identity submatrices in +* preferred positions +* + IF( P .GT. R ) THEN + DO I = 1, R + IWORK(I) = P - R + I + END DO + DO I = R + 1, P + IWORK(I) = I - R + END DO + IF( WANTU1 ) THEN + CALL SLAPMT( .FALSE., P, P, U1, LDU1, IWORK ) + END IF + IF( WANTV1T ) THEN + CALL SLAPMR( .FALSE., P, Q, V1T, LDV1T, IWORK ) + END IF + END IF + END IF +* + RETURN +* +* End of SORCSD2BY1 +* + END + diff --git a/lapack-netlib/SRC/sstemr.f b/lapack-netlib/SRC/sstemr.f index ba859db8b..2e995802e 100644 --- a/lapack-netlib/SRC/sstemr.f +++ b/lapack-netlib/SRC/sstemr.f @@ -294,7 +294,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup realOTHERcomputational * @@ -312,10 +312,10 @@ $ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, $ IWORK, LIWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE @@ -389,6 +389,7 @@ WU = ZERO IIL = 0 IIU = 0 + NSPLIT = 0 IF( VALEIG ) THEN * We do not reference VL, VU in the cases RANGE = 'I','A' diff --git a/lapack-netlib/SRC/ssycon_rook.f b/lapack-netlib/SRC/ssycon_rook.f new file mode 100644 index 000000000..54087d1ec --- /dev/null +++ b/lapack-netlib/SRC/ssycon_rook.f @@ -0,0 +1,258 @@ +*> \brief \b SSYCON_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYCON_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, +* WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* REAL ANORM, RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ), IWORK( * ) +* REAL A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYCON_ROOK estimates the reciprocal of the condition number (in the +*> 1-norm) of a real symmetric matrix A using the factorization +*> A = U*D*U**T or A = L*D*L**T computed by SSYTRF_ROOK. +*> +*> An estimate is obtained for norm(inv(A)), and the reciprocal of the +*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by SSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by SSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] ANORM +*> \verbatim +*> ANORM is REAL +*> The 1-norm of the original matrix A. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is REAL +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an +*> estimate of the 1-norm of inv(A) computed in this routine. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup realSYcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> November 2011, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, + $ IWORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N + REAL ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + REAL A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, KASE + REAL AINVNM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SLACN2, SSYTRS_ROOK, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( ANORM.LT.ZERO ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYCON_ROOK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + RCOND = ZERO + IF( N.EQ.0 ) THEN + RCOND = ONE + RETURN + ELSE IF( ANORM.LE.ZERO ) THEN + RETURN + END IF +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO 10 I = N, 1, -1 + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) + $ RETURN + 10 CONTINUE + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO 20 I = 1, N + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) + $ RETURN + 20 CONTINUE + END IF +* +* Estimate the 1-norm of the inverse. +* + KASE = 0 + 30 CONTINUE + CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN +* +* Multiply by inv(L*D*L**T) or inv(U*D*U**T). +* + CALL SSYTRS_ROOK( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO ) + GO TO 30 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM.NE.ZERO ) + $ RCOND = ( ONE / AINVNM ) / ANORM +* + RETURN +* +* End of SSYCON_ROOK +* + END diff --git a/lapack-netlib/SRC/ssysv_rook.f b/lapack-netlib/SRC/ssysv_rook.f new file mode 100644 index 000000000..6c159338a --- /dev/null +++ b/lapack-netlib/SRC/ssysv_rook.f @@ -0,0 +1,293 @@ +*> \brief SSYSV_ROOK computes the solution to system of linear equations A * X = B for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYSV_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYSV_ROOK computes the solution to a real system of linear +*> equations +*> A * X = B, +*> where A is an N-by-N symmetric matrix and X and B are N-by-NRHS +*> matrices. +*> +*> The diagonal pivoting method is used to factor A as +*> A = U * D * U**T, if UPLO = 'U', or +*> A = L * D * L**T, if UPLO = 'L', +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and D is symmetric and block diagonal with +*> 1-by-1 and 2-by-2 diagonal blocks. +*> +*> SSYTRF_ROOK is called to compute the factorization of a real +*> symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal +*> pivoting method. +*> +*> The factored form of A is then used to solve the system +*> of equations A * X = B by calling SSYTRS_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, the block diagonal matrix D and the +*> multipliers used to obtain the factor U or L from the +*> factorization A = U*D*U**T or A = L*D*L**T as computed by +*> SSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, +*> as determined by SSYTRF_ROOK. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= 1, and for best performance +*> LWORK >= max(1,N*NB), where NB is the optimal blocksize for +*> SSYTRF_ROOK. +*> +*> TRS will be done with Level 2 BLAS +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, so the solution could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup realSYsolve +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> April 2012, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.4.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SSYTRF_ROOK, SSYTRS_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + CALL SSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, -1, INFO ) + LWKOPT = WORK(1) + END IF + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYSV_ROOK ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = U*D*U**T or A = L*D*L**T. +* + CALL SSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* +* Solve with TRS_ROOK ( Use Level 2 BLAS) +* + CALL SSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of SSYSV_ROOK +* + END diff --git a/lapack-netlib/SRC/ssytf2.f b/lapack-netlib/SRC/ssytf2.f index 68e4dee6b..1ca56621c 100644 --- a/lapack-netlib/SRC/ssytf2.f +++ b/lapack-netlib/SRC/ssytf2.f @@ -90,13 +90,22 @@ *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D. -*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were -*> interchanged and D(k,k) is a 1-by-1 diagonal block. -*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and -*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) -*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = -*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were -*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns +*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) +*> is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns +*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1) +*> is a 2-by-2 diagonal block. *> \endverbatim *> *> \param[out] INFO @@ -118,7 +127,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup realSYcomputational * @@ -186,10 +195,10 @@ * ===================================================================== SUBROUTINE SSYTF2( UPLO, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER UPLO @@ -269,7 +278,8 @@ ABSAKK = ABS( A( K, K ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. * IF( K.GT.1 ) THEN IMAX = ISAMAX( K-1, A( 1, K ), 1 ) @@ -280,7 +290,8 @@ * IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN * -* Column K is zero or contains a NaN: set INFO and continue +* Column K is zero or underflow, or contains a NaN: +* set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K @@ -437,7 +448,8 @@ ABSAKK = ABS( A( K, K ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. * IF( K.LT.N ) THEN IMAX = K + ISAMAX( N-K, A( K+1, K ), 1 ) @@ -448,7 +460,8 @@ * IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN * -* Column K is zero or contains a NaN: set INFO and continue +* Column K is zero or underflow, or contains a NaN: +* set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K diff --git a/lapack-netlib/SRC/ssytf2_rook.f b/lapack-netlib/SRC/ssytf2_rook.f new file mode 100644 index 000000000..270530d79 --- /dev/null +++ b/lapack-netlib/SRC/ssytf2_rook.f @@ -0,0 +1,813 @@ +*> \brief \b SSYTF2_ROOK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYTF2_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYTF2_ROOK computes the factorization of a real symmetric matrix A +*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method: +*> +*> A = U*D*U**T or A = L*D*L**T +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, U**T is the transpose of U, and D is symmetric and +*> block diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the unblocked version of the algorithm, calling Level 2 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> n-by-n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading n-by-n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, the block diagonal matrix D and the multipliers used +*> to obtain the factor U or L (see below for further details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup realSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', then A = U*D*U**T, where +*> U = P(n)*U(n)* ... *P(k)U(k)* ..., +*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to +*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I v 0 ) k-s +*> U(k) = ( 0 I 0 ) s +*> ( 0 0 I ) n-k +*> k-s s n-k +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). +*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), +*> and A(k,k), and v overwrites A(1:k-2,k-1:k). +*> +*> If UPLO = 'L', then A = L*D*L**T, where +*> L = P(1)*L(1)* ... *P(k)*L(k)* ..., +*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to +*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I 0 0 ) k-1 +*> L(k) = ( 0 I 0 ) s +*> ( 0 v I ) n-k-s+1 +*> k-1 s n-k-s+1 +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). +*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), +*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> 01-01-96 - Based on modifications by +*> J. Lewis, Boeing Computer Services Company +*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville abd , USA +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER, DONE + INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP, + $ P, II + REAL ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, + $ ROWMAX, STEMP, T, WK, WKM1, WKP1, SFMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ISAMAX + REAL SLAMCH + EXTERNAL LSAME, ISAMAX, SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL SSCAL, SSWAP, SSYR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYTF2_ROOK', -INFO ) + RETURN + END IF +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = SLAMCH( 'S' ) +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2 +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 70 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( A( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = ISAMAX( K-1, A( 1, K ), 1 ) + COLMAX = ABS( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + ELSE +* +* Test for interchange +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABSAKK.GE.ALPHA*COLMAX +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, +* use 1-by-1 pivot block +* + KP = K + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* Begin pivot search loop body +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + ISAMAX( K-IMAX, A( IMAX, IMAX+1 ), + $ LDA ) + ROWMAX = ABS( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = ISAMAX( IMAX-1, A( 1, IMAX ), 1 ) + STEMP = ABS( A( ITEMP, IMAX ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX +* + IF( .NOT.( ABS( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX .EQ. COLMAX, +* used to handle NaN and Inf +* + ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot NOT found, set variables and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 12 +* + END IF +* +* Swap TWO rows and TWO columns +* +* First swap +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Interchange rows and column K and P in the leading +* submatrix A(1:k,1:k) if we have a 2-by-2 pivot +* + IF( P.GT.1 ) + $ CALL SSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 ) + IF( P.LT.(K-1) ) + $ CALL SSWAP( K-P-1, A( P+1, K ), 1, A( P, P+1 ), + $ LDA ) + T = A( K, K ) + A( K, K ) = A( P, P ) + A( P, P ) = T + END IF +* +* Second swap +* + KK = K - KSTEP + 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the leading +* submatrix A(1:k,1:k) +* + IF( KP.GT.1 ) + $ CALL SSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) + IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) ) + $ CALL SSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K-1, K ) + A( K-1, K ) = A( KP, K ) + A( KP, K ) = T + END IF + END IF +* +* Update the leading submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* + IF( K.GT.1 ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) and +* store U(k) in column k +* + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*1/D(k)*W(k)**T +* + D11 = ONE / A( K, K ) + CALL SSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) +* +* Store U(k) in column k +* + CALL SSCAL( K-1, D11, A( 1, K ), 1 ) + ELSE +* +* Store L(k) in column K +* + D11 = A( K, K ) + DO 16 II = 1, K - 1 + A( II, K ) = A( II, K ) / D11 + 16 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL SSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k-1 now hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* +* Perform a rank-2 update of A(1:k-2,1:k-2) as +* +* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T +* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.GT.2 ) THEN +* + D12 = A( K-1, K ) + D22 = A( K-1, K-1 ) / D12 + D11 = A( K, K ) / D12 + T = ONE / ( D11*D22-ONE ) +* + DO 30 J = K - 2, 1, -1 +* + WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) + WK = T*( D22*A( J, K )-A( J, K-1 ) ) +* + DO 20 I = J, 1, -1 + A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - + $ ( A( I, K-1 ) / D12 )*WKM1 + 20 CONTINUE +* +* Store U(k) and U(k-1) in cols k and k-1 for row J +* + A( J, K ) = WK / D12 + A( J, K-1 ) = WKM1 / D12 +* + 30 CONTINUE +* + END IF +* + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2 +* + K = 1 + 40 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 70 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( A( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + ISAMAX( N-K, A( K+1, K ), 1 ) + COLMAX = ABS( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + ELSE +* +* Test for interchange +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABSAKK.GE.ALPHA*COLMAX +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 42 CONTINUE +* +* Begin pivot search loop body +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + ISAMAX( IMAX-K, A( IMAX, K ), LDA ) + ROWMAX = ABS( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + ISAMAX( N-IMAX, A( IMAX+1, IMAX ), + $ 1 ) + STEMP = ABS( A( ITEMP, IMAX ) ) + IF( STEMP.GT.ROWMAX ) THEN + ROWMAX = STEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX +* + IF( .NOT.( ABS( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX .EQ. COLMAX, +* used to handle NaN and Inf +* + ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot NOT found, set variables and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 42 +* + END IF +* +* Swap TWO rows and TWO columns +* +* First swap +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Interchange rows and column K and P in the trailing +* submatrix A(k:n,k:n) if we have a 2-by-2 pivot +* + IF( P.LT.N ) + $ CALL SSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) + IF( P.GT.(K+1) ) + $ CALL SSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA ) + T = A( K, K ) + A( K, K ) = A( P, P ) + A( P, P ) = T + END IF +* +* Second swap +* + KK = K + KSTEP - 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the trailing +* submatrix A(k:n,k:n) +* + IF( KP.LT.N ) + $ CALL SSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) ) + $ CALL SSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K+1, K ) + A( K+1, K ) = A( KP, K ) + A( KP, K ) = T + END IF + END IF +* +* Update the trailing submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* + IF( K.LT.N ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) and +* store L(k) in column k +* + IF( ABS( A( K, K ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* + D11 = ONE / A( K, K ) + CALL SSYR( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) +* +* Store L(k) in column k +* + CALL SSCAL( N-K, D11, A( K+1, K ), 1 ) + ELSE +* +* Store L(k) in column k +* + D11 = A( K, K ) + DO 46 II = K + 1, N + A( II, K ) = A( II, K ) / D11 + 46 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL SSYR( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* +* +* Perform a rank-2 update of A(k+2:n,k+2:n) as +* +* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T +* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.LT.N-1 ) THEN +* + D21 = A( K+1, K ) + D11 = A( K+1, K+1 ) / D21 + D22 = A( K, K ) / D21 + T = ONE / ( D11*D22-ONE ) +* + DO 60 J = K + 2, N +* +* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* + WK = T*( D11*A( J, K )-A( J, K+1 ) ) + WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) +* +* Perform a rank-2 update of A(k+2:n,k+2:n) +* + DO 50 I = J, N + A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - + $ ( A( I, K+1 ) / D21 )*WKP1 + 50 CONTINUE +* +* Store L(k) and L(k+1) in cols k and k+1 for row J +* + A( J, K ) = WK / D21 + A( J, K+1 ) = WKP1 / D21 +* + 60 CONTINUE +* + END IF +* + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 40 +* + END IF +* + 70 CONTINUE +* + RETURN +* +* End of SSYTF2_ROOK +* + END diff --git a/lapack-netlib/SRC/ssytrf_rook.f b/lapack-netlib/SRC/ssytrf_rook.f new file mode 100644 index 000000000..bf60764cb --- /dev/null +++ b/lapack-netlib/SRC/ssytrf_rook.f @@ -0,0 +1,393 @@ +*> \brief \b SSYTRF_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYTRF_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYTRF_ROOK computes the factorization of a real symmetric matrix A +*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. +*> The form of the factorization is +*> +*> A = U*D*U**T or A = L*D*L**T +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and D is symmetric and block diagonal with +*> 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, the block diagonal matrix D and the multipliers used +*> to obtain the factor U or L (see below for further details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MAX(1,LWORK)). +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >=1. For best performance +*> LWORK >= N*NB, where NB is the block size returned by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup realSYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', then A = U*D*U**T, where +*> U = P(n)*U(n)* ... *P(k)U(k)* ..., +*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to +*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I v 0 ) k-s +*> U(k) = ( 0 I 0 ) s +*> ( 0 0 I ) n-k +*> k-s s n-k +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). +*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), +*> and A(k,k), and v overwrites A(1:k-2,k-1:k). +*> +*> If UPLO = 'L', then A = L*D*L**T, where +*> L = P(1)*L(1)* ... *P(k)*L(k)* ..., +*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to +*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I 0 0 ) k-1 +*> L(k) = ( 0 I 0 ) s +*> ( 0 v I ) n-k-s+1 +*> k-1 s n-k-s+1 +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). +*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), +*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2011, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL SLASYF_ROOK, SSYTF2_ROOK, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size +* + NB = ILAENV( 1, 'SSYTRF_ROOK', UPLO, N, -1, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYTRF_ROOK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* + NBMIN = 2 + LDWORK = N + IF( NB.GT.1 .AND. NB.LT.N ) THEN + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN + NB = MAX( LWORK / LDWORK, 1 ) + NBMIN = MAX( 2, ILAENV( 2, 'SSYTRF_ROOK', + $ UPLO, N, -1, -1, -1 ) ) + END IF + ELSE + IWS = 1 + END IF + IF( NB.LT.NBMIN ) + $ NB = N +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* KB, where KB is the number of columns factorized by SLASYF_ROOK; +* KB is either NB or NB-1, or K for the last block +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 40 +* + IF( K.GT.NB ) THEN +* +* Factorize columns k-kb+1:k of A and use blocked code to +* update columns 1:k-kb +* + CALL SLASYF_ROOK( UPLO, K, NB, KB, A, LDA, + $ IPIV, WORK, LDWORK, IINFO ) + ELSE +* +* Use unblocked code to factorize columns 1:k of A +* + CALL SSYTF2_ROOK( UPLO, K, A, LDA, IPIV, IINFO ) + KB = K + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO +* +* No need to adjust IPIV +* +* Decrease K and return to the start of the main loop +* + K = K - KB + GO TO 10 +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* KB, where KB is the number of columns factorized by SLASYF_ROOK; +* KB is either NB or NB-1, or N-K+1 for the last block +* + K = 1 + 20 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 40 +* + IF( K.LE.N-NB ) THEN +* +* Factorize columns k:k+kb-1 of A and use blocked code to +* update columns k+kb:n +* + CALL SLASYF_ROOK( UPLO, N-K+1, NB, KB, A( K, K ), LDA, + $ IPIV( K ), WORK, LDWORK, IINFO ) + ELSE +* +* Use unblocked code to factorize columns k:n of A +* + CALL SSYTF2_ROOK( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), + $ IINFO ) + KB = N - K + 1 + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + K - 1 +* +* Adjust IPIV +* + DO 30 J = K, K + KB - 1 + IF( IPIV( J ).GT.0 ) THEN + IPIV( J ) = IPIV( J ) + K - 1 + ELSE + IPIV( J ) = IPIV( J ) - K + 1 + END IF + 30 CONTINUE +* +* Increase K and return to the start of the main loop +* + K = K + KB + GO TO 20 +* + END IF +* + 40 CONTINUE + WORK( 1 ) = LWKOPT + RETURN +* +* End of SSYTRF_ROOK +* + END diff --git a/lapack-netlib/SRC/ssytri_rook.f b/lapack-netlib/SRC/ssytri_rook.f new file mode 100644 index 000000000..0d0dfd98a --- /dev/null +++ b/lapack-netlib/SRC/ssytri_rook.f @@ -0,0 +1,450 @@ +*> \brief \b SSYTRI_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYTRI_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYTRI_ROOK computes the inverse of a real symmetric +*> matrix A using the factorization A = U*D*U**T or A = L*D*L**T +*> computed by SSYTRF_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the block diagonal matrix D and the multipliers +*> used to obtain the factor U or L as computed by SSYTRF_ROOK. +*> +*> On exit, if INFO = 0, the (symmetric) inverse of the original +*> matrix. If UPLO = 'U', the upper triangular part of the +*> inverse is formed and the part of A below the diagonal is not +*> referenced; if UPLO = 'L' the lower triangular part of the +*> inverse is formed and the part of A above the diagonal is +*> not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by SSYTRF_ROOK. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup realSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> April 2012, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER K, KP, KSTEP + REAL AK, AKKP1, AKP1, D, T, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SDOT + EXTERNAL LSAME, SDOT +* .. +* .. External Subroutines .. + EXTERNAL SCOPY, SSWAP, SSYMV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYTRI_ROOK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO 10 INFO = N, 1, -1 + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) + $ RETURN + 10 CONTINUE + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO 20 INFO = 1, N + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) + $ RETURN + 20 CONTINUE + END IF + INFO = 0 +* + IF( UPPER ) THEN +* +* Compute inv(A) from the factorization A = U*D*U**T. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + 30 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 40 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Invert the diagonal block. +* + A( K, K ) = ONE / A( K, K ) +* +* Compute column K of the inverse. +* + IF( K.GT.1 ) THEN + CALL SCOPY( K-1, A( 1, K ), 1, WORK, 1 ) + CALL SSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, + $ A( 1, K ), 1 ) + A( K, K ) = A( K, K ) - SDOT( K-1, WORK, 1, A( 1, K ), + $ 1 ) + END IF + KSTEP = 1 + ELSE +* +* 2 x 2 diagonal block +* +* Invert the diagonal block. +* + T = ABS( A( K, K+1 ) ) + AK = A( K, K ) / T + AKP1 = A( K+1, K+1 ) / T + AKKP1 = A( K, K+1 ) / T + D = T*( AK*AKP1-ONE ) + A( K, K ) = AKP1 / D + A( K+1, K+1 ) = AK / D + A( K, K+1 ) = -AKKP1 / D +* +* Compute columns K and K+1 of the inverse. +* + IF( K.GT.1 ) THEN + CALL SCOPY( K-1, A( 1, K ), 1, WORK, 1 ) + CALL SSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, + $ A( 1, K ), 1 ) + A( K, K ) = A( K, K ) - SDOT( K-1, WORK, 1, A( 1, K ), + $ 1 ) + A( K, K+1 ) = A( K, K+1 ) - + $ SDOT( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 ) + CALL SCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 ) + CALL SSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, + $ A( 1, K+1 ), 1 ) + A( K+1, K+1 ) = A( K+1, K+1 ) - + $ SDOT( K-1, WORK, 1, A( 1, K+1 ), 1 ) + END IF + KSTEP = 2 + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* Interchange rows and columns K and IPIV(K) in the leading +* submatrix A(1:k+1,1:k+1) +* + KP = IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.GT.1 ) + $ CALL SSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) + CALL SSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + ELSE +* +* Interchange rows and columns K and K+1 with -IPIV(K) and +* -IPIV(K+1)in the leading submatrix A(1:k+1,1:k+1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.GT.1 ) + $ CALL SSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) + CALL SSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) +* + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + TEMP = A( K, K+1 ) + A( K, K+1 ) = A( KP, K+1 ) + A( KP, K+1 ) = TEMP + END IF +* + K = K + 1 + KP = -IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.GT.1 ) + $ CALL SSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) + CALL SSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + END IF +* + K = K + 1 + GO TO 30 + 40 CONTINUE +* + ELSE +* +* Compute inv(A) from the factorization A = L*D*L**T. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = N + 50 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 60 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Invert the diagonal block. +* + A( K, K ) = ONE / A( K, K ) +* +* Compute column K of the inverse. +* + IF( K.LT.N ) THEN + CALL SCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) + CALL SSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, + $ ZERO, A( K+1, K ), 1 ) + A( K, K ) = A( K, K ) - SDOT( N-K, WORK, 1, A( K+1, K ), + $ 1 ) + END IF + KSTEP = 1 + ELSE +* +* 2 x 2 diagonal block +* +* Invert the diagonal block. +* + T = ABS( A( K, K-1 ) ) + AK = A( K-1, K-1 ) / T + AKP1 = A( K, K ) / T + AKKP1 = A( K, K-1 ) / T + D = T*( AK*AKP1-ONE ) + A( K-1, K-1 ) = AKP1 / D + A( K, K ) = AK / D + A( K, K-1 ) = -AKKP1 / D +* +* Compute columns K-1 and K of the inverse. +* + IF( K.LT.N ) THEN + CALL SCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) + CALL SSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, + $ ZERO, A( K+1, K ), 1 ) + A( K, K ) = A( K, K ) - SDOT( N-K, WORK, 1, A( K+1, K ), + $ 1 ) + A( K, K-1 ) = A( K, K-1 ) - + $ SDOT( N-K, A( K+1, K ), 1, A( K+1, K-1 ), + $ 1 ) + CALL SCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 ) + CALL SSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, + $ ZERO, A( K+1, K-1 ), 1 ) + A( K-1, K-1 ) = A( K-1, K-1 ) - + $ SDOT( N-K, WORK, 1, A( K+1, K-1 ), 1 ) + END IF + KSTEP = 2 + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* Interchange rows and columns K and IPIV(K) in the trailing +* submatrix A(k-1:n,k-1:n) +* + KP = IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.LT.N ) + $ CALL SSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) + CALL SSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA ) + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + ELSE +* +* Interchange rows and columns K and K-1 with -IPIV(K) and +* -IPIV(K-1) in the trailing submatrix A(k-1:n,k-1:n) +* + KP = -IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.LT.N ) + $ CALL SSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) + CALL SSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA ) +* + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + TEMP = A( K, K-1 ) + A( K, K-1 ) = A( KP, K-1 ) + A( KP, K-1 ) = TEMP + END IF +* + K = K - 1 + KP = -IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.LT.N ) + $ CALL SSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) + CALL SSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA ) + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + END IF +* + K = K - 1 + GO TO 50 + 60 CONTINUE + END IF +* + RETURN +* +* End of SSYTRI_ROOK +* + END diff --git a/lapack-netlib/SRC/ssytrs_rook.f b/lapack-netlib/SRC/ssytrs_rook.f new file mode 100644 index 000000000..240b454b6 --- /dev/null +++ b/lapack-netlib/SRC/ssytrs_rook.f @@ -0,0 +1,484 @@ +*> \brief \b SSYTRS_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYTRS_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYTRS_ROOK solves a system of linear equations A*X = B with +*> a real symmetric matrix A using the factorization A = U*D*U**T or +*> A = L*D*L**T computed by SSYTRF_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by SSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by SSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date April 2012 +* +*> \ingroup realSYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> April 2012, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + $ INFO ) +* +* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* April 2012 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J, K, KP + REAL AK, AKM1, AKM1K, BK, BKM1, DENOM +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SGEMV, SGER, SSCAL, SSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYTRS_ROOK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Solve A*X = B, where A = U*D*U**T. +* +* First solve U*D*X = B, overwriting B with X. +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 30 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(U(K)), where U(K) is the transformation +* stored in column K of A. +* + CALL SGER( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, + $ B( 1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + CALL SSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB ) + K = K - 1 + ELSE +* +* 2 x 2 diagonal block +* +* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K-1 ) + IF( KP.NE.K-1 ) + $ CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(U(K)), where U(K) is the transformation +* stored in columns K-1 and K of A. +* + IF( K.GT.2 ) THEN + CALL SGER( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), + $ LDB, B( 1, 1 ), LDB ) + CALL SGER( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ), + $ LDB, B( 1, 1 ), LDB ) + END IF +* +* Multiply by the inverse of the diagonal block. +* + AKM1K = A( K-1, K ) + AKM1 = A( K-1, K-1 ) / AKM1K + AK = A( K, K ) / AKM1K + DENOM = AKM1*AK - ONE + DO 20 J = 1, NRHS + BKM1 = B( K-1, J ) / AKM1K + BK = B( K, J ) / AKM1K + B( K-1, J ) = ( AK*BKM1-BK ) / DENOM + B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM + 20 CONTINUE + K = K - 2 + END IF +* + GO TO 10 + 30 CONTINUE +* +* Next solve U**T *X = B, overwriting B with X. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + 40 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 50 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Multiply by inv(U**T(K)), where U(K) is the transformation +* stored in column K of A. +* + IF( K.GT.1 ) + $ CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, + $ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB ) +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K + 1 + ELSE +* +* 2 x 2 diagonal block +* +* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation +* stored in columns K and K+1 of A. +* + IF( K.GT.1 ) THEN + CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, + $ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB ) + CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, + $ LDB, A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB ) + END IF +* +* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1). +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K+1 ) + IF( KP.NE.K+1 ) + $ CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) +* + K = K + 2 + END IF +* + GO TO 40 + 50 CONTINUE +* + ELSE +* +* Solve A*X = B, where A = L*D*L**T. +* +* First solve L*D*X = B, overwriting B with X. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + 60 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 80 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(L(K)), where L(K) is the transformation +* stored in column K of A. +* + IF( K.LT.N ) + $ CALL SGER( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ), + $ LDB, B( K+1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + CALL SSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB ) + K = K + 1 + ELSE +* +* 2 x 2 diagonal block +* +* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K+1 ) + IF( KP.NE.K+1 ) + $ CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(L(K)), where L(K) is the transformation +* stored in columns K and K+1 of A. +* + IF( K.LT.N-1 ) THEN + CALL SGER( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ), + $ LDB, B( K+2, 1 ), LDB ) + CALL SGER( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1, + $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) + END IF +* +* Multiply by the inverse of the diagonal block. +* + AKM1K = A( K+1, K ) + AKM1 = A( K, K ) / AKM1K + AK = A( K+1, K+1 ) / AKM1K + DENOM = AKM1*AK - ONE + DO 70 J = 1, NRHS + BKM1 = B( K, J ) / AKM1K + BK = B( K+1, J ) / AKM1K + B( K, J ) = ( AK*BKM1-BK ) / DENOM + B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM + 70 CONTINUE + K = K + 2 + END IF +* + GO TO 60 + 80 CONTINUE +* +* Next solve L**T *X = B, overwriting B with X. +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = N + 90 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 100 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Multiply by inv(L**T(K)), where L(K) is the transformation +* stored in column K of A. +* + IF( K.LT.N ) + $ CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), + $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K - 1 + ELSE +* +* 2 x 2 diagonal block +* +* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation +* stored in columns K-1 and K of A. +* + IF( K.LT.N ) THEN + CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), + $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) + CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), + $ LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ), + $ LDB ) + END IF +* +* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K-1 ) + IF( KP.NE.K-1 ) + $ CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) +* + K = K - 2 + END IF +* + GO TO 90 + 100 CONTINUE + END IF +* + RETURN +* +* End of SSYTRS_ROOK +* + END diff --git a/lapack-netlib/SRC/stpmqrt.f b/lapack-netlib/SRC/stpmqrt.f index 848507fc3..2763b9aff 100644 --- a/lapack-netlib/SRC/stpmqrt.f +++ b/lapack-netlib/SRC/stpmqrt.f @@ -175,7 +175,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup realOTHERcomputational * @@ -216,10 +216,10 @@ SUBROUTINE STPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, $ A, LDA, B, LDB, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -235,7 +235,7 @@ * .. * .. Local Scalars .. LOGICAL LEFT, RIGHT, TRAN, NOTRAN - INTEGER I, IB, MB, LB, KF, Q + INTEGER I, IB, MB, LB, KF, LDAQ, LDVQ * .. * .. External Functions .. LOGICAL LSAME @@ -257,10 +257,12 @@ TRAN = LSAME( TRANS, 'T' ) NOTRAN = LSAME( TRANS, 'N' ) * - IF( LEFT ) THEN - Q = M + IF ( LEFT ) THEN + LDVQ = MAX( 1, M ) + LDAQ = MAX( 1, K ) ELSE IF ( RIGHT ) THEN - Q = N + LDVQ = MAX( 1, N ) + LDAQ = MAX( 1, M ) END IF IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN INFO = -1 @@ -274,13 +276,13 @@ INFO = -5 ELSE IF( L.LT.0 .OR. L.GT.K ) THEN INFO = -6 - ELSE IF( NB.LT.1 .OR. NB.GT.K ) THEN + ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0) ) THEN INFO = -7 - ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN + ELSE IF( LDV.LT.LDVQ ) THEN INFO = -9 ELSE IF( LDT.LT.NB ) THEN INFO = -11 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + ELSE IF( LDA.LT.LDAQ ) THEN INFO = -13 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -15 diff --git a/lapack-netlib/SRC/stpqrt.f b/lapack-netlib/SRC/stpqrt.f index d9efb26f8..139c1f737 100644 --- a/lapack-netlib/SRC/stpqrt.f +++ b/lapack-netlib/SRC/stpqrt.f @@ -132,7 +132,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup realOTHERcomputational * @@ -189,10 +189,10 @@ SUBROUTINE STPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDT, N, M, L, NB @@ -219,9 +219,9 @@ INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 - ELSE IF( L.LT.0 .OR. L.GT.MIN(M,N) ) THEN + ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN INFO = -3 - ELSE IF( NB.LT.1 .OR. NB.GT.N ) THEN + ELSE IF( NB.LT.1 .OR. (NB.GT.N .AND. N.GT.0)) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 diff --git a/lapack-netlib/SRC/zbbcsd.f b/lapack-netlib/SRC/zbbcsd.f index dceb6b8d4..63cbde09f 100644 --- a/lapack-netlib/SRC/zbbcsd.f +++ b/lapack-netlib/SRC/zbbcsd.f @@ -322,7 +322,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex16OTHERcomputational * @@ -332,10 +332,10 @@ $ V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, $ B22D, B22E, RWORK, LRWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS @@ -476,7 +476,10 @@ * Initial deflation * IMAX = Q - DO WHILE( ( IMAX .GT. 1 ) .AND. ( PHI(IMAX-1) .EQ. ZERO ) ) + DO WHILE( IMAX .GT. 1 ) + IF( PHI(IMAX-1) .NE. ZERO ) THEN + EXIT + END IF IMAX = IMAX - 1 END DO IMIN = IMAX - 1 diff --git a/lapack-netlib/SRC/zgebal.f b/lapack-netlib/SRC/zgebal.f index 9c90f0b4b..ac616df89 100644 --- a/lapack-netlib/SRC/zgebal.f +++ b/lapack-netlib/SRC/zgebal.f @@ -121,7 +121,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex16GEcomputational * @@ -160,10 +160,10 @@ * ===================================================================== SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER JOB @@ -194,8 +194,8 @@ * .. External Functions .. LOGICAL DISNAN, LSAME INTEGER IZAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL DISNAN, LSAME, IZAMAX, DLAMCH + DOUBLE PRECISION DLAMCH, DZNRM2 + EXTERNAL DISNAN, LSAME, IZAMAX, DLAMCH, DZNRM2 * .. * .. External Subroutines .. EXTERNAL XERBLA, ZDSCAL, ZSWAP @@ -324,15 +324,9 @@ NOCONV = .FALSE. * DO 200 I = K, L - C = ZERO - R = ZERO -* - DO 150 J = K, L - IF( J.EQ.I ) - $ GO TO 150 - C = C + CABS1( A( J, I ) ) - R = R + CABS1( A( I, J ) ) - 150 CONTINUE +* + C = DZNRM2( L-K+1, A( K, I ), 1 ) + R = DZNRM2( L-K+1, A( I, K ), LDA ) ICA = IZAMAX( L, A( 1, I ), 1 ) CA = ABS( A( ICA, I ) ) IRA = IZAMAX( N-K+1, A( I, K ), LDA ) diff --git a/lapack-netlib/SRC/zgemqrt.f b/lapack-netlib/SRC/zgemqrt.f index 71db24f27..19d684f73 100644 --- a/lapack-netlib/SRC/zgemqrt.f +++ b/lapack-netlib/SRC/zgemqrt.f @@ -160,7 +160,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex16GEcomputational * @@ -168,10 +168,10 @@ SUBROUTINE ZGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, $ C, LDC, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -225,7 +225,7 @@ INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.Q ) THEN INFO = -5 - ELSE IF( NB.LT.1 .OR. NB.GT.K ) THEN + ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0)) THEN INFO = -6 ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN INFO = -8 diff --git a/lapack-netlib/SRC/zgeqrt.f b/lapack-netlib/SRC/zgeqrt.f index 0decf1143..0603c4fe9 100644 --- a/lapack-netlib/SRC/zgeqrt.f +++ b/lapack-netlib/SRC/zgeqrt.f @@ -108,7 +108,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex16GEcomputational * @@ -141,10 +141,10 @@ * ===================================================================== SUBROUTINE ZGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDT, M, N, NB @@ -173,7 +173,7 @@ INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 - ELSE IF( NB.LT.1 .OR. NB.GT.MIN(M,N) ) THEN + ELSE IF( NB.LT.1 .OR. ( NB.GT.MIN(M,N) .AND. MIN(M,N).GT.0 ) )THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 diff --git a/lapack-netlib/SRC/zgetc2.f b/lapack-netlib/SRC/zgetc2.f index 277ac7ce2..3179612f5 100644 --- a/lapack-netlib/SRC/zgetc2.f +++ b/lapack-netlib/SRC/zgetc2.f @@ -98,7 +98,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup complex16GEauxiliary * @@ -111,10 +111,10 @@ * ===================================================================== SUBROUTINE ZGETC2( N, A, LDA, IPIV, JPIV, INFO ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. INTEGER INFO, LDA, N @@ -203,6 +203,12 @@ INFO = N A( N, N ) = DCMPLX( SMIN, ZERO ) END IF +* +* Set last pivots to N +* + IPIV( N ) = N + JPIV( N ) = N +* RETURN * * End of ZGETC2 diff --git a/lapack-netlib/SRC/zhecon_rook.f b/lapack-netlib/SRC/zhecon_rook.f new file mode 100644 index 000000000..9ae433650 --- /dev/null +++ b/lapack-netlib/SRC/zhecon_rook.f @@ -0,0 +1,253 @@ +*> \brief \b ZHECON_ROOK estimates the reciprocal of the condition number fort HE matrices using factorization obtained with one of the bounded diagonal pivoting methods (max 2 interchanges) +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHECON_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHECON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHECON_ROOK estimates the reciprocal of the condition number of a complex +*> Hermitian matrix A using the factorization A = U*D*U**H or +*> A = L*D*L**H computed by CHETRF_ROOK. +*> +*> An estimate is obtained for norm(inv(A)), and the reciprocal of the +*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**H; +*> = 'L': Lower triangular, form is A = L*D*L**H. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by CHETRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by CHETRF_ROOK. +*> \endverbatim +*> +*> \param[in] ANORM +*> \verbatim +*> ANORM is DOUBLE PRECISION +*> The 1-norm of the original matrix A. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an +*> estimate of the 1-norm of inv(A) computed in this routine. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex16HEcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZHECON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N + DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, KASE + DOUBLE PRECISION AINVNM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZHETRS_ROOK, ZLACN2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( ANORM.LT.ZERO ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHECON_ROOK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + RCOND = ZERO + IF( N.EQ.0 ) THEN + RCOND = ONE + RETURN + ELSE IF( ANORM.LE.ZERO ) THEN + RETURN + END IF +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO 10 I = N, 1, -1 + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) + $ RETURN + 10 CONTINUE + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO 20 I = 1, N + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) + $ RETURN + 20 CONTINUE + END IF +* +* Estimate the 1-norm of the inverse. +* + KASE = 0 + 30 CONTINUE + CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN +* +* Multiply by inv(L*D*L**H) or inv(U*D*U**H). +* + CALL ZHETRS_ROOK( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO ) + GO TO 30 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM.NE.ZERO ) + $ RCOND = ( ONE / AINVNM ) / ANORM +* + RETURN +* +* End of ZHECON_ROOK +* + END diff --git a/lapack-netlib/SRC/zhesv_rook.f b/lapack-netlib/SRC/zhesv_rook.f new file mode 100644 index 000000000..3922b43f9 --- /dev/null +++ b/lapack-netlib/SRC/zhesv_rook.f @@ -0,0 +1,295 @@ +*> \brief \b ZHESV_ROOK computes the solution to a system of linear equations A * X = B for HE matrices using the bounded Bunch-Kaufman ("rook") diagonal pivoting method +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHESV_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHESV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHESV_ROOK computes the solution to a complex system of linear equations +*> A * X = B, +*> where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS +*> matrices. +*> +*> The bounded Bunch-Kaufman ("rook") diagonal pivoting method is used +*> to factor A as +*> A = U * D * U**T, if UPLO = 'U', or +*> A = L * D * L**T, if UPLO = 'L', +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and D is Hermitian and block diagonal with +*> 1-by-1 and 2-by-2 diagonal blocks. +*> +*> ZHETRF_ROOK is called to compute the factorization of a complex +*> Hermition matrix A using the bounded Bunch-Kaufman ("rook") diagonal +*> pivoting method. +*> +*> The factored form of A is then used to solve the system +*> of equations A * X = B by calling ZHETRS_ROOK (uses BLAS 2). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, the block diagonal matrix D and the +*> multipliers used to obtain the factor U or L from the +*> factorization A = U*D*U**H or A = L*D*L**H as computed by +*> ZHETRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> Only the last KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> Only the first KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= 1, and for best performance +*> LWORK >= max(1,N*NB), where NB is the optimal blocksize for +*> ZHETRF_ROOK. +*> for LWORK < N, TRS will be done with Level BLAS 2 +*> for LWORK >= N, TRS will be done with Level BLAS 3 +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, so the solution could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex16HEsolve +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* +* ===================================================================== + SUBROUTINE ZHESV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZHETRF_ROOK, ZHETRS_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + NB = ILAENV( 1, 'ZHETRF_ROOK', UPLO, N, -1, -1, -1 ) + LWKOPT = N*NB + END IF + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHESV_ROOK ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = U*D*U**H or A = L*D*L**H. +* + CALL ZHETRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* +* Solve with TRS ( Use Level BLAS 2) +* + CALL ZHETRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of ZHESV_ROOK +* + END diff --git a/lapack-netlib/SRC/zhetf2.f b/lapack-netlib/SRC/zhetf2.f index 85968c208..612d9c5df 100644 --- a/lapack-netlib/SRC/zhetf2.f +++ b/lapack-netlib/SRC/zhetf2.f @@ -1,25 +1,25 @@ -*> \brief \b ZHETF2 computes the factorization of a complex Hermitian matrix, using the diagonal pivoting method (unblocked algorithm). +*> \brief \b ZHETF2 computes the factorization of a complex Hermitian matrix, using the diagonal pivoting method (unblocked algorithm, calling Level 2 BLAS). * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZHETF2 + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZHETF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHETF2( UPLO, N, A, LDA, IPIV, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, LDA, N @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ) * .. -* +* * *> \par Purpose: * ============= @@ -90,13 +90,22 @@ *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D. -*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were -*> interchanged and D(k,k) is a 1-by-1 diagonal block. -*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and -*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) -*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = -*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were -*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns +*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) +*> is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns +*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1) +*> is a 2-by-2 diagonal block. *> \endverbatim *> *> \param[out] INFO @@ -113,12 +122,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup complex16HEcomputational * @@ -182,10 +191,10 @@ * ===================================================================== SUBROUTINE ZHETF2( UPLO, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER UPLO @@ -273,7 +282,8 @@ ABSAKK = ABS( DBLE( A( K, K ) ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. * IF( K.GT.1 ) THEN IMAX = IZAMAX( K-1, A( 1, K ), 1 ) @@ -284,13 +294,19 @@ * IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN * -* Column K is zero or contains a NaN: set INFO and continue +* Column K is zero or underflow, or contains a NaN: +* set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K KP = K A( K, K ) = DBLE( A( K, K ) ) ELSE +* +* ============================================================ +* +* Test for interchange +* IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * * no interchange, use 1-by-1 pivot block @@ -299,7 +315,8 @@ ELSE * * JMAX is the column-index of the largest off-diagonal -* element in row IMAX, and ROWMAX is its absolute value +* element in row IMAX, and ROWMAX is its absolute value. +* Determine only ROWMAX. * JMAX = IMAX + IZAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA ) ROWMAX = CABS1( A( IMAX, JMAX ) ) @@ -313,6 +330,7 @@ * no interchange, use 1-by-1 pivot block * KP = K +* ELSE IF( ABS( DBLE( A( IMAX, IMAX ) ) ).GE.ALPHA*ROWMAX ) $ THEN * @@ -328,7 +346,10 @@ KP = IMAX KSTEP = 2 END IF +* END IF +* +* ============================================================ * KK = K - KSTEP + 1 IF( KP.NE.KK ) THEN @@ -456,7 +477,8 @@ ABSAKK = ABS( DBLE( A( K, K ) ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. * IF( K.LT.N ) THEN IMAX = K + IZAMAX( N-K, A( K+1, K ), 1 ) @@ -467,13 +489,19 @@ * IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN * -* Column K is zero or contains a NaN: set INFO and continue +* Column K is zero or underflow, or contains a NaN: +* set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K KP = K A( K, K ) = DBLE( A( K, K ) ) ELSE +* +* ============================================================ +* +* Test for interchange +* IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * * no interchange, use 1-by-1 pivot block @@ -482,7 +510,8 @@ ELSE * * JMAX is the column-index of the largest off-diagonal -* element in row IMAX, and ROWMAX is its absolute value +* element in row IMAX, and ROWMAX is its absolute value. +* Determine only ROWMAX. * JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), LDA ) ROWMAX = CABS1( A( IMAX, JMAX ) ) @@ -496,6 +525,7 @@ * no interchange, use 1-by-1 pivot block * KP = K +* ELSE IF( ABS( DBLE( A( IMAX, IMAX ) ) ).GE.ALPHA*ROWMAX ) $ THEN * @@ -511,7 +541,10 @@ KP = IMAX KSTEP = 2 END IF +* END IF +* +* ============================================================ * KK = K + KSTEP - 1 IF( KP.NE.KK ) THEN diff --git a/lapack-netlib/SRC/zhetf2_rook.f b/lapack-netlib/SRC/zhetf2_rook.f new file mode 100644 index 000000000..7d524cdb0 --- /dev/null +++ b/lapack-netlib/SRC/zhetf2_rook.f @@ -0,0 +1,910 @@ +*> \brief \b ZHETF2_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHETF2_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHETF2_ROOK computes the factorization of a complex Hermitian matrix A +*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method: +*> +*> A = U*D*U**H or A = L*D*L**H +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, U**H is the conjugate transpose of U, and D is +*> Hermitian and block diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the unblocked version of the algorithm, calling Level 2 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> Hermitian matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading +*> n-by-n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading n-by-n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, the block diagonal matrix D and the multipliers used +*> to obtain the factor U or L (see below for further details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex16HEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', then A = U*D*U**H, where +*> U = P(n)*U(n)* ... *P(k)U(k)* ..., +*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to +*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I v 0 ) k-s +*> U(k) = ( 0 I 0 ) s +*> ( 0 0 I ) n-k +*> k-s s n-k +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). +*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), +*> and A(k,k), and v overwrites A(1:k-2,k-1:k). +*> +*> If UPLO = 'L', then A = L*D*L**H, where +*> L = P(1)*L(1)* ... *P(k)*L(k)* ..., +*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to +*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I 0 0 ) k-1 +*> L(k) = ( 0 I 0 ) s +*> ( 0 v I ) n-k-s+1 +*> k-1 s n-k-s+1 +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). +*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), +*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> 01-01-96 - Based on modifications by +*> J. Lewis, Boeing Computer Services Company +*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZHETF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* ====================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL DONE, UPPER + INTEGER I, II, IMAX, ITEMP, J, JMAX, K, KK, KP, KSTEP, + $ P + DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D, D11, D22, R1, DTEMP, + $ ROWMAX, TT, SFMIN + COMPLEX*16 D12, D21, T, WK, WKM1, WKP1, Z +* .. +* .. External Functions .. +* + LOGICAL LSAME + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL LSAME, IZAMAX, DLAMCH, DLAPY2 +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZDSCAL, ZHER, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, SQRT +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHETF2_ROOK', -INFO ) + RETURN + END IF +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = DLAMCH( 'S' ) +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**H using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2 +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 70 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( DBLE( A( K, K ) ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = IZAMAX( K-1, A( 1, K ), 1 ) + COLMAX = CABS1( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + A( K, K ) = DBLE( A( K, K ) ) + ELSE +* +* ============================================================ +* +* BEGIN pivot search +* +* Case(1) +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* BEGIN pivot search loop body +* +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + IZAMAX( K-IMAX, A( IMAX, IMAX+1 ), + $ LDA ) + ROWMAX = CABS1( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = IZAMAX( IMAX-1, A( 1, IMAX ), 1 ) + DTEMP = CABS1( A( ITEMP, IMAX ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Case(2) +* Equivalent to testing for +* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABS( DBLE( A( IMAX, IMAX ) ) ) + $ .LT.ALPHA*ROWMAX ) ) THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Case(3) +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K-1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. +* +* Case(4) + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* END pivot search loop body +* + IF( .NOT.DONE ) GOTO 12 +* + END IF +* +* END pivot search +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped +* + KK = K - KSTEP + 1 +* +* For only a 2x2 pivot, interchange rows and columns K and P +* in the leading submatrix A(1:k,1:k) +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* (1) Swap columnar parts + IF( P.GT.1 ) + $ CALL ZSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 ) +* (2) Swap and conjugate middle parts + DO 14 J = P + 1, K - 1 + T = DCONJG( A( J, K ) ) + A( J, K ) = DCONJG( A( P, J ) ) + A( P, J ) = T + 14 CONTINUE +* (3) Swap and conjugate corner elements at row-col interserction + A( P, K ) = DCONJG( A( P, K ) ) +* (4) Swap diagonal elements at row-col intersection + R1 = DBLE( A( K, K ) ) + A( K, K ) = DBLE( A( P, P ) ) + A( P, P ) = R1 + END IF +* +* For both 1x1 and 2x2 pivots, interchange rows and +* columns KK and KP in the leading submatrix A(1:k,1:k) +* + IF( KP.NE.KK ) THEN +* (1) Swap columnar parts + IF( KP.GT.1 ) + $ CALL ZSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) +* (2) Swap and conjugate middle parts + DO 15 J = KP + 1, KK - 1 + T = DCONJG( A( J, KK ) ) + A( J, KK ) = DCONJG( A( KP, J ) ) + A( KP, J ) = T + 15 CONTINUE +* (3) Swap and conjugate corner elements at row-col interserction + A( KP, KK ) = DCONJG( A( KP, KK ) ) +* (4) Swap diagonal elements at row-col intersection + R1 = DBLE( A( KK, KK ) ) + A( KK, KK ) = DBLE( A( KP, KP ) ) + A( KP, KP ) = R1 +* + IF( KSTEP.EQ.2 ) THEN +* (*) Make sure that diagonal element of pivot is real + A( K, K ) = DBLE( A( K, K ) ) +* (5) Swap row elements + T = A( K-1, K ) + A( K-1, K ) = A( KP, K ) + A( KP, K ) = T + END IF + ELSE +* (*) Make sure that diagonal element of pivot is real + A( K, K ) = DBLE( A( K, K ) ) + IF( KSTEP.EQ.2 ) + $ A( K-1, K-1 ) = DBLE( A( K-1, K-1 ) ) + END IF +* +* Update the leading submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* + IF( K.GT.1 ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) and +* store U(k) in column k +* + IF( ABS( DBLE( A( K, K ) ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*1/D(k)*W(k)**T +* + D11 = ONE / DBLE( A( K, K ) ) + CALL ZHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) +* +* Store U(k) in column k +* + CALL ZDSCAL( K-1, D11, A( 1, K ), 1 ) + ELSE +* +* Store L(k) in column K +* + D11 = DBLE( A( K, K ) ) + DO 16 II = 1, K - 1 + A( II, K ) = A( II, K ) / D11 + 16 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL ZHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k-1 now hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* +* Perform a rank-2 update of A(1:k-2,1:k-2) as +* +* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T +* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.GT.2 ) THEN +* D = |A12| + D = DLAPY2( DBLE( A( K-1, K ) ), + $ DIMAG( A( K-1, K ) ) ) + D11 = A( K, K ) / D + D22 = A( K-1, K-1 ) / D + D12 = A( K-1, K ) / D + TT = ONE / ( D11*D22-ONE ) +* + DO 30 J = K - 2, 1, -1 +* +* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* + WKM1 = TT*( D11*A( J, K-1 )-DCONJG( D12 )* + $ A( J, K ) ) + WK = TT*( D22*A( J, K )-D12*A( J, K-1 ) ) +* +* Perform a rank-2 update of A(1:k-2,1:k-2) +* + DO 20 I = J, 1, -1 + A( I, J ) = A( I, J ) - + $ ( A( I, K ) / D )*DCONJG( WK ) - + $ ( A( I, K-1 ) / D )*DCONJG( WKM1 ) + 20 CONTINUE +* +* Store U(k) and U(k-1) in cols k and k-1 for row J +* + A( J, K ) = WK / D + A( J, K-1 ) = WKM1 / D +* (*) Make sure that diagonal element of pivot is real + A( J, J ) = DCMPLX( DBLE( A( J, J ) ), ZERO ) +* + 30 CONTINUE +* + END IF +* + END IF +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + ELSE +* +* Factorize A as L*D*L**H using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2 +* + K = 1 + 40 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 70 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( DBLE( A( K, K ) ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + IZAMAX( N-K, A( K+1, K ), 1 ) + COLMAX = CABS1( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + A( K, K ) = DBLE( A( K, K ) ) + ELSE +* +* ============================================================ +* +* BEGIN pivot search +* +* Case(1) +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 42 CONTINUE +* +* BEGIN pivot search loop body +* +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), LDA ) + ROWMAX = CABS1( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + IZAMAX( N-IMAX, A( IMAX+1, IMAX ), + $ 1 ) + DTEMP = CABS1( A( ITEMP, IMAX ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Case(2) +* Equivalent to testing for +* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABS( DBLE( A( IMAX, IMAX ) ) ) + $ .LT.ALPHA*ROWMAX ) ) THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Case(3) +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. +* +* Case(4) + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* +* END pivot search loop body +* + IF( .NOT.DONE ) GOTO 42 +* + END IF +* +* END pivot search +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped +* + KK = K + KSTEP - 1 +* +* For only a 2x2 pivot, interchange rows and columns K and P +* in the trailing submatrix A(k:n,k:n) +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* (1) Swap columnar parts + IF( P.LT.N ) + $ CALL ZSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) +* (2) Swap and conjugate middle parts + DO 44 J = K + 1, P - 1 + T = DCONJG( A( J, K ) ) + A( J, K ) = DCONJG( A( P, J ) ) + A( P, J ) = T + 44 CONTINUE +* (3) Swap and conjugate corner elements at row-col interserction + A( P, K ) = DCONJG( A( P, K ) ) +* (4) Swap diagonal elements at row-col intersection + R1 = DBLE( A( K, K ) ) + A( K, K ) = DBLE( A( P, P ) ) + A( P, P ) = R1 + END IF +* +* For both 1x1 and 2x2 pivots, interchange rows and +* columns KK and KP in the trailing submatrix A(k:n,k:n) +* + IF( KP.NE.KK ) THEN +* (1) Swap columnar parts + IF( KP.LT.N ) + $ CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) +* (2) Swap and conjugate middle parts + DO 45 J = KK + 1, KP - 1 + T = DCONJG( A( J, KK ) ) + A( J, KK ) = DCONJG( A( KP, J ) ) + A( KP, J ) = T + 45 CONTINUE +* (3) Swap and conjugate corner elements at row-col interserction + A( KP, KK ) = DCONJG( A( KP, KK ) ) +* (4) Swap diagonal elements at row-col intersection + R1 = DBLE( A( KK, KK ) ) + A( KK, KK ) = DBLE( A( KP, KP ) ) + A( KP, KP ) = R1 +* + IF( KSTEP.EQ.2 ) THEN +* (*) Make sure that diagonal element of pivot is real + A( K, K ) = DBLE( A( K, K ) ) +* (5) Swap row elements + T = A( K+1, K ) + A( K+1, K ) = A( KP, K ) + A( KP, K ) = T + END IF + ELSE +* (*) Make sure that diagonal element of pivot is real + A( K, K ) = DBLE( A( K, K ) ) + IF( KSTEP.EQ.2 ) + $ A( K+1, K+1 ) = DBLE( A( K+1, K+1 ) ) + END IF +* +* Update the trailing submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k of A now holds +* +* W(k) = L(k)*D(k), +* +* where L(k) is the k-th column of L +* + IF( K.LT.N ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) and +* store L(k) in column k +* +* Handle division by a small number +* + IF( ABS( DBLE( A( K, K ) ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* + D11 = ONE / DBLE( A( K, K ) ) + CALL ZHER( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) +* +* Store L(k) in column k +* + CALL ZDSCAL( N-K, D11, A( K+1, K ), 1 ) + ELSE +* +* Store L(k) in column k +* + D11 = DBLE( A( K, K ) ) + DO 46 II = K + 1, N + A( II, K ) = A( II, K ) / D11 + 46 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL ZHER( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* +* +* Perform a rank-2 update of A(k+2:n,k+2:n) as +* +* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T +* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.LT.N-1 ) THEN +* D = |A21| + D = DLAPY2( DBLE( A( K+1, K ) ), + $ DIMAG( A( K+1, K ) ) ) + D11 = DBLE( A( K+1, K+1 ) ) / D + D22 = DBLE( A( K, K ) ) / D + D21 = A( K+1, K ) / D + TT = ONE / ( D11*D22-ONE ) +* + DO 60 J = K + 2, N +* +* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* + WK = TT*( D11*A( J, K )-D21*A( J, K+1 ) ) + WKP1 = TT*( D22*A( J, K+1 )-DCONJG( D21 )* + $ A( J, K ) ) +* +* Perform a rank-2 update of A(k+2:n,k+2:n) +* + DO 50 I = J, N + A( I, J ) = A( I, J ) - + $ ( A( I, K ) / D )*DCONJG( WK ) - + $ ( A( I, K+1 ) / D )*DCONJG( WKP1 ) + 50 CONTINUE +* +* Store L(k) and L(k+1) in cols k and k+1 for row J +* + A( J, K ) = WK / D + A( J, K+1 ) = WKP1 / D +* (*) Make sure that diagonal element of pivot is real + A( J, J ) = DCMPLX( DBLE( A( J, J ) ), ZERO ) +* + 60 CONTINUE +* + END IF +* + END IF +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 40 +* + END IF +* + 70 CONTINUE +* + RETURN +* +* End of ZHETF2_ROOK +* + END diff --git a/lapack-netlib/SRC/zhetrf_rook.f b/lapack-netlib/SRC/zhetrf_rook.f new file mode 100644 index 000000000..64e59aab5 --- /dev/null +++ b/lapack-netlib/SRC/zhetrf_rook.f @@ -0,0 +1,397 @@ +*> \brief \b ZHETRF_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (blocked algorithm, calling Level 3 BLAS). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHETRF_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHETRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHETRF_ROOK computes the factorization of a complex Hermitian matrix A +*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. +*> The form of the factorization is +*> +*> A = U*D*U**T or A = L*D*L**T +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and D is Hermitian and block diagonal with +*> 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, the block diagonal matrix D and the multipliers used +*> to obtain the factor U or L (see below for further details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> Only the last KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> Only the first KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)). +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >=1. For best performance +*> LWORK >= N*NB, where NB is the block size returned by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex16HEcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', then A = U*D*U**T, where +*> U = P(n)*U(n)* ... *P(k)U(k)* ..., +*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to +*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I v 0 ) k-s +*> U(k) = ( 0 I 0 ) s +*> ( 0 0 I ) n-k +*> k-s s n-k +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). +*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), +*> and A(k,k), and v overwrites A(1:k-2,k-1:k). +*> +*> If UPLO = 'L', then A = L*D*L**T, where +*> L = P(1)*L(1)* ... *P(k)*L(k)* ..., +*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to +*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I 0 0 ) k-1 +*> L(k) = ( 0 I 0 ) s +*> ( 0 v I ) n-k-s+1 +*> k-1 s n-k-s+1 +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). +*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), +*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZHETRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL ZLAHEF_ROOK, ZHETF2_ROOK, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size +* + NB = ILAENV( 1, 'ZHETRF_ROOK', UPLO, N, -1, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHETRF_ROOK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* + NBMIN = 2 + LDWORK = N + IF( NB.GT.1 .AND. NB.LT.N ) THEN + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN + NB = MAX( LWORK / LDWORK, 1 ) + NBMIN = MAX( 2, ILAENV( 2, 'ZHETRF_ROOK', + $ UPLO, N, -1, -1, -1 ) ) + END IF + ELSE + IWS = 1 + END IF + IF( NB.LT.NBMIN ) + $ NB = N +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* KB, where KB is the number of columns factorized by ZLAHEF_ROOK; +* KB is either NB or NB-1, or K for the last block +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 40 +* + IF( K.GT.NB ) THEN +* +* Factorize columns k-kb+1:k of A and use blocked code to +* update columns 1:k-kb +* + CALL ZLAHEF_ROOK( UPLO, K, NB, KB, A, LDA, + $ IPIV, WORK, LDWORK, IINFO ) + ELSE +* +* Use unblocked code to factorize columns 1:k of A +* + CALL ZHETF2_ROOK( UPLO, K, A, LDA, IPIV, IINFO ) + KB = K + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO +* +* No need to adjust IPIV +* +* Decrease K and return to the start of the main loop +* + K = K - KB + GO TO 10 +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* KB, where KB is the number of columns factorized by ZLAHEF_ROOK; +* KB is either NB or NB-1, or N-K+1 for the last block +* + K = 1 + 20 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 40 +* + IF( K.LE.N-NB ) THEN +* +* Factorize columns k:k+kb-1 of A and use blocked code to +* update columns k+kb:n +* + CALL ZLAHEF_ROOK( UPLO, N-K+1, NB, KB, A( K, K ), LDA, + $ IPIV( K ), WORK, LDWORK, IINFO ) + ELSE +* +* Use unblocked code to factorize columns k:n of A +* + CALL ZHETF2_ROOK( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), + $ IINFO ) + KB = N - K + 1 + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + K - 1 +* +* Adjust IPIV +* + DO 30 J = K, K + KB - 1 + IF( IPIV( J ).GT.0 ) THEN + IPIV( J ) = IPIV( J ) + K - 1 + ELSE + IPIV( J ) = IPIV( J ) - K + 1 + END IF + 30 CONTINUE +* +* Increase K and return to the start of the main loop +* + K = K + KB + GO TO 20 +* + END IF +* + 40 CONTINUE + WORK( 1 ) = LWKOPT + RETURN +* +* End of ZHETRF_ROOK +* + END diff --git a/lapack-netlib/SRC/zhetri_rook.f b/lapack-netlib/SRC/zhetri_rook.f new file mode 100644 index 000000000..68b88acbd --- /dev/null +++ b/lapack-netlib/SRC/zhetri_rook.f @@ -0,0 +1,516 @@ +*> \brief \b ZHETRI_ROOK computes the inverse of HE matrix using the factorization obtained with the bounded Bunch-Kaufman ("rook") diagonal pivoting method. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHETRI_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHETRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHETRI_ROOK computes the inverse of a complex Hermitian indefinite matrix +*> A using the factorization A = U*D*U**H or A = L*D*L**H computed by +*> ZHETRF_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**H; +*> = 'L': Lower triangular, form is A = L*D*L**H. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the block diagonal matrix D and the multipliers +*> used to obtain the factor U or L as computed by ZHETRF_ROOK. +*> +*> On exit, if INFO = 0, the (Hermitian) inverse of the original +*> matrix. If UPLO = 'U', the upper triangular part of the +*> inverse is formed and the part of A below the diagonal is not +*> referenced; if UPLO = 'L' the lower triangular part of the +*> inverse is formed and the part of A above the diagonal is +*> not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by ZHETRF_ROOK. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex16HEcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZHETRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + COMPLEX*16 CONE, CZERO + PARAMETER ( ONE = 1.0D+0, CONE = ( 1.0D+0, 0.0D+0 ), + $ CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J, K, KP, KSTEP + DOUBLE PRECISION AK, AKP1, D, T + COMPLEX*16 AKKP1, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME + COMPLEX*16 ZDOTC + EXTERNAL LSAME, ZDOTC +* .. +* .. External Subroutines .. + EXTERNAL ZCOPY, ZHEMV, ZSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DCONJG, MAX, DBLE +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHETRI_ROOK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO 10 INFO = N, 1, -1 + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO ) + $ RETURN + 10 CONTINUE + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO 20 INFO = 1, N + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO ) + $ RETURN + 20 CONTINUE + END IF + INFO = 0 +* + IF( UPPER ) THEN +* +* Compute inv(A) from the factorization A = U*D*U**H. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + 30 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 70 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Invert the diagonal block. +* + A( K, K ) = ONE / DBLE( A( K, K ) ) +* +* Compute column K of the inverse. +* + IF( K.GT.1 ) THEN + CALL ZCOPY( K-1, A( 1, K ), 1, WORK, 1 ) + CALL ZHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO, + $ A( 1, K ), 1 ) + A( K, K ) = A( K, K ) - DBLE( ZDOTC( K-1, WORK, 1, A( 1, + $ K ), 1 ) ) + END IF + KSTEP = 1 + ELSE +* +* 2 x 2 diagonal block +* +* Invert the diagonal block. +* + T = ABS( A( K, K+1 ) ) + AK = DBLE( A( K, K ) ) / T + AKP1 = DBLE( A( K+1, K+1 ) ) / T + AKKP1 = A( K, K+1 ) / T + D = T*( AK*AKP1-ONE ) + A( K, K ) = AKP1 / D + A( K+1, K+1 ) = AK / D + A( K, K+1 ) = -AKKP1 / D +* +* Compute columns K and K+1 of the inverse. +* + IF( K.GT.1 ) THEN + CALL ZCOPY( K-1, A( 1, K ), 1, WORK, 1 ) + CALL ZHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO, + $ A( 1, K ), 1 ) + A( K, K ) = A( K, K ) - DBLE( ZDOTC( K-1, WORK, 1, A( 1, + $ K ), 1 ) ) + A( K, K+1 ) = A( K, K+1 ) - + $ ZDOTC( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 ) + CALL ZCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 ) + CALL ZHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO, + $ A( 1, K+1 ), 1 ) + A( K+1, K+1 ) = A( K+1, K+1 ) - + $ DBLE( ZDOTC( K-1, WORK, 1, A( 1, K+1 ), + $ 1 ) ) + END IF + KSTEP = 2 + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* Interchange rows and columns K and IPIV(K) in the leading +* submatrix A(1:k,1:k) +* + KP = IPIV( K ) + IF( KP.NE.K ) THEN +* + IF( KP.GT.1 ) + $ CALL ZSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) +* + DO 40 J = KP + 1, K - 1 + TEMP = DCONJG( A( J, K ) ) + A( J, K ) = DCONJG( A( KP, J ) ) + A( KP, J ) = TEMP + 40 CONTINUE +* + A( KP, K ) = DCONJG( A( KP, K ) ) +* + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + ELSE +* +* Interchange rows and columns K and K+1 with -IPIV(K) and +* -IPIV(K+1) in the leading submatrix A(k+1:n,k+1:n) +* +* (1) Interchange rows and columns K and -IPIV(K) +* + KP = -IPIV( K ) + IF( KP.NE.K ) THEN +* + IF( KP.GT.1 ) + $ CALL ZSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) +* + DO 50 J = KP + 1, K - 1 + TEMP = DCONJG( A( J, K ) ) + A( J, K ) = DCONJG( A( KP, J ) ) + A( KP, J ) = TEMP + 50 CONTINUE +* + A( KP, K ) = DCONJG( A( KP, K ) ) +* + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP +* + TEMP = A( K, K+1 ) + A( K, K+1 ) = A( KP, K+1 ) + A( KP, K+1 ) = TEMP + END IF +* +* (2) Interchange rows and columns K+1 and -IPIV(K+1) +* + K = K + 1 + KP = -IPIV( K ) + IF( KP.NE.K ) THEN +* + IF( KP.GT.1 ) + $ CALL ZSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) +* + DO 60 J = KP + 1, K - 1 + TEMP = DCONJG( A( J, K ) ) + A( J, K ) = DCONJG( A( KP, J ) ) + A( KP, J ) = TEMP + 60 CONTINUE +* + A( KP, K ) = DCONJG( A( KP, K ) ) +* + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + END IF +* + K = K + 1 + GO TO 30 + 70 CONTINUE +* + ELSE +* +* Compute inv(A) from the factorization A = L*D*L**H. +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = N + 80 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 120 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Invert the diagonal block. +* + A( K, K ) = ONE / DBLE( A( K, K ) ) +* +* Compute column K of the inverse. +* + IF( K.LT.N ) THEN + CALL ZCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) + CALL ZHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA, WORK, + $ 1, CZERO, A( K+1, K ), 1 ) + A( K, K ) = A( K, K ) - DBLE( ZDOTC( N-K, WORK, 1, + $ A( K+1, K ), 1 ) ) + END IF + KSTEP = 1 + ELSE +* +* 2 x 2 diagonal block +* +* Invert the diagonal block. +* + T = ABS( A( K, K-1 ) ) + AK = DBLE( A( K-1, K-1 ) ) / T + AKP1 = DBLE( A( K, K ) ) / T + AKKP1 = A( K, K-1 ) / T + D = T*( AK*AKP1-ONE ) + A( K-1, K-1 ) = AKP1 / D + A( K, K ) = AK / D + A( K, K-1 ) = -AKKP1 / D +* +* Compute columns K-1 and K of the inverse. +* + IF( K.LT.N ) THEN + CALL ZCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) + CALL ZHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA, WORK, + $ 1, CZERO, A( K+1, K ), 1 ) + A( K, K ) = A( K, K ) - DBLE( ZDOTC( N-K, WORK, 1, + $ A( K+1, K ), 1 ) ) + A( K, K-1 ) = A( K, K-1 ) - + $ ZDOTC( N-K, A( K+1, K ), 1, A( K+1, K-1 ), + $ 1 ) + CALL ZCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 ) + CALL ZHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA, WORK, + $ 1, CZERO, A( K+1, K-1 ), 1 ) + A( K-1, K-1 ) = A( K-1, K-1 ) - + $ DBLE( ZDOTC( N-K, WORK, 1, A( K+1, K-1 ), + $ 1 ) ) + END IF + KSTEP = 2 + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* Interchange rows and columns K and IPIV(K) in the trailing +* submatrix A(k:n,k:n) +* + KP = IPIV( K ) + IF( KP.NE.K ) THEN +* + IF( KP.LT.N ) + $ CALL ZSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) +* + DO 90 J = K + 1, KP - 1 + TEMP = DCONJG( A( J, K ) ) + A( J, K ) = DCONJG( A( KP, J ) ) + A( KP, J ) = TEMP + 90 CONTINUE +* + A( KP, K ) = DCONJG( A( KP, K ) ) +* + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + ELSE +* +* Interchange rows and columns K and K-1 with -IPIV(K) and +* -IPIV(K-1) in the trailing submatrix A(k-1:n,k-1:n) +* +* (1) Interchange rows and columns K and -IPIV(K) +* + KP = -IPIV( K ) + IF( KP.NE.K ) THEN +* + IF( KP.LT.N ) + $ CALL ZSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) +* + DO 100 J = K + 1, KP - 1 + TEMP = DCONJG( A( J, K ) ) + A( J, K ) = DCONJG( A( KP, J ) ) + A( KP, J ) = TEMP + 100 CONTINUE +* + A( KP, K ) = DCONJG( A( KP, K ) ) +* + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP +* + TEMP = A( K, K-1 ) + A( K, K-1 ) = A( KP, K-1 ) + A( KP, K-1 ) = TEMP + END IF +* +* (2) Interchange rows and columns K-1 and -IPIV(K-1) +* + K = K - 1 + KP = -IPIV( K ) + IF( KP.NE.K ) THEN +* + IF( KP.LT.N ) + $ CALL ZSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) +* + DO 110 J = K + 1, KP - 1 + TEMP = DCONJG( A( J, K ) ) + A( J, K ) = DCONJG( A( KP, J ) ) + A( KP, J ) = TEMP + 110 CONTINUE +* + A( KP, K ) = DCONJG( A( KP, K ) ) +* + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + END IF +* + K = K - 1 + GO TO 80 + 120 CONTINUE + END IF +* + RETURN +* +* End of ZHETRI_ROOK +* + END diff --git a/lapack-netlib/SRC/zhetrs_rook.f b/lapack-netlib/SRC/zhetrs_rook.f new file mode 100644 index 000000000..f99697ca5 --- /dev/null +++ b/lapack-netlib/SRC/zhetrs_rook.f @@ -0,0 +1,503 @@ +*> \brief \b ZHETRS_ROOK computes the solution to a system of linear equations A * X = B for HE matrices using factorization obtained with one of the bounded diagonal pivoting methods (max 2 interchanges) +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHETRS_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHETRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHETRS_ROOK solves a system of linear equations A*X = B with a complex +*> Hermitian matrix A using the factorization A = U*D*U**H or +*> A = L*D*L**H computed by ZHETRF_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**H; +*> = 'L': Lower triangular, form is A = L*D*L**H. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by ZHETRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by ZHETRF_ROOK. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex16HEcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZHETRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + $ INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J, K, KP + DOUBLE PRECISION S + COMPLEX*16 AK, AKM1, AKM1K, BK, BKM1, DENOM +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZGEMV, ZGERU, ZLACGV, ZDSCAL, ZSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX, DBLE +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHETRS_ROOK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Solve A*X = B, where A = U*D*U**H. +* +* First solve U*D*X = B, overwriting B with X. +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 30 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(U(K)), where U(K) is the transformation +* stored in column K of A. +* + CALL ZGERU( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, + $ B( 1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + S = DBLE( ONE ) / DBLE( A( K, K ) ) + CALL ZDSCAL( NRHS, S, B( K, 1 ), LDB ) + K = K - 1 + ELSE +* +* 2 x 2 diagonal block +* +* Interchange rows K and -IPIV(K), then K-1 and -IPIV(K-1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K-1) + IF( KP.NE.K-1 ) + $ CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(U(K)), where U(K) is the transformation +* stored in columns K-1 and K of A. +* + CALL ZGERU( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, + $ B( 1, 1 ), LDB ) + CALL ZGERU( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ), + $ LDB, B( 1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + AKM1K = A( K-1, K ) + AKM1 = A( K-1, K-1 ) / AKM1K + AK = A( K, K ) / DCONJG( AKM1K ) + DENOM = AKM1*AK - ONE + DO 20 J = 1, NRHS + BKM1 = B( K-1, J ) / AKM1K + BK = B( K, J ) / DCONJG( AKM1K ) + B( K-1, J ) = ( AK*BKM1-BK ) / DENOM + B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM + 20 CONTINUE + K = K - 2 + END IF +* + GO TO 10 + 30 CONTINUE +* +* Next solve U**H *X = B, overwriting B with X. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + 40 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 50 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Multiply by inv(U**H(K)), where U(K) is the transformation +* stored in column K of A. +* + IF( K.GT.1 ) THEN + CALL ZLACGV( NRHS, B( K, 1 ), LDB ) + CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B, + $ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB ) + CALL ZLACGV( NRHS, B( K, 1 ), LDB ) + END IF +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K + 1 + ELSE +* +* 2 x 2 diagonal block +* +* Multiply by inv(U**H(K+1)), where U(K+1) is the transformation +* stored in columns K and K+1 of A. +* + IF( K.GT.1 ) THEN + CALL ZLACGV( NRHS, B( K, 1 ), LDB ) + CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B, + $ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB ) + CALL ZLACGV( NRHS, B( K, 1 ), LDB ) +* + CALL ZLACGV( NRHS, B( K+1, 1 ), LDB ) + CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B, + $ LDB, A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB ) + CALL ZLACGV( NRHS, B( K+1, 1 ), LDB ) + END IF +* +* Interchange rows K and -IPIV(K), then K+1 and -IPIV(K+1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K+1 ) + IF( KP.NE.K+1 ) + $ CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) +* + K = K + 2 + END IF +* + GO TO 40 + 50 CONTINUE +* + ELSE +* +* Solve A*X = B, where A = L*D*L**H. +* +* First solve L*D*X = B, overwriting B with X. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + 60 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 80 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(L(K)), where L(K) is the transformation +* stored in column K of A. +* + IF( K.LT.N ) + $ CALL ZGERU( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ), + $ LDB, B( K+1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + S = DBLE( ONE ) / DBLE( A( K, K ) ) + CALL ZDSCAL( NRHS, S, B( K, 1 ), LDB ) + K = K + 1 + ELSE +* +* 2 x 2 diagonal block +* +* Interchange rows K and -IPIV(K), then K+1 and -IPIV(K+1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K+1 ) + IF( KP.NE.K+1 ) + $ CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(L(K)), where L(K) is the transformation +* stored in columns K and K+1 of A. +* + IF( K.LT.N-1 ) THEN + CALL ZGERU( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ), + $ LDB, B( K+2, 1 ), LDB ) + CALL ZGERU( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1, + $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) + END IF +* +* Multiply by the inverse of the diagonal block. +* + AKM1K = A( K+1, K ) + AKM1 = A( K, K ) / DCONJG( AKM1K ) + AK = A( K+1, K+1 ) / AKM1K + DENOM = AKM1*AK - ONE + DO 70 J = 1, NRHS + BKM1 = B( K, J ) / DCONJG( AKM1K ) + BK = B( K+1, J ) / AKM1K + B( K, J ) = ( AK*BKM1-BK ) / DENOM + B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM + 70 CONTINUE + K = K + 2 + END IF +* + GO TO 60 + 80 CONTINUE +* +* Next solve L**H *X = B, overwriting B with X. +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = N + 90 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 100 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Multiply by inv(L**H(K)), where L(K) is the transformation +* stored in column K of A. +* + IF( K.LT.N ) THEN + CALL ZLACGV( NRHS, B( K, 1 ), LDB ) + CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE, + $ B( K+1, 1 ), LDB, A( K+1, K ), 1, ONE, + $ B( K, 1 ), LDB ) + CALL ZLACGV( NRHS, B( K, 1 ), LDB ) + END IF +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K - 1 + ELSE +* +* 2 x 2 diagonal block +* +* Multiply by inv(L**H(K-1)), where L(K-1) is the transformation +* stored in columns K-1 and K of A. +* + IF( K.LT.N ) THEN + CALL ZLACGV( NRHS, B( K, 1 ), LDB ) + CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE, + $ B( K+1, 1 ), LDB, A( K+1, K ), 1, ONE, + $ B( K, 1 ), LDB ) + CALL ZLACGV( NRHS, B( K, 1 ), LDB ) +* + CALL ZLACGV( NRHS, B( K-1, 1 ), LDB ) + CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE, + $ B( K+1, 1 ), LDB, A( K+1, K-1 ), 1, ONE, + $ B( K-1, 1 ), LDB ) + CALL ZLACGV( NRHS, B( K-1, 1 ), LDB ) + END IF +* +* Interchange rows K and -IPIV(K), then K-1 and -IPIV(K-1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K-1 ) + IF( KP.NE.K-1 ) + $ CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) +* + K = K - 2 + END IF +* + GO TO 90 + 100 CONTINUE + END IF +* + RETURN +* +* End of ZHETRS_ROOK +* + END diff --git a/lapack-netlib/SRC/zhsein.f b/lapack-netlib/SRC/zhsein.f index 6c7173f1c..57c99dbea 100644 --- a/lapack-netlib/SRC/zhsein.f +++ b/lapack-netlib/SRC/zhsein.f @@ -104,6 +104,7 @@ *> \verbatim *> H is COMPLEX*16 array, dimension (LDH,N) *> The upper Hessenberg matrix H. +*> If a NaN is detected in H, the routine will return with INFO=-6. *> \endverbatim *> *> \param[in] LDH @@ -225,7 +226,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex16OTHERcomputational * @@ -244,10 +245,10 @@ $ LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL, $ IFAILR, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER EIGSRC, INITV, SIDE @@ -276,9 +277,9 @@ COMPLEX*16 CDUM, WK * .. * .. External Functions .. - LOGICAL LSAME + LOGICAL LSAME, DISNAN DOUBLE PRECISION DLAMCH, ZLANHS - EXTERNAL LSAME, DLAMCH, ZLANHS + EXTERNAL LSAME, DLAMCH, ZLANHS, DISNAN * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLAEIN @@ -399,7 +400,10 @@ * has not ben computed before. * HNORM = ZLANHS( 'I', KR-KL+1, H( KL, KL ), LDH, RWORK ) - IF( HNORM.GT.RZERO ) THEN + IF( DISNAN( HNORM ) ) THEN + INFO = -6 + RETURN + ELSE IF( HNORM.GT.RZERO ) THEN EPS3 = HNORM*ULP ELSE EPS3 = SMLNUM diff --git a/lapack-netlib/SRC/zhseqr.f b/lapack-netlib/SRC/zhseqr.f index e9fe20401..994843688 100644 --- a/lapack-netlib/SRC/zhseqr.f +++ b/lapack-netlib/SRC/zhseqr.f @@ -43,7 +43,7 @@ *> Optionally Z may be postmultiplied into an input unitary *> matrix Q so that this routine can give the Schur factorization *> of a matrix A which has been reduced to the Hessenberg form H -*> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. +*> by the unitary matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H. *> \endverbatim * * Arguments: @@ -216,7 +216,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex16OTHERcomputational * @@ -299,10 +299,10 @@ SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, $ WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N diff --git a/lapack-netlib/SRC/zlahef.f b/lapack-netlib/SRC/zlahef.f index 71daaf8e8..36b9b73ce 100644 --- a/lapack-netlib/SRC/zlahef.f +++ b/lapack-netlib/SRC/zlahef.f @@ -1,4 +1,4 @@ -*> \brief \b ZLAHEF computes a partial factorization of a complex Hermitian indefinite matrix, using the diagonal pivoting method. +*> \brief \b ZLAHEF computes a partial factorization of a complex Hermitian indefinite matrix using the Bunch-Kaufman diagonal pivoting method (blocked algorithm, calling Level 3 BLAS). * * =========== DOCUMENTATION =========== * @@ -110,16 +110,26 @@ *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D. -*> If UPLO = 'U', only the last KB elements of IPIV are set; -*> if UPLO = 'L', only the first KB elements are set. *> -*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were -*> interchanged and D(k,k) is a 1-by-1 diagonal block. -*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and -*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) -*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = -*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were -*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> If UPLO = 'U': +*> Only the last KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns +*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) +*> is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> Only the first KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns +*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1) +*> is a 2-by-2 diagonal block. *> \endverbatim *> *> \param[out] W @@ -150,17 +160,27 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup complex16HEcomputational * +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> \endverbatim +* * ===================================================================== SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER UPLO @@ -230,6 +250,8 @@ * IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) $ GO TO 30 +* + KSTEP = 1 * * Copy column K of A to column KW of W and update it * @@ -240,8 +262,6 @@ $ W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 ) W( K, KW ) = DBLE( W( K, KW ) ) END IF -* - KSTEP = 1 * * Determine rows and columns to be interchanged and whether * a 1-by-1 or 2-by-2 pivot block will be used @@ -249,7 +269,8 @@ ABSAKK = ABS( DBLE( W( K, KW ) ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. * IF( K.GT.1 ) THEN IMAX = IZAMAX( K-1, W( 1, KW ), 1 ) @@ -260,13 +281,19 @@ * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * -* Column K is zero: set INFO and continue +* Column K is zero or underflow: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K KP = K A( K, K ) = DBLE( A( K, K ) ) ELSE +* +* ============================================================ +* +* BEGIN pivot search +* +* Case(1) IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * * no interchange, use 1-by-1 pivot block @@ -274,6 +301,9 @@ KP = K ELSE * +* BEGIN pivot search along IMAX row +* +* * Copy column IMAX to column KW-1 of W and update it * CALL ZCOPY( IMAX-1, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 ) @@ -289,7 +319,8 @@ END IF * * JMAX is the column-index of the largest off-diagonal -* element in row IMAX, and ROWMAX is its absolute value +* element in row IMAX, and ROWMAX is its absolute value. +* Determine only ROWMAX. * JMAX = IMAX + IZAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 ) ROWMAX = CABS1( W( JMAX, KW-1 ) ) @@ -298,11 +329,14 @@ ROWMAX = MAX( ROWMAX, CABS1( W( JMAX, KW-1 ) ) ) END IF * +* Case(2) IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN * * no interchange, use 1-by-1 pivot block * KP = K +* +* Case(3) ELSE IF( ABS( DBLE( W( IMAX, KW-1 ) ) ).GE.ALPHA*ROWMAX ) $ THEN * @@ -311,9 +345,11 @@ * KP = IMAX * -* copy column KW-1 of W to column KW +* copy column KW-1 of W to column KW of W * CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* +* Case(4) ELSE * * interchange rows and columns K-1 and IMAX, use 2-by-2 @@ -322,27 +358,48 @@ KP = IMAX KSTEP = 2 END IF +* +* +* END pivot search along IMAX row +* END IF +* +* END pivot search +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped * KK = K - KSTEP + 1 +* +* KKW is the column of W which corresponds to column KK of A +* KKW = NB + KK - N * -* Updated column KP is already stored in column KKW of W +* Interchange rows and columns KP and KK. +* Updated column KP is already stored in column KKW of W. * IF( KP.NE.KK ) THEN * -* Copy non-updated column KK to column KP +* Copy non-updated column KK to column KP of submatrix A +* at step K. No need to copy element into column K +* (or K and K-1 for 2-by-2 pivot) of A, since these columns +* will be later overwritten. * A( KP, KP ) = DBLE( A( KK, KK ) ) CALL ZCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), $ LDA ) CALL ZLACGV( KK-1-KP, A( KP, KP+1 ), LDA ) - CALL ZCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) + IF( KP.GT.1 ) + $ CALL ZCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) * -* Interchange rows KK and KP in last KK columns of A and W +* Interchange rows KK and KP in last K+1 to N columns of A +* (columns K (or K and K-1 for 2-by-2 pivot) of A will be +* later overwritten). Interchange rows KK and KP +* in last KKW to NB columns of W. * - IF( KK.LT.N ) - $ CALL ZSWAP( N-KK, A( KK, KK+1 ), LDA, A( KP, KK+1 ), + IF( K.LT.N ) + $ CALL ZSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ), $ LDA ) CALL ZSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), $ LDW ) @@ -350,40 +407,108 @@ * IF( KSTEP.EQ.1 ) THEN * -* 1-by-1 pivot block D(k): column KW of W now holds +* 1-by-1 pivot block D(k): column kw of W now holds * -* W(k) = U(k)*D(k) +* W(kw) = U(k)*D(k), * * where U(k) is the k-th column of U * -* Store U(k) in column k of A +* (1) Store subdiag. elements of column U(k) +* and 1-by-1 block D(k) in column k of A. +* (NOTE: Diagonal element U(k,k) is a UNIT element +* and not stored) +* A(k,k) := D(k,k) = W(k,kw) +* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k) * +* (NOTE: No need to use for Hermitian matrix +* A( K, K ) = DBLE( W( K, K) ) to separately copy diagonal +* element D(k,k) from W (potentially saves only one load)) CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) - R1 = ONE / DBLE( A( K, K ) ) - CALL ZDSCAL( K-1, R1, A( 1, K ), 1 ) + IF( K.GT.1 ) THEN * -* Conjugate W(k) +* (NOTE: No need to check if A(k,k) is NOT ZERO, +* since that was ensured earlier in pivot search: +* case A(k,k) = 0 falls into 2x2 pivot case(4)) +* + R1 = ONE / DBLE( A( K, K ) ) + CALL ZDSCAL( K-1, R1, A( 1, K ), 1 ) +* +* (2) Conjugate column W(kw) +* + CALL ZLACGV( K-1, W( 1, KW ), 1 ) + END IF * - CALL ZLACGV( K-1, W( 1, KW ), 1 ) ELSE * -* 2-by-2 pivot block D(k): columns KW and KW-1 of W now -* hold +* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold * -* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k) * * where U(k) and U(k-1) are the k-th and (k-1)-th columns * of U +* +* (1) Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2 +* block D(k-1:k,k-1:k) in columns k-1 and k of A. +* (NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT +* block and not stored) +* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw) +* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) = +* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) ) * IF( K.GT.2 ) THEN * -* Store U(k) and U(k-1) in columns k and k-1 of A +* Factor out the columns of the inverse of 2-by-2 pivot +* block D, so that each column contains 1, to reduce the +* number of FLOPS when we multiply panel +* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1). +* +* D**(-1) = ( d11 cj(d21) )**(-1) = +* ( d21 d22 ) +* +* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) = +* ( (-d21) ( d11 ) ) +* +* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) * +* +* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) = +* ( ( -1 ) ( d11/conj(d21) ) ) +* +* = 1/(|d21|**2) * 1/(D22*D11-1) * +* +* * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = ( conj(D21)*( D11 ) D21*( -1 ) ) +* ( ( -1 ) ( D22 ) ), +* +* where D11 = d22/d21, +* D22 = d11/conj(d21), +* D21 = T/d21, +* T = 1/(D22*D11-1). +* +* (NOTE: No need to check for division by ZERO, +* since that was ensured earlier in pivot search: +* (a) d21 != 0, since in 2x2 pivot case(4) +* |d21| should be larger than |d11| and |d22|; +* (b) (D22*D11 - 1) != 0, since from (a), +* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.) * D21 = W( K-1, KW ) D11 = W( K, KW ) / DCONJG( D21 ) D22 = W( K-1, KW-1 ) / D21 T = ONE / ( DBLE( D11*D22 )-ONE ) D21 = T / D21 +* +* Update elements in columns A(k-1) and A(k) as +* dot products of rows of ( W(kw-1) W(kw) ) and columns +* of D**(-1) +* DO 20 J = 1, K - 2 A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) A( J, K ) = DCONJG( D21 )* @@ -397,11 +522,13 @@ A( K-1, K ) = W( K-1, KW ) A( K, K ) = W( K, KW ) * -* Conjugate W(k) and W(k-1) +* (2) Conjugate columns W(kw) and W(kw-1) * CALL ZLACGV( K-1, W( 1, KW ), 1 ) CALL ZLACGV( K-2, W( 1, KW-1 ), 1 ) +* END IF +* END IF * * Store details of the interchanges in IPIV @@ -448,20 +575,28 @@ 50 CONTINUE * * Put U12 in standard form by partially undoing the interchanges -* in columns k+1:n +* in columns k+1:n looping backwards from k+1 to n * J = K + 1 60 CONTINUE - JJ = J - JP = IPIV( J ) - IF( JP.LT.0 ) THEN - JP = -JP +* +* Undo the interchanges (if any) of rows JJ and JP at each +* step J +* +* (Here, J is a diagonal index) + JJ = J + JP = IPIV( J ) + IF( JP.LT.0 ) THEN + JP = -JP +* (Here, J is a diagonal index) + J = J + 1 + END IF +* (NOTE: Here, J is used to determine row length. Length N-J+1 +* of the rows to swap back doesn't include diagonal element) J = J + 1 - END IF - J = J + 1 - IF( JP.NE.JJ .AND. J.LE.N ) - $ CALL ZSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA ) - IF( J.LE.N ) + IF( JP.NE.JJ .AND. J.LE.N ) + $ CALL ZSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA ) + IF( J.LT.N ) $ GO TO 60 * * Set KB to the number of columns factorized @@ -483,6 +618,8 @@ * IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) $ GO TO 90 +* + KSTEP = 1 * * Copy column K of A to column K of W and update it * @@ -492,8 +629,6 @@ CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), LDA, $ W( K, 1 ), LDW, CONE, W( K, K ), 1 ) W( K, K ) = DBLE( W( K, K ) ) -* - KSTEP = 1 * * Determine rows and columns to be interchanged and whether * a 1-by-1 or 2-by-2 pivot block will be used @@ -501,7 +636,8 @@ ABSAKK = ABS( DBLE( W( K, K ) ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. * IF( K.LT.N ) THEN IMAX = K + IZAMAX( N-K, W( K+1, K ), 1 ) @@ -512,13 +648,19 @@ * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * -* Column K is zero: set INFO and continue +* Column K is zero or underflow: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K KP = K A( K, K ) = DBLE( A( K, K ) ) ELSE +* +* ============================================================ +* +* BEGIN pivot search +* +* Case(1) IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * * no interchange, use 1-by-1 pivot block @@ -526,6 +668,9 @@ KP = K ELSE * +* BEGIN pivot search along IMAX row +* +* * Copy column IMAX to column K+1 of W and update it * CALL ZCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 ) @@ -540,7 +685,8 @@ W( IMAX, K+1 ) = DBLE( W( IMAX, K+1 ) ) * * JMAX is the column-index of the largest off-diagonal -* element in row IMAX, and ROWMAX is its absolute value +* element in row IMAX, and ROWMAX is its absolute value. +* Determine only ROWMAX. * JMAX = K - 1 + IZAMAX( IMAX-K, W( K, K+1 ), 1 ) ROWMAX = CABS1( W( JMAX, K+1 ) ) @@ -549,11 +695,14 @@ ROWMAX = MAX( ROWMAX, CABS1( W( JMAX, K+1 ) ) ) END IF * +* Case(2) IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN * * no interchange, use 1-by-1 pivot block * KP = K +* +* Case(3) ELSE IF( ABS( DBLE( W( IMAX, K+1 ) ) ).GE.ALPHA*ROWMAX ) $ THEN * @@ -562,9 +711,11 @@ * KP = IMAX * -* copy column K+1 of W to column K +* copy column K+1 of W to column K of W * CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* +* Case(4) ELSE * * interchange rows and columns K+1 and IMAX, use 2-by-2 @@ -573,15 +724,29 @@ KP = IMAX KSTEP = 2 END IF +* +* +* END pivot search along IMAX row +* END IF +* +* END pivot search +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped * KK = K + KSTEP - 1 * -* Updated column KP is already stored in column KK of W +* Interchange rows and columns KP and KK. +* Updated column KP is already stored in column KK of W. * IF( KP.NE.KK ) THEN * -* Copy non-updated column KK to column KP +* Copy non-updated column KK to column KP of submatrix A +* at step K. No need to copy element into column K +* (or K and K+1 for 2-by-2 pivot) of A, since these columns +* will be later overwritten. * A( KP, KP ) = DBLE( A( KK, KK ) ) CALL ZCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), @@ -590,9 +755,13 @@ IF( KP.LT.N ) $ CALL ZCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) * -* Interchange rows KK and KP in first KK columns of A and W +* Interchange rows KK and KP in first K-1 columns of A +* (columns K (or K and K+1 for 2-by-2 pivot) of A will be +* later overwritten). Interchange rows KK and KP +* in first KK columns of W. * - CALL ZSWAP( KK-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) + IF( K.GT.1 ) + $ CALL ZSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) CALL ZSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) END IF * @@ -600,21 +769,35 @@ * * 1-by-1 pivot block D(k): column k of W now holds * -* W(k) = L(k)*D(k) +* W(k) = L(k)*D(k), * * where L(k) is the k-th column of L * -* Store L(k) in column k of A +* (1) Store subdiag. elements of column L(k) +* and 1-by-1 block D(k) in column k of A. +* (NOTE: Diagonal element L(k,k) is a UNIT element +* and not stored) +* A(k,k) := D(k,k) = W(k,k) +* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k) * +* (NOTE: No need to use for Hermitian matrix +* A( K, K ) = DBLE( W( K, K) ) to separately copy diagonal +* element D(k,k) from W (potentially saves only one load)) CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) IF( K.LT.N ) THEN +* +* (NOTE: No need to check if A(k,k) is NOT ZERO, +* since that was ensured earlier in pivot search: +* case A(k,k) = 0 falls into 2x2 pivot case(4)) +* R1 = ONE / DBLE( A( K, K ) ) CALL ZDSCAL( N-K, R1, A( K+1, K ), 1 ) * -* Conjugate W(k) +* (2) Conjugate column W(k) * CALL ZLACGV( N-K, W( K+1, K ), 1 ) END IF +* ELSE * * 2-by-2 pivot block D(k): columns k and k+1 of W now hold @@ -623,16 +806,69 @@ * * where L(k) and L(k+1) are the k-th and (k+1)-th columns * of L +* +* (1) Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2 +* block D(k:k+1,k:k+1) in columns k and k+1 of A. +* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT +* block and not stored) +* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1) +* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) = +* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) ) * IF( K.LT.N-1 ) THEN * -* Store L(k) and L(k+1) in columns k and k+1 of A +* Factor out the columns of the inverse of 2-by-2 pivot +* block D, so that each column contains 1, to reduce the +* number of FLOPS when we multiply panel +* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1). +* +* D**(-1) = ( d11 cj(d21) )**(-1) = +* ( d21 d22 ) +* +* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) = +* ( (-d21) ( d11 ) ) +* +* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) * +* +* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) = +* ( ( -1 ) ( d11/conj(d21) ) ) +* +* = 1/(|d21|**2) * 1/(D22*D11-1) * +* +* * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = ( conj(D21)*( D11 ) D21*( -1 ) ) +* ( ( -1 ) ( D22 ) ), +* +* where D11 = d22/d21, +* D22 = d11/conj(d21), +* D21 = T/d21, +* T = 1/(D22*D11-1). +* +* (NOTE: No need to check for division by ZERO, +* since that was ensured earlier in pivot search: +* (a) d21 != 0, since in 2x2 pivot case(4) +* |d21| should be larger than |d11| and |d22|; +* (b) (D22*D11 - 1) != 0, since from (a), +* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.) * D21 = W( K+1, K ) D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / DCONJG( D21 ) T = ONE / ( DBLE( D11*D22 )-ONE ) D21 = T / D21 +* +* Update elements in columns A(k) and A(k+1) as +* dot products of rows of ( W(k) W(k+1) ) and columns +* of D**(-1) +* DO 80 J = K + 2, N A( J, K ) = DCONJG( D21 )* $ ( D11*W( J, K )-W( J, K+1 ) ) @@ -646,11 +882,13 @@ A( K+1, K ) = W( K+1, K ) A( K+1, K+1 ) = W( K+1, K+1 ) * -* Conjugate W(k) and W(k+1) +* (2) Conjugate columns W(k) and W(k+1) * CALL ZLACGV( N-K, W( K+1, K ), 1 ) CALL ZLACGV( N-K-1, W( K+2, K+1 ), 1 ) +* END IF +* END IF * * Store details of the interchanges in IPIV @@ -698,20 +936,28 @@ 110 CONTINUE * * Put L21 in standard form by partially undoing the interchanges -* in columns 1:k-1 +* of rows in columns 1:k-1 looping backwards from k-1 to 1 * J = K - 1 120 CONTINUE - JJ = J - JP = IPIV( J ) - IF( JP.LT.0 ) THEN - JP = -JP +* +* Undo the interchanges (if any) of rows JJ and JP at each +* step J +* +* (Here, J is a diagonal index) + JJ = J + JP = IPIV( J ) + IF( JP.LT.0 ) THEN + JP = -JP +* (Here, J is a diagonal index) + J = J - 1 + END IF +* (NOTE: Here, J is used to determine row length. Length J +* of the rows to swap back doesn't include diagonal element) J = J - 1 - END IF - J = J - 1 - IF( JP.NE.JJ .AND. J.GE.1 ) - $ CALL ZSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA ) - IF( J.GE.1 ) + IF( JP.NE.JJ .AND. J.GE.1 ) + $ CALL ZSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA ) + IF( J.GT.1 ) $ GO TO 120 * * Set KB to the number of columns factorized diff --git a/lapack-netlib/SRC/zlahef_rook.f b/lapack-netlib/SRC/zlahef_rook.f new file mode 100644 index 000000000..1a344a30f --- /dev/null +++ b/lapack-netlib/SRC/zlahef_rook.f @@ -0,0 +1,1176 @@ +* \brief \b ZLAHEF_ROOK computes a partial factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (blocked algorithm, calling Level 3 BLAS). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLAHEF_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), W( LDW, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLAHEF_ROOK computes a partial factorization of a complex Hermitian +*> matrix A using the bounded Bunch-Kaufman ("rook") diagonal pivoting +*> method. The partial factorization has the form: +*> +*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: +*> ( 0 U22 ) ( 0 D ) ( U12**H U22**H ) +*> +*> A = ( L11 0 ) ( D 0 ) ( L11**H L21**H ) if UPLO = 'L' +*> ( L21 I ) ( 0 A22 ) ( 0 I ) +*> +*> where the order of D is at most NB. The actual order is returned in +*> the argument KB, and is either NB or NB-1, or N if N <= NB. +*> Note that U**H denotes the conjugate transpose of U. +*> +*> ZLAHEF_ROOK is an auxiliary routine called by ZHETRF_ROOK. It uses +*> blocked code (calling Level 3 BLAS) to update the submatrix +*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> Hermitian matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The maximum number of columns of the matrix A that should be +*> factored. NB should be at least 2 to allow for 2-by-2 pivot +*> blocks. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> The number of columns of A that were actually factored. +*> KB is either NB-1 or NB, or N if N <= NB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the Hermitian matrix A. If UPLO = 'U', the leading +*> n-by-n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading n-by-n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> On exit, A contains details of the partial factorization. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> Only the last KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> Only the first KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is COMPLEX*16 array, dimension (LDW,NB) +*> \endverbatim +*> +*> \param[in] LDW +*> \verbatim +*> LDW is INTEGER +*> The leading dimension of the array W. LDW >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex16HEcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, + $ INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), W( LDW, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL DONE + INTEGER IMAX, ITEMP, II, J, JB, JJ, JMAX, JP1, JP2, K, + $ KK, KKW, KP, KSTEP, KW, P + DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, DTEMP, R1, ROWMAX, T, + $ SFMIN + COMPLEX*16 D11, D21, D22, Z +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, IZAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL ZCOPY, ZDSCAL, ZGEMM, ZGEMV, ZLACGV, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) ) +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = DLAMCH( 'S' ) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Factorize the trailing columns of A using the upper triangle +* of A and working backwards, and compute the matrix W = U12*D +* for use in updating A11 (note that conjg(W) is actually stored) +* +* K is the main loop index, decreasing from N in steps of 1 or 2 +* + K = N + 10 CONTINUE +* +* KW is the column of W which corresponds to column K of A +* + KW = NB + K - N +* +* Exit from loop +* + IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) + $ GO TO 30 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column KW of W and update it +* + IF( K.GT.1 ) + $ CALL ZCOPY( K-1, A( 1, K ), 1, W( 1, KW ), 1 ) + W( K, KW ) = DBLE( A( K, K ) ) + IF( K.LT.N ) THEN + CALL ZGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), LDA, + $ W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 ) + W( K, KW ) = DBLE( W( K, KW ) ) + END IF +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( DBLE( W( K, KW ) ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = IZAMAX( K-1, W( 1, KW ), 1 ) + COLMAX = CABS1( W( IMAX, KW ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + A( K, K ) = DBLE( W( K, KW ) ) + IF( K.GT.1 ) + $ CALL ZCOPY( K-1, W( 1, KW ), 1, A( 1, K ), 1 ) + ELSE +* +* ============================================================ +* +* BEGIN pivot search +* +* Case(1) +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* +* Lop until pivot found +* + DONE = .FALSE. +* + 12 CONTINUE +* +* BEGIN pivot search loop body +* +* +* Copy column IMAX to column KW-1 of W and update it +* + IF( IMAX.GT.1 ) + $ CALL ZCOPY( IMAX-1, A( 1, IMAX ), 1, W( 1, KW-1 ), + $ 1 ) + W( IMAX, KW-1 ) = DBLE( A( IMAX, IMAX ) ) +* + CALL ZCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, + $ W( IMAX+1, KW-1 ), 1 ) + CALL ZLACGV( K-IMAX, W( IMAX+1, KW-1 ), 1 ) +* + IF( K.LT.N ) THEN + CALL ZGEMV( 'No transpose', K, N-K, -CONE, + $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW, + $ CONE, W( 1, KW-1 ), 1 ) + W( IMAX, KW-1 ) = DBLE( W( IMAX, KW-1 ) ) + END IF +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + IZAMAX( K-IMAX, W( IMAX+1, KW-1 ), + $ 1 ) + ROWMAX = CABS1( W( JMAX, KW-1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = IZAMAX( IMAX-1, W( 1, KW-1 ), 1 ) + DTEMP = CABS1( W( ITEMP, KW-1 ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Case(2) +* Equivalent to testing for +* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABS( DBLE( W( IMAX,KW-1 ) ) ) + $ .LT.ALPHA*ROWMAX ) ) THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column KW-1 of W to column KW of W +* + CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + DONE = .TRUE. +* +* Case(3) +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K-1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. +* +* Case(4) + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + END IF +* +* +* END pivot search loop body +* + IF( .NOT.DONE ) GOTO 12 +* + END IF +* +* END pivot search +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped +* + KK = K - KSTEP + 1 +* +* KKW is the column of W which corresponds to column KK of A +* + KKW = NB + KK - N +* +* Interchange rows and columns P and K. +* Updated column P is already stored in column KW of W. +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P of submatrix A +* at step K. No need to copy element into columns +* K and K-1 of A for 2-by-2 pivot, since these columns +* will be later overwritten. +* + A( P, P ) = DBLE( A( K, K ) ) + CALL ZCOPY( K-1-P, A( P+1, K ), 1, A( P, P+1 ), + $ LDA ) + CALL ZLACGV( K-1-P, A( P, P+1 ), LDA ) + IF( P.GT.1 ) + $ CALL ZCOPY( P-1, A( 1, K ), 1, A( 1, P ), 1 ) +* +* Interchange rows K and P in the last K+1 to N columns of A +* (columns K and K-1 of A for 2-by-2 pivot will be +* later overwritten). Interchange rows K and P +* in last KKW to NB columns of W. +* + IF( K.LT.N ) + $ CALL ZSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), + $ LDA ) + CALL ZSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), + $ LDW ) + END IF +* +* Interchange rows and columns KP and KK. +* Updated column KP is already stored in column KKW of W. +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP of submatrix A +* at step K. No need to copy element into column K +* (or K and K-1 for 2-by-2 pivot) of A, since these columns +* will be later overwritten. +* + A( KP, KP ) = DBLE( A( KK, KK ) ) + CALL ZCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + CALL ZLACGV( KK-1-KP, A( KP, KP+1 ), LDA ) + IF( KP.GT.1 ) + $ CALL ZCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) +* +* Interchange rows KK and KP in last K+1 to N columns of A +* (columns K (or K and K-1 for 2-by-2 pivot) of A will be +* later overwritten). Interchange rows KK and KP +* in last KKW to NB columns of W. +* + IF( K.LT.N ) + $ CALL ZSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ), + $ LDA ) + CALL ZSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), + $ LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column kw of W now holds +* +* W(kw) = U(k)*D(k), +* +* where U(k) is the k-th column of U +* +* (1) Store subdiag. elements of column U(k) +* and 1-by-1 block D(k) in column k of A. +* (NOTE: Diagonal element U(k,k) is a UNIT element +* and not stored) +* A(k,k) := D(k,k) = W(k,kw) +* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k) +* +* (NOTE: No need to use for Hermitian matrix +* A( K, K ) = REAL( W( K, K) ) to separately copy diagonal +* element D(k,k) from W (potentially saves only one load)) + CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) + IF( K.GT.1 ) THEN +* +* (NOTE: No need to check if A(k,k) is NOT ZERO, +* since that was ensured earlier in pivot search: +* case A(k,k) = 0 falls into 2x2 pivot case(3)) +* +* Handle division by a small number +* + T = DBLE( A( K, K ) ) + IF( ABS( T ).GE.SFMIN ) THEN + R1 = ONE / T + CALL ZDSCAL( K-1, R1, A( 1, K ), 1 ) + ELSE + DO 14 II = 1, K-1 + A( II, K ) = A( II, K ) / T + 14 CONTINUE + END IF +* +* (2) Conjugate column W(kw) +* + CALL ZLACGV( K-1, W( 1, KW ), 1 ) + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold +* +* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* +* (1) Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2 +* block D(k-1:k,k-1:k) in columns k-1 and k of A. +* (NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT +* block and not stored) +* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw) +* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) = +* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) ) +* + IF( K.GT.2 ) THEN +* +* Factor out the columns of the inverse of 2-by-2 pivot +* block D, so that each column contains 1, to reduce the +* number of FLOPS when we multiply panel +* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1). +* +* D**(-1) = ( d11 cj(d21) )**(-1) = +* ( d21 d22 ) +* +* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) = +* ( (-d21) ( d11 ) ) +* +* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) * +* +* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) = +* ( ( -1 ) ( d11/conj(d21) ) ) +* +* = 1/(|d21|**2) * 1/(D22*D11-1) * +* +* * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* Handle division by a small number. (NOTE: order of +* operations is important) +* +* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) ) +* ( (( -1 ) ) (( D22 ) ) ), +* +* where D11 = d22/d21, +* D22 = d11/conj(d21), +* D21 = d21, +* T = 1/(D22*D11-1). +* +* (NOTE: No need to check for division by ZERO, +* since that was ensured earlier in pivot search: +* (a) d21 != 0 in 2x2 pivot case(4), +* since |d21| should be larger than |d11| and |d22|; +* (b) (D22*D11 - 1) != 0, since from (a), +* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.) +* + D21 = W( K-1, KW ) + D11 = W( K, KW ) / DCONJG( D21 ) + D22 = W( K-1, KW-1 ) / D21 + T = ONE / ( DBLE( D11*D22 )-ONE ) +* +* Update elements in columns A(k-1) and A(k) as +* dot products of rows of ( W(kw-1) W(kw) ) and columns +* of D**(-1) +* + DO 20 J = 1, K - 2 + A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) / + $ D21 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ DCONJG( D21 ) ) + 20 CONTINUE + END IF +* +* Copy D(k) to A +* + A( K-1, K-1 ) = W( K-1, KW-1 ) + A( K-1, K ) = W( K-1, KW ) + A( K, K ) = W( K, KW ) +* +* (2) Conjugate columns W(kw) and W(kw-1) +* + CALL ZLACGV( K-1, W( 1, KW ), 1 ) + CALL ZLACGV( K-2, W( 1, KW-1 ), 1 ) +* + END IF +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + 30 CONTINUE +* +* Update the upper triangle of A11 (= A(1:k,1:k)) as +* +* A11 := A11 - U12*D*U12**H = A11 - U12*W**H +* +* computing blocks of NB columns at a time (note that conjg(W) is +* actually stored) +* + DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB + JB = MIN( NB, K-J+1 ) +* +* Update the upper triangle of the diagonal block +* + DO 40 JJ = J, J + JB - 1 + A( JJ, JJ ) = DBLE( A( JJ, JJ ) ) + CALL ZGEMV( 'No transpose', JJ-J+1, N-K, -CONE, + $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE, + $ A( J, JJ ), 1 ) + A( JJ, JJ ) = DBLE( A( JJ, JJ ) ) + 40 CONTINUE +* +* Update the rectangular superdiagonal block +* + IF( J.GE.2 ) + $ CALL ZGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, + $ -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, + $ CONE, A( 1, J ), LDA ) + 50 CONTINUE +* +* Put U12 in standard form by partially undoing the interchanges +* in of rows in columns k+1:n looping backwards from k+1 to n +* + J = K + 1 + 60 CONTINUE +* +* Undo the interchanges (if any) of rows J and JP2 +* (or J and JP2, and J+1 and JP1) at each step J +* + KSTEP = 1 + JP1 = 1 +* (Here, J is a diagonal index) + JJ = J + JP2 = IPIV( J ) + IF( JP2.LT.0 ) THEN + JP2 = -JP2 +* (Here, J is a diagonal index) + J = J + 1 + JP1 = -IPIV( J ) + KSTEP = 2 + END IF +* (NOTE: Here, J is used to determine row length. Length N-J+1 +* of the rows to swap back doesn't include diagonal element) + J = J + 1 + IF( JP2.NE.JJ .AND. J.LE.N ) + $ CALL ZSWAP( N-J+1, A( JP2, J ), LDA, A( JJ, J ), LDA ) + JJ = JJ + 1 + IF( KSTEP.EQ.2 .AND. JP1.NE.JJ .AND. J.LE.N ) + $ CALL ZSWAP( N-J+1, A( JP1, J ), LDA, A( JJ, J ), LDA ) + IF( J.LT.N ) + $ GO TO 60 +* +* Set KB to the number of columns factorized +* + KB = N - K +* + ELSE +* +* Factorize the leading columns of A using the lower triangle +* of A and working forwards, and compute the matrix W = L21*D +* for use in updating A22 (note that conjg(W) is actually stored) +* +* K is the main loop index, increasing from 1 in steps of 1 or 2 +* + K = 1 + 70 CONTINUE +* +* Exit from loop +* + IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) + $ GO TO 90 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column K of W and update column K of W +* + W( K, K ) = DBLE( A( K, K ) ) + IF( K.LT.N ) + $ CALL ZCOPY( N-K, A( K+1, K ), 1, W( K+1, K ), 1 ) + IF( K.GT.1 ) THEN + CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), + $ LDA, W( K, 1 ), LDW, CONE, W( K, K ), 1 ) + W( K, K ) = DBLE( W( K, K ) ) + END IF +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( DBLE( W( K, K ) ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + IZAMAX( N-K, W( K+1, K ), 1 ) + COLMAX = CABS1( W( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + A( K, K ) = DBLE( W( K, K ) ) + IF( K.LT.N ) + $ CALL ZCOPY( N-K, W( K+1, K ), 1, A( K+1, K ), 1 ) + ELSE +* +* ============================================================ +* +* BEGIN pivot search +* +* Case(1) +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 72 CONTINUE +* +* BEGIN pivot search loop body +* +* +* Copy column IMAX to column k+1 of W and update it +* + CALL ZCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1) + CALL ZLACGV( IMAX-K, W( K, K+1 ), 1 ) + W( IMAX, K+1 ) = DBLE( A( IMAX, IMAX ) ) +* + IF( IMAX.LT.N ) + $ CALL ZCOPY( N-IMAX, A( IMAX+1, IMAX ), 1, + $ W( IMAX+1, K+1 ), 1 ) +* + IF( K.GT.1 ) THEN + CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, + $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW, + $ CONE, W( K, K+1 ), 1 ) + W( IMAX, K+1 ) = DBLE( W( IMAX, K+1 ) ) + END IF +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + IZAMAX( IMAX-K, W( K, K+1 ), 1 ) + ROWMAX = CABS1( W( JMAX, K+1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + IZAMAX( N-IMAX, W( IMAX+1, K+1 ), 1) + DTEMP = CABS1( W( ITEMP, K+1 ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Case(2) +* Equivalent to testing for +* ABS( REAL( W( IMAX,K+1 ) ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABS( DBLE( W( IMAX,K+1 ) ) ) + $ .LT.ALPHA*ROWMAX ) ) THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column K+1 of W to column K of W +* + CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + DONE = .TRUE. +* +* Case(3) +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. +* +* Case(4) + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + END IF +* +* +* End pivot search loop body +* + IF( .NOT.DONE ) GOTO 72 +* + END IF +* +* END pivot search +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped +* + KK = K + KSTEP - 1 +* +* Interchange rows and columns P and K (only for 2-by-2 pivot). +* Updated column P is already stored in column K of W. +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column KK-1 to column P of submatrix A +* at step K. No need to copy element into columns +* K and K+1 of A for 2-by-2 pivot, since these columns +* will be later overwritten. +* + A( P, P ) = DBLE( A( K, K ) ) + CALL ZCOPY( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA ) + CALL ZLACGV( P-K-1, A( P, K+1 ), LDA ) + IF( P.LT.N ) + $ CALL ZCOPY( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) +* +* Interchange rows K and P in first K-1 columns of A +* (columns K and K+1 of A for 2-by-2 pivot will be +* later overwritten). Interchange rows K and P +* in first KK columns of W. +* + IF( K.GT.1 ) + $ CALL ZSWAP( K-1, A( K, 1 ), LDA, A( P, 1 ), LDA ) + CALL ZSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW ) + END IF +* +* Interchange rows and columns KP and KK. +* Updated column KP is already stored in column KK of W. +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP of submatrix A +* at step K. No need to copy element into column K +* (or K and K+1 for 2-by-2 pivot) of A, since these columns +* will be later overwritten. +* + A( KP, KP ) = DBLE( A( KK, KK ) ) + CALL ZCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ LDA ) + CALL ZLACGV( KP-KK-1, A( KP, KK+1 ), LDA ) + IF( KP.LT.N ) + $ CALL ZCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) +* +* Interchange rows KK and KP in first K-1 columns of A +* (column K (or K and K+1 for 2-by-2 pivot) of A will be +* later overwritten). Interchange rows KK and KP +* in first KK columns of W. +* + IF( K.GT.1 ) + $ CALL ZSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) + CALL ZSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k of W now holds +* +* W(k) = L(k)*D(k), +* +* where L(k) is the k-th column of L +* +* (1) Store subdiag. elements of column L(k) +* and 1-by-1 block D(k) in column k of A. +* (NOTE: Diagonal element L(k,k) is a UNIT element +* and not stored) +* A(k,k) := D(k,k) = W(k,k) +* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k) +* +* (NOTE: No need to use for Hermitian matrix +* A( K, K ) = REAL( W( K, K) ) to separately copy diagonal +* element D(k,k) from W (potentially saves only one load)) + CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) + IF( K.LT.N ) THEN +* +* (NOTE: No need to check if A(k,k) is NOT ZERO, +* since that was ensured earlier in pivot search: +* case A(k,k) = 0 falls into 2x2 pivot case(3)) +* +* Handle division by a small number +* + T = DBLE( A( K, K ) ) + IF( ABS( T ).GE.SFMIN ) THEN + R1 = ONE / T + CALL ZDSCAL( N-K, R1, A( K+1, K ), 1 ) + ELSE + DO 74 II = K + 1, N + A( II, K ) = A( II, K ) / T + 74 CONTINUE + END IF +* +* (2) Conjugate column W(k) +* + CALL ZLACGV( N-K, W( K+1, K ), 1 ) + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 of W now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* +* (1) Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2 +* block D(k:k+1,k:k+1) in columns k and k+1 of A. +* NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT +* block and not stored. +* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1) +* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) = +* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) ) +* + IF( K.LT.N-1 ) THEN +* +* Factor out the columns of the inverse of 2-by-2 pivot +* block D, so that each column contains 1, to reduce the +* number of FLOPS when we multiply panel +* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1). +* +* D**(-1) = ( d11 cj(d21) )**(-1) = +* ( d21 d22 ) +* +* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) = +* ( (-d21) ( d11 ) ) +* +* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) * +* +* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) = +* ( ( -1 ) ( d11/conj(d21) ) ) +* +* = 1/(|d21|**2) * 1/(D22*D11-1) * +* +* * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* Handle division by a small number. (NOTE: order of +* operations is important) +* +* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) ) +* ( (( -1 ) ) (( D22 ) ) ), +* +* where D11 = d22/d21, +* D22 = d11/conj(d21), +* D21 = d21, +* T = 1/(D22*D11-1). +* +* (NOTE: No need to check for division by ZERO, +* since that was ensured earlier in pivot search: +* (a) d21 != 0 in 2x2 pivot case(4), +* since |d21| should be larger than |d11| and |d22|; +* (b) (D22*D11 - 1) != 0, since from (a), +* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.) +* + D21 = W( K+1, K ) + D11 = W( K+1, K+1 ) / D21 + D22 = W( K, K ) / DCONJG( D21 ) + T = ONE / ( DBLE( D11*D22 )-ONE ) +* +* Update elements in columns A(k) and A(k+1) as +* dot products of rows of ( W(k) W(k+1) ) and columns +* of D**(-1) +* + DO 80 J = K + 2, N + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ DCONJG( D21 ) ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) + 80 CONTINUE + END IF +* +* Copy D(k) to A +* + A( K, K ) = W( K, K ) + A( K+1, K ) = W( K+1, K ) + A( K+1, K+1 ) = W( K+1, K+1 ) +* +* (2) Conjugate columns W(k) and W(k+1) +* + CALL ZLACGV( N-K, W( K+1, K ), 1 ) + CALL ZLACGV( N-K-1, W( K+2, K+1 ), 1 ) +* + END IF +* + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 70 +* + 90 CONTINUE +* +* Update the lower triangle of A22 (= A(k:n,k:n)) as +* +* A22 := A22 - L21*D*L21**H = A22 - L21*W**H +* +* computing blocks of NB columns at a time (note that conjg(W) is +* actually stored) +* + DO 110 J = K, N, NB + JB = MIN( NB, N-J+1 ) +* +* Update the lower triangle of the diagonal block +* + DO 100 JJ = J, J + JB - 1 + A( JJ, JJ ) = DBLE( A( JJ, JJ ) ) + CALL ZGEMV( 'No transpose', J+JB-JJ, K-1, -CONE, + $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE, + $ A( JJ, JJ ), 1 ) + A( JJ, JJ ) = DBLE( A( JJ, JJ ) ) + 100 CONTINUE +* +* Update the rectangular subdiagonal block +* + IF( J+JB.LE.N ) + $ CALL ZGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, + $ K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ), + $ LDW, CONE, A( J+JB, J ), LDA ) + 110 CONTINUE +* +* Put L21 in standard form by partially undoing the interchanges +* of rows in columns 1:k-1 looping backwards from k-1 to 1 +* + J = K - 1 + 120 CONTINUE +* +* Undo the interchanges (if any) of rows J and JP2 +* (or J and JP2, and J-1 and JP1) at each step J +* + KSTEP = 1 + JP1 = 1 +* (Here, J is a diagonal index) + JJ = J + JP2 = IPIV( J ) + IF( JP2.LT.0 ) THEN + JP2 = -JP2 +* (Here, J is a diagonal index) + J = J - 1 + JP1 = -IPIV( J ) + KSTEP = 2 + END IF +* (NOTE: Here, J is used to determine row length. Length J +* of the rows to swap back doesn't include diagonal element) + J = J - 1 + IF( JP2.NE.JJ .AND. J.GE.1 ) + $ CALL ZSWAP( J, A( JP2, 1 ), LDA, A( JJ, 1 ), LDA ) + JJ = JJ -1 + IF( KSTEP.EQ.2 .AND. JP1.NE.JJ .AND. J.GE.1 ) + $ CALL ZSWAP( J, A( JP1, 1 ), LDA, A( JJ, 1 ), LDA ) + IF( J.GT.1 ) + $ GO TO 120 +* +* Set KB to the number of columns factorized +* + KB = K - 1 +* + END IF + RETURN +* +* End of ZLAHEF_ROOK +* + END diff --git a/lapack-netlib/SRC/zlarfb.f b/lapack-netlib/SRC/zlarfb.f index 99490f582..480f543fa 100644 --- a/lapack-netlib/SRC/zlarfb.f +++ b/lapack-netlib/SRC/zlarfb.f @@ -159,7 +159,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2013 * *> \ingroup complex16OTHERauxiliary * @@ -195,10 +195,10 @@ SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2013 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS @@ -217,12 +217,11 @@ * .. * .. Local Scalars .. CHARACTER TRANST - INTEGER I, J, LASTV, LASTC + INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAZLR, ILAZLC - EXTERNAL LSAME, ILAZLR, ILAZLC + EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM @@ -255,36 +254,33 @@ * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) -* - LASTV = MAX( K, ILAZLR( M, K, V, LDV ) ) - LASTC = ILAZLC( LASTV, N, C, LDC ) * * W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) * * W := C1**H * DO 10 J = 1, K - CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) + CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL ZLACGV( N, WORK( 1, J ), 1 ) 10 CONTINUE * * W := W * V1 * - CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN * -* W := W + C2**H *V2 +* W := W + C2**H * V2 * - CALL ZGEMM( 'Conjugate transpose', 'No transpose', - $ LASTC, K, LASTV-K, ONE, C( K+1, 1 ), LDC, - $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK ) + CALL ZGEMM( 'Conjugate transpose', 'No transpose', N, + $ K, M-K, ONE, C( K+1, 1 ), LDC, + $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**H or W * T * - CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**H * @@ -293,20 +289,19 @@ * C2 := C2 - V2 * W**H * CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ LASTV-K, LASTC, K, - $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, - $ ONE, C( K+1, 1 ), LDC ) + $ M-K, N, K, -ONE, V( K+1, 1 ), LDV, WORK, + $ LDWORK, ONE, C( K+1, 1 ), LDC ) END IF * * W := W * V1**H * CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) + $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**H * DO 30 J = 1, K - DO 20 I = 1, LASTC + DO 20 I = 1, N C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) 20 CONTINUE 30 CONTINUE @@ -314,58 +309,53 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) -* - LASTV = MAX( K, ILAZLR( N, K, V, LDV ) ) - LASTC = ILAZLR( M, LASTV, C, LDC ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C1 * DO 40 J = 1, K - CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 40 CONTINUE * * W := W * V1 * - CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN * * W := W + C2 * V2 * - CALL ZGEMM( 'No transpose', 'No transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) + CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**H * - CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**H * - IF( LASTV.GT.K ) THEN + IF( N.GT.K ) THEN * * C2 := C2 - W * V2**H * - CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, - $ ONE, C( 1, K+1 ), LDC ) + CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, + $ N-K, K, -ONE, WORK, LDWORK, V( K+1, 1 ), + $ LDV, ONE, C( 1, K+1 ), LDC ) END IF * * W := W * V1**H * CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) + $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 60 J = 1, K - DO 50 I = 1, LASTC + DO 50 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 50 CONTINUE 60 CONTINUE @@ -381,38 +371,33 @@ * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) -* - LASTC = ILAZLC( M, N, C, LDC ) * * W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) * * W := C2**H * DO 70 J = 1, K - CALL ZCOPY( LASTC, C( M-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) - CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) + CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL ZLACGV( N, WORK( 1, J ), 1 ) 70 CONTINUE * * W := W * V2 * - CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( M-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * -* W := W + C1**H*V1 +* W := W + C1**H * V1 * - CALL ZGEMM( 'Conjugate transpose', 'No transpose', - $ LASTC, K, M-K, - $ ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL ZGEMM( 'Conjugate transpose', 'No transpose', N, + $ K, M-K, ONE, C, LDC, V, LDV, ONE, WORK, + $ LDWORK ) END IF * * W := W * T**H or W * T * - CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**H * @@ -421,21 +406,20 @@ * C1 := C1 - V1 * W**H * CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ M-K, LASTC, K, - $ -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) + $ M-K, N, K, -ONE, V, LDV, WORK, LDWORK, + $ ONE, C, LDC ) END IF * * W := W * V2**H * CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V( M-K+1, 1 ), LDV, - $ WORK, LDWORK ) + $ 'Unit', N, K, ONE, V( M-K+1, 1 ), LDV, WORK, + $ LDWORK ) * * C2 := C2 - W**H * DO 90 J = 1, K - DO 80 I = 1, LASTC + DO 80 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - $ DCONJG( WORK( I, J ) ) 80 CONTINUE @@ -444,36 +428,31 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) -* - LASTC = ILAZLR( M, N, C, LDC ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C2 * DO 100 J = 1, K - CALL ZCOPY( LASTC, C( 1, N-K+J ), 1, - $ WORK( 1, J ), 1 ) + CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 100 CONTINUE * * W := W * V2 * - CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( N-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1 * - CALL ZGEMM( 'No transpose', 'No transpose', - $ LASTC, K, N-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**H * - CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**H * @@ -481,23 +460,22 @@ * * C1 := C1 - W * V1**H * - CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) + CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, + $ N-K, K, -ONE, WORK, LDWORK, V, LDV, ONE, + $ C, LDC ) END IF * * W := W * V2**H * CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V( N-K+1, 1 ), LDV, - $ WORK, LDWORK ) + $ 'Unit', M, K, ONE, V( N-K+1, 1 ), LDV, WORK, + $ LDWORK ) * * C2 := C2 - W * DO 120 J = 1, K - DO 110 I = 1, LASTC - C( I, N-K+J ) = C( I, N-K+J ) - $ - WORK( I, J ) + DO 110 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 110 CONTINUE 120 CONTINUE END IF @@ -514,59 +492,56 @@ * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) -* - LASTV = MAX( K, ILAZLC( K, M, V, LDV ) ) - LASTC = ILAZLC( LASTV, N, C, LDC ) * * W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) * * W := C1**H * DO 130 J = 1, K - CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) + CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL ZLACGV( N, WORK( 1, J ), 1 ) 130 CONTINUE * * W := W * V1**H * CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN * -* W := W + C2**H*V2**H +* W := W + C2**H * V2**H * CALL ZGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', LASTC, K, LASTV-K, - $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) + $ 'Conjugate transpose', N, K, M-K, ONE, + $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, + $ WORK, LDWORK ) END IF * * W := W * T**H or W * T * - CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**H * W**H * - IF( LASTV.GT.K ) THEN + IF( M.GT.K ) THEN * * C2 := C2 - V2**H * W**H * CALL ZGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', LASTV-K, LASTC, K, - $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, - $ ONE, C( K+1, 1 ), LDC ) + $ 'Conjugate transpose', M-K, N, K, -ONE, + $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) END IF * * W := W * V1 * - CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**H * DO 150 J = 1, K - DO 140 I = 1, LASTC + DO 140 I = 1, N C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) 140 CONTINUE 150 CONTINUE @@ -574,57 +549,53 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) -* - LASTV = MAX( K, ILAZLC( K, N, V, LDV ) ) - LASTC = ILAZLR( M, LASTV, C, LDC ) * * W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) * * W := C1 * DO 160 J = 1, K - CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 160 CONTINUE * * W := W * V1**H * CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN * * W := W + C2 * V2**H * - CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ LASTC, K, LASTV-K, ONE, C( 1, K+1 ), LDC, - $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK ) + CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, + $ K, N-K, ONE, C( 1, K+1 ), LDC, + $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**H * - CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * - IF( LASTV.GT.K ) THEN + IF( N.GT.K ) THEN * * C2 := C2 - W * V2 * - CALL ZGEMM( 'No transpose', 'No transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, - $ ONE, C( 1, K+1 ), LDC ) + CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) END IF * * W := W * V1 * - CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 180 J = 1, K - DO 170 I = 1, LASTC + DO 170 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 170 CONTINUE 180 CONTINUE @@ -640,37 +611,34 @@ * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) -* - LASTC = ILAZLC( M, N, C, LDC ) * * W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) * * W := C2**H * DO 190 J = 1, K - CALL ZCOPY( LASTC, C( M-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) - CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) + CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL ZLACGV( N, WORK( 1, J ), 1 ) 190 CONTINUE * * W := W * V2**H * CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V( 1, M-K+1 ), LDV, - $ WORK, LDWORK ) + $ 'Unit', N, K, ONE, V( 1, M-K+1 ), LDV, WORK, + $ LDWORK ) IF( M.GT.K ) THEN * * W := W + C1**H * V1**H * CALL ZGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', LASTC, K, M-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + $ 'Conjugate transpose', N, K, M-K, ONE, C, + $ LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**H or W * T * - CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**H * W**H * @@ -679,20 +647,19 @@ * C1 := C1 - V1**H * W**H * CALL ZGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', M-K, LASTC, K, - $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) + $ 'Conjugate transpose', M-K, N, K, -ONE, V, + $ LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2 * - CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, M-K+1 ), LDV, - $ WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W**H * DO 210 J = 1, K - DO 200 I = 1, LASTC + DO 200 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - $ DCONJG( WORK( I, J ) ) 200 CONTINUE @@ -701,36 +668,33 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) -* - LASTC = ILAZLR( M, N, C, LDC ) * * W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) * * W := C2 * DO 220 J = 1, K - CALL ZCOPY( LASTC, C( 1, N-K+J ), 1, - $ WORK( 1, J ), 1 ) + CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 220 CONTINUE * * W := W * V2**H * CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V( 1, N-K+1 ), LDV, - $ WORK, LDWORK ) + $ 'Unit', M, K, ONE, V( 1, N-K+1 ), LDV, WORK, + $ LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1**H * - CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ LASTC, K, N-K, ONE, C, LDC, V, LDV, ONE, - $ WORK, LDWORK ) + CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, + $ K, N-K, ONE, C, LDC, V, LDV, ONE, WORK, + $ LDWORK ) END IF * * W := W * T or W * T**H * - CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * @@ -738,21 +702,19 @@ * * C1 := C1 - W * V1 * - CALL ZGEMM( 'No transpose', 'No transpose', - $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) + CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2 * - CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, N-K+1 ), LDV, - $ WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 240 J = 1, K - DO 230 I = 1, LASTC + DO 230 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 230 CONTINUE 240 CONTINUE diff --git a/lapack-netlib/SRC/zlartg.f b/lapack-netlib/SRC/zlartg.f index e790021c6..3e2260223 100644 --- a/lapack-netlib/SRC/zlartg.f +++ b/lapack-netlib/SRC/zlartg.f @@ -85,7 +85,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup complex16OTHERauxiliary * @@ -103,10 +103,10 @@ * ===================================================================== SUBROUTINE ZLARTG( F, G, CS, SN, R ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. DOUBLE PRECISION CS @@ -130,7 +130,8 @@ * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2 - EXTERNAL DLAMCH, DLAPY2 + LOGICAL DISNAN + EXTERNAL DLAMCH, DLAPY2, DISNAN * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, LOG, @@ -139,26 +140,17 @@ * .. Statement Functions .. DOUBLE PRECISION ABS1, ABSSQ * .. -* .. Save statement .. -* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 -* .. -* .. Data statements .. -* DATA FIRST / .TRUE. / -* .. * .. Statement Function definitions .. ABS1( FF ) = MAX( ABS( DBLE( FF ) ), ABS( DIMAG( FF ) ) ) ABSSQ( FF ) = DBLE( FF )**2 + DIMAG( FF )**2 * .. * .. Executable Statements .. * -* IF( FIRST ) THEN - SAFMIN = DLAMCH( 'S' ) - EPS = DLAMCH( 'E' ) - SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / - $ LOG( DLAMCH( 'B' ) ) / TWO ) - SAFMX2 = ONE / SAFMN2 -* FIRST = .FALSE. -* END IF + SAFMIN = DLAMCH( 'S' ) + EPS = DLAMCH( 'E' ) + SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / + $ LOG( DLAMCH( 'B' ) ) / TWO ) + SAFMX2 = ONE / SAFMN2 SCALE = MAX( ABS1( F ), ABS1( G ) ) FS = F GS = G @@ -172,7 +164,7 @@ IF( SCALE.GE.SAFMX2 ) $ GO TO 10 ELSE IF( SCALE.LE.SAFMN2 ) THEN - IF( G.EQ.CZERO ) THEN + IF( G.EQ.CZERO.OR.DISNAN( ABS( G ) ) ) THEN CS = ONE SN = CZERO R = F diff --git a/lapack-netlib/SRC/zlasyf.f b/lapack-netlib/SRC/zlasyf.f index a732eae5f..b0f48fbbc 100644 --- a/lapack-netlib/SRC/zlasyf.f +++ b/lapack-netlib/SRC/zlasyf.f @@ -1,25 +1,25 @@ -*> \brief \b ZLASYF computes a partial factorization of a complex symmetric matrix, using the diagonal pivoting method. +*> \brief \b ZLASYF computes a partial factorization of a complex symmetric matrix using the Bunch-Kaufman diagonal pivoting method. * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download ZLASYF + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download ZLASYF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER INFO, KB, LDA, LDW, N, NB @@ -28,7 +28,7 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), W( LDW, * ) * .. -* +* * *> \par Purpose: * ============= @@ -110,16 +110,26 @@ *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D. -*> If UPLO = 'U', only the last KB elements of IPIV are set; -*> if UPLO = 'L', only the first KB elements are set. *> -*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were -*> interchanged and D(k,k) is a 1-by-1 diagonal block. -*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and -*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) -*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = -*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were -*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> If UPLO = 'U': +*> Only the last KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns +*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) +*> is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> Only the first KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns +*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1) +*> is a 2-by-2 diagonal block. *> \endverbatim *> *> \param[out] W @@ -145,22 +155,32 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup complex16SYcomputational * +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> \endverbatim +* * ===================================================================== SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER UPLO @@ -246,7 +266,7 @@ ABSAKK = CABS1( W( K, KW ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value + * IF( K.GT.1 ) THEN IMAX = IZAMAX( K-1, W( 1, KW ), 1 ) @@ -257,7 +277,7 @@ * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * -* Column K is zero: set INFO and continue +* Column K is zero or underflow: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K @@ -302,7 +322,7 @@ * KP = IMAX * -* copy column KW-1 of W to column KW +* copy column KW-1 of W to column KW of W * CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) ELSE @@ -314,60 +334,118 @@ KSTEP = 2 END IF END IF +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped * KK = K - KSTEP + 1 +* +* KKW is the column of W which corresponds to column KK of A +* KKW = NB + KK - N * -* Updated column KP is already stored in column KKW of W +* Interchange rows and columns KP and KK. +* Updated column KP is already stored in column KKW of W. * IF( KP.NE.KK ) THEN * -* Copy non-updated column KK to column KP +* Copy non-updated column KK to column KP of submatrix A +* at step K. No need to copy element into column K +* (or K and K-1 for 2-by-2 pivot) of A, since these columns +* will be later overwritten. * - A( KP, K ) = A( KK, K ) - CALL ZCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), + A( KP, KP ) = A( KK, KK ) + CALL ZCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), $ LDA ) - CALL ZCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 ) + IF( KP.GT.1 ) + $ CALL ZCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) * -* Interchange rows KK and KP in last KK columns of A and W +* Interchange rows KK and KP in last K+1 to N columns of A +* (columns K (or K and K-1 for 2-by-2 pivot) of A will be +* later overwritten). Interchange rows KK and KP +* in last KKW to NB columns of W. * - CALL ZSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA ) + IF( K.LT.N ) + $ CALL ZSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ), + $ LDA ) CALL ZSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), $ LDW ) END IF * IF( KSTEP.EQ.1 ) THEN * -* 1-by-1 pivot block D(k): column KW of W now holds +* 1-by-1 pivot block D(k): column kw of W now holds * -* W(k) = U(k)*D(k) +* W(kw) = U(k)*D(k), * * where U(k) is the k-th column of U * -* Store U(k) in column k of A +* Store subdiag. elements of column U(k) +* and 1-by-1 block D(k) in column k of A. +* NOTE: Diagonal element U(k,k) is a UNIT element +* and not stored. +* A(k,k) := D(k,k) = W(k,kw) +* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k) * CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) R1 = CONE / A( K, K ) CALL ZSCAL( K-1, R1, A( 1, K ), 1 ) +* ELSE * -* 2-by-2 pivot block D(k): columns KW and KW-1 of W now -* hold +* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold * -* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k) * * where U(k) and U(k-1) are the k-th and (k-1)-th columns * of U +* +* Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2 +* block D(k-1:k,k-1:k) in columns k-1 and k of A. +* NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT +* block and not stored. +* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw) +* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) = +* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) ) * IF( K.GT.2 ) THEN * -* Store U(k) and U(k-1) in columns k and k-1 of A +* Compose the columns of the inverse of 2-by-2 pivot +* block D in the following way to reduce the number +* of FLOPS when we myltiply panel ( W(kw-1) W(kw) ) by +* this inverse +* +* D**(-1) = ( d11 d21 )**(-1) = +* ( d21 d22 ) +* +* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = +* ( (-d21 ) ( d11 ) ) +* +* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * +* +* * ( ( d22/d21 ) ( -1 ) ) = +* ( ( -1 ) ( d11/d21 ) ) +* +* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = 1/d21 * T * ( ( D11 ) ( -1 ) ) +* ( ( -1 ) ( D22 ) ) +* +* = D21 * ( ( D11 ) ( -1 ) ) +* ( ( -1 ) ( D22 ) ) * D21 = W( K-1, KW ) D11 = W( K, KW ) / D21 D22 = W( K-1, KW-1 ) / D21 T = CONE / ( D11*D22-CONE ) D21 = T / D21 +* +* Update elements in columns A(k-1) and A(k) as +* dot products of rows of ( W(kw-1) W(kw) ) and columns +* of D**(-1) +* DO 20 J = 1, K - 2 A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) ) @@ -379,7 +457,9 @@ A( K-1, K-1 ) = W( K-1, KW-1 ) A( K-1, K ) = W( K-1, KW ) A( K, K ) = W( K, KW ) +* END IF +* END IF * * Store details of the interchanges in IPIV @@ -423,20 +503,28 @@ 50 CONTINUE * * Put U12 in standard form by partially undoing the interchanges -* in columns k+1:n +* in columns k+1:n looping backwards from k+1 to n * J = K + 1 60 CONTINUE - JJ = J - JP = IPIV( J ) - IF( JP.LT.0 ) THEN - JP = -JP +* +* Undo the interchanges (if any) of rows JJ and JP at each +* step J +* +* (Here, J is a diagonal index) + JJ = J + JP = IPIV( J ) + IF( JP.LT.0 ) THEN + JP = -JP +* (Here, J is a diagonal index) + J = J + 1 + END IF +* (NOTE: Here, J is used to determine row length. Length N-J+1 +* of the rows to swap back doesn't include diagonal element) J = J + 1 - END IF - J = J + 1 - IF( JP.NE.JJ .AND. J.LE.N ) - $ CALL ZSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA ) - IF( J.LE.N ) + IF( JP.NE.JJ .AND. J.LE.N ) + $ CALL ZSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA ) + IF( J.LT.N ) $ GO TO 60 * * Set KB to the number of columns factorized @@ -473,7 +561,7 @@ ABSAKK = CABS1( W( K, K ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value + * IF( K.LT.N ) THEN IMAX = K + IZAMAX( N-K, W( K+1, K ), 1 ) @@ -484,7 +572,7 @@ * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * -* Column K is zero: set INFO and continue +* Column K is zero or underflow: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K @@ -528,7 +616,7 @@ * KP = IMAX * -* copy column K+1 of W to column K +* copy column K+1 of W to column K of W * CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) ELSE @@ -540,22 +628,36 @@ KSTEP = 2 END IF END IF +* +* ============================================================ +* +* KK is the column of A where pivoting step stopped * KK = K + KSTEP - 1 * -* Updated column KP is already stored in column KK of W +* Interchange rows and columns KP and KK. +* Updated column KP is already stored in column KK of W. * IF( KP.NE.KK ) THEN * -* Copy non-updated column KK to column KP +* Copy non-updated column KK to column KP of submatrix A +* at step K. No need to copy element into column K +* (or K and K+1 for 2-by-2 pivot) of A, since these columns +* will be later overwritten. * - A( KP, K ) = A( KK, K ) - CALL ZCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA ) - CALL ZCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 ) + A( KP, KP ) = A( KK, KK ) + CALL ZCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ LDA ) + IF( KP.LT.N ) + $ CALL ZCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) * -* Interchange rows KK and KP in first KK columns of A and W +* Interchange rows KK and KP in first K-1 columns of A +* (columns K (or K and K+1 for 2-by-2 pivot) of A will be +* later overwritten). Interchange rows KK and KP +* in first KK columns of W. * - CALL ZSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) + IF( K.GT.1 ) + $ CALL ZSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) CALL ZSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) END IF * @@ -563,17 +665,23 @@ * * 1-by-1 pivot block D(k): column k of W now holds * -* W(k) = L(k)*D(k) +* W(k) = L(k)*D(k), * * where L(k) is the k-th column of L * -* Store L(k) in column k of A +* Store subdiag. elements of column L(k) +* and 1-by-1 block D(k) in column k of A. +* (NOTE: Diagonal element L(k,k) is a UNIT element +* and not stored) +* A(k,k) := D(k,k) = W(k,k) +* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k) * CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) IF( K.LT.N ) THEN R1 = CONE / A( K, K ) CALL ZSCAL( N-K, R1, A( K+1, K ), 1 ) END IF +* ELSE * * 2-by-2 pivot block D(k): columns k and k+1 of W now hold @@ -582,16 +690,52 @@ * * where L(k) and L(k+1) are the k-th and (k+1)-th columns * of L +* +* Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2 +* block D(k:k+1,k:k+1) in columns k and k+1 of A. +* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT +* block and not stored) +* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1) +* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) = +* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) ) * IF( K.LT.N-1 ) THEN * -* Store L(k) and L(k+1) in columns k and k+1 of A +* Compose the columns of the inverse of 2-by-2 pivot +* block D in the following way to reduce the number +* of FLOPS when we myltiply panel ( W(k) W(k+1) ) by +* this inverse +* +* D**(-1) = ( d11 d21 )**(-1) = +* ( d21 d22 ) +* +* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = +* ( (-d21 ) ( d11 ) ) +* +* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * +* +* * ( ( d22/d21 ) ( -1 ) ) = +* ( ( -1 ) ( d11/d21 ) ) +* +* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = +* ( ( -1 ) ( D22 ) ) +* +* = 1/d21 * T * ( ( D11 ) ( -1 ) ) +* ( ( -1 ) ( D22 ) ) +* +* = D21 * ( ( D11 ) ( -1 ) ) +* ( ( -1 ) ( D22 ) ) * D21 = W( K+1, K ) D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / D21 T = CONE / ( D11*D22-CONE ) D21 = T / D21 +* +* Update elements in columns A(k) and A(k+1) as +* dot products of rows of ( W(k) W(k+1) ) and columns +* of D**(-1) +* DO 80 J = K + 2, N A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) ) A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) @@ -603,7 +747,9 @@ A( K, K ) = W( K, K ) A( K+1, K ) = W( K+1, K ) A( K+1, K+1 ) = W( K+1, K+1 ) +* END IF +* END IF * * Store details of the interchanges in IPIV @@ -648,20 +794,28 @@ 110 CONTINUE * * Put L21 in standard form by partially undoing the interchanges -* in columns 1:k-1 +* of rows in columns 1:k-1 looping backwards from k-1 to 1 * J = K - 1 120 CONTINUE - JJ = J - JP = IPIV( J ) - IF( JP.LT.0 ) THEN - JP = -JP +* +* Undo the interchanges (if any) of rows JJ and JP at each +* step J +* +* (Here, J is a diagonal index) + JJ = J + JP = IPIV( J ) + IF( JP.LT.0 ) THEN + JP = -JP +* (Here, J is a diagonal index) + J = J - 1 + END IF +* (NOTE: Here, J is used to determine row length. Length J +* of the rows to swap back doesn't include diagonal element) J = J - 1 - END IF - J = J - 1 - IF( JP.NE.JJ .AND. J.GE.1 ) - $ CALL ZSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA ) - IF( J.GE.1 ) + IF( JP.NE.JJ .AND. J.GE.1 ) + $ CALL ZSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA ) + IF( J.GT.1 ) $ GO TO 120 * * Set KB to the number of columns factorized diff --git a/lapack-netlib/SRC/zlasyf_rook.f b/lapack-netlib/SRC/zlasyf_rook.f new file mode 100644 index 000000000..108c03e6b --- /dev/null +++ b/lapack-netlib/SRC/zlasyf_rook.f @@ -0,0 +1,900 @@ +*> \brief \b ZLASYF_ROOK computes a partial factorization of a complex symmetric matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLASYF_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), W( LDW, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLASYF_ROOK computes a partial factorization of a complex symmetric +*> matrix A using the bounded Bunch-Kaufman ("rook") diagonal +*> pivoting method. The partial factorization has the form: +*> +*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: +*> ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) +*> +*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L' +*> ( L21 I ) ( 0 A22 ) ( 0 I ) +*> +*> where the order of D is at most NB. The actual order is returned in +*> the argument KB, and is either NB or NB-1, or N if N <= NB. +*> +*> ZLASYF_ROOK is an auxiliary routine called by ZSYTRF_ROOK. It uses +*> blocked code (calling Level 3 BLAS) to update the submatrix +*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The maximum number of columns of the matrix A that should be +*> factored. NB should be at least 2 to allow for 2-by-2 pivot +*> blocks. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> The number of columns of A that were actually factored. +*> KB is either NB-1 or NB, or N if N <= NB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> n-by-n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading n-by-n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> On exit, A contains details of the partial factorization. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> Only the last KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> Only the first KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is COMPLEX*16 array, dimension (LDW,NB) +*> \endverbatim +*> +*> \param[in] LDW +*> \verbatim +*> LDW is INTEGER +*> The leading dimension of the array W. LDW >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex16SYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, + $ INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), W( LDW, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) + COMPLEX*16 CONE, CZERO + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), + $ CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL DONE + INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, JP1, JP2, K, KK, + $ KW, KKW, KP, KSTEP, P, II + DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, ROWMAX, DTEMP, SFMIN + COMPLEX*16 D11, D12, D21, D22, R1, T, Z +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, IZAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL ZCOPY, ZGEMM, ZGEMV, ZSCAL, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT, DIMAG, DBLE +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) ) +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = DLAMCH( 'S' ) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Factorize the trailing columns of A using the upper triangle +* of A and working backwards, and compute the matrix W = U12*D +* for use in updating A11 +* +* K is the main loop index, decreasing from N in steps of 1 or 2 +* + K = N + 10 CONTINUE +* +* KW is the column of W which corresponds to column K of A +* + KW = NB + K - N +* +* Exit from loop +* + IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) + $ GO TO 30 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column KW of W and update it +* + CALL ZCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 ) + IF( K.LT.N ) + $ CALL ZGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), + $ LDA, W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 ) +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = CABS1( W( K, KW ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = IZAMAX( K-1, W( 1, KW ), 1 ) + COLMAX = CABS1( W( IMAX, KW ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) + ELSE +* +* ============================================================ +* +* Test for interchange +* +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* Begin pivot search loop body +* +* +* Copy column IMAX to column KW-1 of W and update it +* + CALL ZCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 ) + CALL ZCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, + $ W( IMAX+1, KW-1 ), 1 ) +* + IF( K.LT.N ) + $ CALL ZGEMV( 'No transpose', K, N-K, -CONE, + $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW, + $ CONE, W( 1, KW-1 ), 1 ) +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + IZAMAX( K-IMAX, W( IMAX+1, KW-1 ), + $ 1 ) + ROWMAX = CABS1( W( JMAX, KW-1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = IZAMAX( IMAX-1, W( 1, KW-1 ), 1 ) + DTEMP = CABS1( W( ITEMP, KW-1 ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for +* CABS1( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.(CABS1( W( IMAX, KW-1 ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column KW-1 of W to column KW of W +* + CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K-1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) +* + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 12 +* + END IF +* +* ============================================================ +* + KK = K - KSTEP + 1 +* +* KKW is the column of W which corresponds to column KK of A +* + KKW = NB + KK - N +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P +* + CALL ZCOPY( K-P, A( P+1, K ), 1, A( P, P+1 ), LDA ) + CALL ZCOPY( P, A( 1, K ), 1, A( 1, P ), 1 ) +* +* Interchange rows K and P in last N-K+1 columns of A +* and last N-K+2 columns of W +* + CALL ZSWAP( N-K+1, A( K, K ), LDA, A( P, K ), LDA ) + CALL ZSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), LDW ) + END IF +* +* Updated column KP is already stored in column KKW of W +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP +* + A( KP, K ) = A( KK, K ) + CALL ZCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + CALL ZCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 ) +* +* Interchange rows KK and KP in last N-KK+1 columns +* of A and W +* + CALL ZSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA ) + CALL ZSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), + $ LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column KW of W now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* +* Store U(k) in column k of A +* + CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) + IF( K.GT.1 ) THEN + IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN + R1 = CONE / A( K, K ) + CALL ZSCAL( K-1, R1, A( 1, K ), 1 ) + ELSE IF( A( K, K ).NE.CZERO ) THEN + DO 14 II = 1, K - 1 + A( II, K ) = A( II, K ) / A( K, K ) + 14 CONTINUE + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns KW and KW-1 of W now +* hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* + IF( K.GT.2 ) THEN +* +* Store U(k) and U(k-1) in columns k and k-1 of A +* + D12 = W( K-1, KW ) + D11 = W( K, KW ) / D12 + D22 = W( K-1, KW-1 ) / D12 + T = CONE / ( D11*D22-CONE ) + DO 20 J = 1, K - 2 + A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) / + $ D12 ) + A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) / + $ D12 ) + 20 CONTINUE + END IF +* +* Copy D(k) to A +* + A( K-1, K-1 ) = W( K-1, KW-1 ) + A( K-1, K ) = W( K-1, KW ) + A( K, K ) = W( K, KW ) + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + 30 CONTINUE +* +* Update the upper triangle of A11 (= A(1:k,1:k)) as +* +* A11 := A11 - U12*D*U12**T = A11 - U12*W**T +* +* computing blocks of NB columns at a time +* + DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB + JB = MIN( NB, K-J+1 ) +* +* Update the upper triangle of the diagonal block +* + DO 40 JJ = J, J + JB - 1 + CALL ZGEMV( 'No transpose', JJ-J+1, N-K, -CONE, + $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE, + $ A( J, JJ ), 1 ) + 40 CONTINUE +* +* Update the rectangular superdiagonal block +* + IF( J.GE.2 ) + $ CALL ZGEMM( 'No transpose', 'Transpose', J-1, JB, + $ N-K, -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, + $ CONE, A( 1, J ), LDA ) + 50 CONTINUE +* +* Put U12 in standard form by partially undoing the interchanges +* in columns k+1:n +* + J = K + 1 + 60 CONTINUE +* + KSTEP = 1 + JP1 = 1 + JJ = J + JP2 = IPIV( J ) + IF( JP2.LT.0 ) THEN + JP2 = -JP2 + J = J + 1 + JP1 = -IPIV( J ) + KSTEP = 2 + END IF +* + J = J + 1 + IF( JP2.NE.JJ .AND. J.LE.N ) + $ CALL ZSWAP( N-J+1, A( JP2, J ), LDA, A( JJ, J ), LDA ) + JJ = J - 1 + IF( JP1.NE.JJ .AND. KSTEP.EQ.2 ) + $ CALL ZSWAP( N-J+1, A( JP1, J ), LDA, A( JJ, J ), LDA ) + IF( J.LE.N ) + $ GO TO 60 +* +* Set KB to the number of columns factorized +* + KB = N - K +* + ELSE +* +* Factorize the leading columns of A using the lower triangle +* of A and working forwards, and compute the matrix W = L21*D +* for use in updating A22 +* +* K is the main loop index, increasing from 1 in steps of 1 or 2 +* + K = 1 + 70 CONTINUE +* +* Exit from loop +* + IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) + $ GO TO 90 +* + KSTEP = 1 + P = K +* +* Copy column K of A to column K of W and update it +* + CALL ZCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 ) + IF( K.GT.1 ) + $ CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), + $ LDA, W( K, 1 ), LDW, CONE, W( K, K ), 1 ) +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = CABS1( W( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + IZAMAX( N-K, W( K+1, K ), 1 ) + COLMAX = CABS1( W( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) + ELSE +* +* ============================================================ +* +* Test for interchange +* +* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K +* + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 72 CONTINUE +* +* Begin pivot search loop body +* +* +* Copy column IMAX to column K+1 of W and update it +* + CALL ZCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1) + CALL ZCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, + $ W( IMAX, K+1 ), 1 ) + IF( K.GT.1 ) + $ CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, + $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW, + $ CONE, W( K, K+1 ), 1 ) +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + IZAMAX( IMAX-K, W( K, K+1 ), 1 ) + ROWMAX = CABS1( W( JMAX, K+1 ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + IZAMAX( N-IMAX, W( IMAX+1, K+1 ), 1) + DTEMP = CABS1( W( ITEMP, K+1 ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for +* CABS1( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX +* (used to handle NaN and Inf) +* + IF( .NOT.( CABS1( W( IMAX, K+1 ) ).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX +* +* copy column K+1 of W to column K of W +* + CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX.EQ.COLMAX, +* (used to handle NaN and Inf) +* + ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) ) + $ THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot not found: set params and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX +* +* Copy updated JMAXth (next IMAXth) column to Kth of W +* + CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) +* + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 72 +* + END IF +* +* ============================================================ +* + KK = K + KSTEP - 1 +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Copy non-updated column K to column P +* + CALL ZCOPY( P-K, A( K, K ), 1, A( P, K ), LDA ) + CALL ZCOPY( N-P+1, A( P, K ), 1, A( P, P ), 1 ) +* +* Interchange rows K and P in first K columns of A +* and first K+1 columns of W +* + CALL ZSWAP( K, A( K, 1 ), LDA, A( P, 1 ), LDA ) + CALL ZSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW ) + END IF +* +* Updated column KP is already stored in column KK of W +* + IF( KP.NE.KK ) THEN +* +* Copy non-updated column KK to column KP +* + A( KP, K ) = A( KK, K ) + CALL ZCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA ) + CALL ZCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 ) +* +* Interchange rows KK and KP in first KK columns of A and W +* + CALL ZSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) + CALL ZSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k of W now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* +* Store L(k) in column k of A +* + CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) + IF( K.LT.N ) THEN + IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN + R1 = CONE / A( K, K ) + CALL ZSCAL( N-K, R1, A( K+1, K ), 1 ) + ELSE IF( A( K, K ).NE.CZERO ) THEN + DO 74 II = K + 1, N + A( II, K ) = A( II, K ) / A( K, K ) + 74 CONTINUE + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 of W now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* + IF( K.LT.N-1 ) THEN +* +* Store L(k) and L(k+1) in columns k and k+1 of A +* + D21 = W( K+1, K ) + D11 = W( K+1, K+1 ) / D21 + D22 = W( K, K ) / D21 + T = CONE / ( D11*D22-CONE ) + DO 80 J = K + 2, N + A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) / + $ D21 ) + A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) / + $ D21 ) + 80 CONTINUE + END IF +* +* Copy D(k) to A +* + A( K, K ) = W( K, K ) + A( K+1, K ) = W( K+1, K ) + A( K+1, K+1 ) = W( K+1, K+1 ) + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 70 +* + 90 CONTINUE +* +* Update the lower triangle of A22 (= A(k:n,k:n)) as +* +* A22 := A22 - L21*D*L21**T = A22 - L21*W**T +* +* computing blocks of NB columns at a time +* + DO 110 J = K, N, NB + JB = MIN( NB, N-J+1 ) +* +* Update the lower triangle of the diagonal block +* + DO 100 JJ = J, J + JB - 1 + CALL ZGEMV( 'No transpose', J+JB-JJ, K-1, -CONE, + $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE, + $ A( JJ, JJ ), 1 ) + 100 CONTINUE +* +* Update the rectangular subdiagonal block +* + IF( J+JB.LE.N ) + $ CALL ZGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, + $ K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW, + $ CONE, A( J+JB, J ), LDA ) + 110 CONTINUE +* +* Put L21 in standard form by partially undoing the interchanges +* in columns 1:k-1 +* + J = K - 1 + 120 CONTINUE +* + KSTEP = 1 + JP1 = 1 + JJ = J + JP2 = IPIV( J ) + IF( JP2.LT.0 ) THEN + JP2 = -JP2 + J = J - 1 + JP1 = -IPIV( J ) + KSTEP = 2 + END IF +* + J = J - 1 + IF( JP2.NE.JJ .AND. J.GE.1 ) + $ CALL ZSWAP( J, A( JP2, 1 ), LDA, A( JJ, 1 ), LDA ) + JJ = J + 1 + IF( JP1.NE.JJ .AND. KSTEP.EQ.2 ) + $ CALL ZSWAP( J, A( JP1, 1 ), LDA, A( JJ, 1 ), LDA ) + IF( J.GE.1 ) + $ GO TO 120 +* +* Set KB to the number of columns factorized +* + KB = K - 1 +* + END IF + RETURN +* +* End of ZLASYF_ROOK +* + END diff --git a/lapack-netlib/SRC/zstemr.f b/lapack-netlib/SRC/zstemr.f index 5333951db..770706e58 100644 --- a/lapack-netlib/SRC/zstemr.f +++ b/lapack-netlib/SRC/zstemr.f @@ -311,7 +311,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup complex16OTHERcomputational * @@ -329,10 +329,10 @@ $ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, $ IWORK, LIWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE @@ -408,7 +408,8 @@ WU = ZERO IIL = 0 IIU = 0 - + NSPLIT = 0 + IF( VALEIG ) THEN * We do not reference VL, VU in the cases RANGE = 'I','A' * The interval (WL, WU] contains all the wanted eigenvalues. diff --git a/lapack-netlib/SRC/zsycon_rook.f b/lapack-netlib/SRC/zsycon_rook.f new file mode 100644 index 000000000..074eeab38 --- /dev/null +++ b/lapack-netlib/SRC/zsycon_rook.f @@ -0,0 +1,255 @@ +*> \brief \b ZSYCON_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZSYCON_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, +* WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSYCON_ROOK estimates the reciprocal of the condition number (in the +*> 1-norm) of a complex symmetric matrix A using the factorization +*> A = U*D*U**T or A = L*D*L**T computed by ZSYTRF_ROOK. +*> +*> An estimate is obtained for norm(inv(A)), and the reciprocal of the +*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by ZSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by ZSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] ANORM +*> \verbatim +*> ANORM is DOUBLE PRECISION +*> The 1-norm of the original matrix A. +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The reciprocal of the condition number of the matrix A, +*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an +*> estimate of the 1-norm of inv(A) computed in this routine. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup complex16SYcomputational +* +*> \par Contributors: +* ================== +*> \verbatim +*> +*> November 2011, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N + DOUBLE PRECISION ANORM, RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, KASE + DOUBLE PRECISION AINVNM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZLACN2, ZSYTRS_ROOK, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( ANORM.LT.ZERO ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZSYCON_ROOK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + RCOND = ZERO + IF( N.EQ.0 ) THEN + RCOND = ONE + RETURN + ELSE IF( ANORM.LE.ZERO ) THEN + RETURN + END IF +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO 10 I = N, 1, -1 + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.CZERO ) + $ RETURN + 10 CONTINUE + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO 20 I = 1, N + IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.CZERO ) + $ RETURN + 20 CONTINUE + END IF +* +* Estimate the 1-norm of the inverse. +* + KASE = 0 + 30 CONTINUE + CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN +* +* Multiply by inv(L*D*L**T) or inv(U*D*U**T). +* + CALL ZSYTRS_ROOK( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO ) + GO TO 30 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM.NE.ZERO ) + $ RCOND = ( ONE / AINVNM ) / ANORM +* + RETURN +* +* End of ZSYCON_ROOK +* + END diff --git a/lapack-netlib/SRC/zsysv_rook.f b/lapack-netlib/SRC/zsysv_rook.f new file mode 100644 index 000000000..9304a3d29 --- /dev/null +++ b/lapack-netlib/SRC/zsysv_rook.f @@ -0,0 +1,293 @@ +*> \brief ZSYSV_ROOK computes the solution to system of linear equations A * X = B for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZSYSV_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSYSV_ROOK computes the solution to a complex system of linear +*> equations +*> A * X = B, +*> where A is an N-by-N symmetric matrix and X and B are N-by-NRHS +*> matrices. +*> +*> The diagonal pivoting method is used to factor A as +*> A = U * D * U**T, if UPLO = 'U', or +*> A = L * D * L**T, if UPLO = 'L', +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and D is symmetric and block diagonal with +*> 1-by-1 and 2-by-2 diagonal blocks. +*> +*> ZSYTRF_ROOK is called to compute the factorization of a complex +*> symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal +*> pivoting method. +*> +*> The factored form of A is then used to solve the system +*> of equations A * X = B by calling ZSYTRS_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, the block diagonal matrix D and the +*> multipliers used to obtain the factor U or L from the +*> factorization A = U*D*U**T or A = L*D*L**T as computed by +*> ZSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, +*> as determined by ZSYTRF_ROOK. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= 1, and for best performance +*> LWORK >= max(1,N*NB), where NB is the optimal blocksize for +*> ZSYTRF_ROOK. +*> +*> TRS will be done with Level 2 BLAS +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, so the solution could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup complex16SYsolve +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2011, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZSYTRF_ROOK, ZSYTRS_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + CALL ZSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, -1, INFO ) + LWKOPT = WORK(1) + END IF + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZSYSV_ROOK ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = U*D*U**T or A = L*D*L**T. +* + CALL ZSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* +* Solve with TRS_ROOK ( Use Level 2 BLAS) +* + CALL ZSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of ZSYSV_ROOK +* + END diff --git a/lapack-netlib/SRC/zsytf2.f b/lapack-netlib/SRC/zsytf2.f index cf604ecfe..f244ba6b5 100644 --- a/lapack-netlib/SRC/zsytf2.f +++ b/lapack-netlib/SRC/zsytf2.f @@ -90,13 +90,22 @@ *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D. -*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were -*> interchanged and D(k,k) is a 1-by-1 diagonal block. -*> If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and -*> columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) -*> is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = -*> IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were -*> interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k-1) < 0, then rows and columns +*> k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) +*> is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) = IPIV(k+1) < 0, then rows and columns +*> k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1) +*> is a 2-by-2 diagonal block. *> \endverbatim *> *> \param[out] INFO @@ -118,7 +127,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup complex16SYcomputational * @@ -182,10 +191,10 @@ * ===================================================================== SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO ) * -* -- LAPACK computational routine (version 3.4.2) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER UPLO @@ -273,7 +282,8 @@ ABSAKK = CABS1( A( K, K ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. * IF( K.GT.1 ) THEN IMAX = IZAMAX( K-1, A( 1, K ), 1 ) @@ -284,7 +294,8 @@ * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO .OR. DISNAN(ABSAKK) ) THEN * -* Column K is zero or NaN: set INFO and continue +* Column K is zero or underflow, or contains a NaN: +* set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K @@ -441,7 +452,8 @@ ABSAKK = CABS1( A( K, K ) ) * * IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. * IF( K.LT.N ) THEN IMAX = K + IZAMAX( N-K, A( K+1, K ), 1 ) @@ -452,7 +464,8 @@ * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO .OR. DISNAN(ABSAKK) ) THEN * -* Column K is zero or NaN: set INFO and continue +* Column K is zero or underflow, or contains a NaN: +* set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K diff --git a/lapack-netlib/SRC/zsytf2_rook.f b/lapack-netlib/SRC/zsytf2_rook.f new file mode 100644 index 000000000..cf964ae8b --- /dev/null +++ b/lapack-netlib/SRC/zsytf2_rook.f @@ -0,0 +1,821 @@ +*> \brief \b ZSYTF2_ROOK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch-Kaufman ("rook") diagonal pivoting method (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZSYTF2_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSYTF2_ROOK computes the factorization of a complex symmetric matrix A +*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method: +*> +*> A = U*D*U**T or A = L*D*L**T +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, U**T is the transpose of U, and D is symmetric and +*> block diagonal with 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the unblocked version of the algorithm, calling Level 2 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> n-by-n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading n-by-n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, the block diagonal matrix D and the multipliers used +*> to obtain the factor U or L (see below for further details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> > 0: if INFO = k, D(k,k) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex16SYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', then A = U*D*U**T, where +*> U = P(n)*U(n)* ... *P(k)U(k)* ..., +*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to +*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I v 0 ) k-s +*> U(k) = ( 0 I 0 ) s +*> ( 0 0 I ) n-k +*> k-s s n-k +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). +*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), +*> and A(k,k), and v overwrites A(1:k-2,k-1:k). +*> +*> If UPLO = 'L', then A = L*D*L**T, where +*> L = P(1)*L(1)* ... *P(k)*L(k)* ..., +*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to +*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I 0 0 ) k-1 +*> L(k) = ( 0 I 0 ) s +*> ( 0 v I ) n-k-s+1 +*> k-1 s n-k-s+1 +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). +*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), +*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> 01-01-96 - Based on modifications by +*> J. Lewis, Boeing Computer Services Company +*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville abd , USA +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZSYTF2_ROOK( UPLO, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER, DONE + INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP, + $ P, II + DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, ROWMAX, DTEMP, SFMIN + COMPLEX*16 D11, D12, D21, D22, T, WK, WKM1, WKP1, Z +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, IZAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL ZSCAL, ZSWAP, ZSYR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT, DIMAG, DBLE +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZSYTF2_ROOK', -INFO ) + RETURN + END IF +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Compute machine safe minimum +* + SFMIN = DLAMCH( 'S' ) +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2 +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 70 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = CABS1( A( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.GT.1 ) THEN + IMAX = IZAMAX( K-1, A( 1, K ), 1 ) + COLMAX = CABS1( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + ELSE +* +* Test for interchange +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABSAKK.GE.ALPHA*COLMAX +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, +* use 1-by-1 pivot block +* + KP = K + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 12 CONTINUE +* +* Begin pivot search loop body +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = IMAX + IZAMAX( K-IMAX, A( IMAX, IMAX+1 ), + $ LDA ) + ROWMAX = CABS1( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.GT.1 ) THEN + ITEMP = IZAMAX( IMAX-1, A( 1, IMAX ), 1 ) + DTEMP = CABS1( A( ITEMP, IMAX ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for (used to handle NaN and Inf) +* CABS1( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX +* + IF( .NOT.( CABS1(A( IMAX, IMAX )).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX .EQ. COLMAX, +* used to handle NaN and Inf +* + ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot NOT found, set variables and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 12 +* + END IF +* +* Swap TWO rows and TWO columns +* +* First swap +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Interchange rows and column K and P in the leading +* submatrix A(1:k,1:k) if we have a 2-by-2 pivot +* + IF( P.GT.1 ) + $ CALL ZSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 ) + IF( P.LT.(K-1) ) + $ CALL ZSWAP( K-P-1, A( P+1, K ), 1, A( P, P+1 ), + $ LDA ) + T = A( K, K ) + A( K, K ) = A( P, P ) + A( P, P ) = T + END IF +* +* Second swap +* + KK = K - KSTEP + 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the leading +* submatrix A(1:k,1:k) +* + IF( KP.GT.1 ) + $ CALL ZSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) + IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) ) + $ CALL ZSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K-1, K ) + A( K-1, K ) = A( KP, K ) + A( KP, K ) = T + END IF + END IF +* +* Update the leading submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* + IF( K.GT.1 ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) and +* store U(k) in column k +* + IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(1:k-1,1:k-1) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*1/D(k)*W(k)**T +* + D11 = CONE / A( K, K ) + CALL ZSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) +* +* Store U(k) in column k +* + CALL ZSCAL( K-1, D11, A( 1, K ), 1 ) + ELSE +* +* Store L(k) in column K +* + D11 = A( K, K ) + DO 16 II = 1, K - 1 + A( II, K ) = A( II, K ) / D11 + 16 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - U(k)*D(k)*U(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL ZSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k-1 now hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* +* Perform a rank-2 update of A(1:k-2,1:k-2) as +* +* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T +* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.GT.2 ) THEN +* + D12 = A( K-1, K ) + D22 = A( K-1, K-1 ) / D12 + D11 = A( K, K ) / D12 + T = CONE / ( D11*D22-CONE ) +* + DO 30 J = K - 2, 1, -1 +* + WKM1 = T*( D11*A( J, K-1 )-A( J, K ) ) + WK = T*( D22*A( J, K )-A( J, K-1 ) ) +* + DO 20 I = J, 1, -1 + A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK - + $ ( A( I, K-1 ) / D12 )*WKM1 + 20 CONTINUE +* +* Store U(k) and U(k-1) in cols k and k-1 for row J +* + A( J, K ) = WK / D12 + A( J, K-1 ) = WKM1 / D12 +* + 30 CONTINUE +* + END IF +* + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2 +* + K = 1 + 40 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 70 + KSTEP = 1 + P = K +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = CABS1( A( K, K ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value. +* Determine both COLMAX and IMAX. +* + IF( K.LT.N ) THEN + IMAX = K + IZAMAX( N-K, A( K+1, K ), 1 ) + COLMAX = CABS1( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN +* +* Column K is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + ELSE +* +* Test for interchange +* +* Equivalent to testing for (used to handle NaN and Inf) +* ABSAKK.GE.ALPHA*COLMAX +* + IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K + ELSE +* + DONE = .FALSE. +* +* Loop until pivot found +* + 42 CONTINUE +* +* Begin pivot search loop body +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value. +* Determine both ROWMAX and JMAX. +* + IF( IMAX.NE.K ) THEN + JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), LDA ) + ROWMAX = CABS1( A( IMAX, JMAX ) ) + ELSE + ROWMAX = ZERO + END IF +* + IF( IMAX.LT.N ) THEN + ITEMP = IMAX + IZAMAX( N-IMAX, A( IMAX+1, IMAX ), + $ 1 ) + DTEMP = CABS1( A( ITEMP, IMAX ) ) + IF( DTEMP.GT.ROWMAX ) THEN + ROWMAX = DTEMP + JMAX = ITEMP + END IF + END IF +* +* Equivalent to testing for (used to handle NaN and Inf) +* CABS1( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX +* + IF( .NOT.( CABS1(A( IMAX, IMAX )).LT.ALPHA*ROWMAX ) ) + $ THEN +* +* interchange rows and columns K and IMAX, +* use 1-by-1 pivot block +* + KP = IMAX + DONE = .TRUE. +* +* Equivalent to testing for ROWMAX .EQ. COLMAX, +* used to handle NaN and Inf +* + ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN +* +* interchange rows and columns K+1 and IMAX, +* use 2-by-2 pivot block +* + KP = IMAX + KSTEP = 2 + DONE = .TRUE. + ELSE +* +* Pivot NOT found, set variables and repeat +* + P = IMAX + COLMAX = ROWMAX + IMAX = JMAX + END IF +* +* End pivot search loop body +* + IF( .NOT. DONE ) GOTO 42 +* + END IF +* +* Swap TWO rows and TWO columns +* +* First swap +* + IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN +* +* Interchange rows and column K and P in the trailing +* submatrix A(k:n,k:n) if we have a 2-by-2 pivot +* + IF( P.LT.N ) + $ CALL ZSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 ) + IF( P.GT.(K+1) ) + $ CALL ZSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA ) + T = A( K, K ) + A( K, K ) = A( P, P ) + A( P, P ) = T + END IF +* +* Second swap +* + KK = K + KSTEP - 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the trailing +* submatrix A(k:n,k:n) +* + IF( KP.LT.N ) + $ CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) ) + $ CALL ZSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K+1, K ) + A( K+1, K ) = A( KP, K ) + A( KP, K ) = T + END IF + END IF +* +* Update the trailing submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* + IF( K.LT.N ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) and +* store L(k) in column k +* + IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* + D11 = CONE / A( K, K ) + CALL ZSYR( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) +* +* Store L(k) in column k +* + CALL ZSCAL( N-K, D11, A( K+1, K ), 1 ) + ELSE +* +* Store L(k) in column k +* + D11 = A( K, K ) + DO 46 II = K + 1, N + A( II, K ) = A( II, K ) / D11 + 46 CONTINUE +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* A := A - L(k)*D(k)*L(k)**T +* = A - W(k)*(1/D(k))*W(k)**T +* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T +* + CALL ZSYR( UPLO, N-K, -D11, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) + END IF + END IF +* + ELSE +* +* 2-by-2 pivot block D(k): columns k and k+1 now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* +* +* Perform a rank-2 update of A(k+2:n,k+2:n) as +* +* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T +* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T +* +* and store L(k) and L(k+1) in columns k and k+1 +* + IF( K.LT.N-1 ) THEN +* + D21 = A( K+1, K ) + D11 = A( K+1, K+1 ) / D21 + D22 = A( K, K ) / D21 + T = CONE / ( D11*D22-CONE ) +* + DO 60 J = K + 2, N +* +* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J +* + WK = T*( D11*A( J, K )-A( J, K+1 ) ) + WKP1 = T*( D22*A( J, K+1 )-A( J, K ) ) +* +* Perform a rank-2 update of A(k+2:n,k+2:n) +* + DO 50 I = J, N + A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK - + $ ( A( I, K+1 ) / D21 )*WKP1 + 50 CONTINUE +* +* Store L(k) and L(k+1) in cols k and k+1 for row J +* + A( J, K ) = WK / D21 + A( J, K+1 ) = WKP1 / D21 +* + 60 CONTINUE +* + END IF +* + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -P + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + GO TO 40 +* + END IF +* + 70 CONTINUE +* + RETURN +* +* End of ZSYTF2_ROOK +* + END diff --git a/lapack-netlib/SRC/zsytrf_rook.f b/lapack-netlib/SRC/zsytrf_rook.f new file mode 100644 index 000000000..718a2815b --- /dev/null +++ b/lapack-netlib/SRC/zsytrf_rook.f @@ -0,0 +1,393 @@ +*> \brief \b ZSYTRF_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZSYTRF_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSYTRF_ROOK computes the factorization of a complex symmetric matrix A +*> using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. +*> The form of the factorization is +*> +*> A = U*D*U**T or A = L*D*L**T +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and D is symmetric and block diagonal with +*> 1-by-1 and 2-by-2 diagonal blocks. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the symmetric matrix A. If UPLO = 'U', the leading +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the strictly lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> leading N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the strictly upper +*> triangular part of A is not referenced. +*> +*> On exit, the block diagonal matrix D and the multipliers used +*> to obtain the factor U or L (see below for further details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)). +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >=1. For best performance +*> LWORK >= N*NB, where NB is the block size returned by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup complex16SYcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', then A = U*D*U**T, where +*> U = P(n)*U(n)* ... *P(k)U(k)* ..., +*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to +*> 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and U(k) is a unit upper triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I v 0 ) k-s +*> U(k) = ( 0 I 0 ) s +*> ( 0 0 I ) n-k +*> k-s s n-k +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). +*> If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), +*> and A(k,k), and v overwrites A(1:k-2,k-1:k). +*> +*> If UPLO = 'L', then A = L*D*L**T, where +*> L = P(1)*L(1)* ... *P(k)*L(k)* ..., +*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to +*> n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +*> and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +*> defined by IPIV(k), and L(k) is a unit lower triangular matrix, such +*> that if the diagonal block D(k) is of order s (s = 1 or 2), then +*> +*> ( I 0 0 ) k-1 +*> L(k) = ( 0 I 0 ) s +*> ( 0 v I ) n-k-s+1 +*> k-1 s n-k-s+1 +*> +*> If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). +*> If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), +*> and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2011, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL ZLASYF_ROOK, ZSYTF2_ROOK, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size +* + NB = ILAENV( 1, 'ZSYTRF_ROOK', UPLO, N, -1, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZSYTRF_ROOK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* + NBMIN = 2 + LDWORK = N + IF( NB.GT.1 .AND. NB.LT.N ) THEN + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN + NB = MAX( LWORK / LDWORK, 1 ) + NBMIN = MAX( 2, ILAENV( 2, 'ZSYTRF_ROOK', + $ UPLO, N, -1, -1, -1 ) ) + END IF + ELSE + IWS = 1 + END IF + IF( NB.LT.NBMIN ) + $ NB = N +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* KB, where KB is the number of columns factorized by ZLASYF_ROOK; +* KB is either NB or NB-1, or K for the last block +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 40 +* + IF( K.GT.NB ) THEN +* +* Factorize columns k-kb+1:k of A and use blocked code to +* update columns 1:k-kb +* + CALL ZLASYF_ROOK( UPLO, K, NB, KB, A, LDA, + $ IPIV, WORK, LDWORK, IINFO ) + ELSE +* +* Use unblocked code to factorize columns 1:k of A +* + CALL ZSYTF2_ROOK( UPLO, K, A, LDA, IPIV, IINFO ) + KB = K + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO +* +* No need to adjust IPIV +* +* Decrease K and return to the start of the main loop +* + K = K - KB + GO TO 10 +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* KB, where KB is the number of columns factorized by ZLASYF_ROOK; +* KB is either NB or NB-1, or N-K+1 for the last block +* + K = 1 + 20 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 40 +* + IF( K.LE.N-NB ) THEN +* +* Factorize columns k:k+kb-1 of A and use blocked code to +* update columns k+kb:n +* + CALL ZLASYF_ROOK( UPLO, N-K+1, NB, KB, A( K, K ), LDA, + $ IPIV( K ), WORK, LDWORK, IINFO ) + ELSE +* +* Use unblocked code to factorize columns k:n of A +* + CALL ZSYTF2_ROOK( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), + $ IINFO ) + KB = N - K + 1 + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + K - 1 +* +* Adjust IPIV +* + DO 30 J = K, K + KB - 1 + IF( IPIV( J ).GT.0 ) THEN + IPIV( J ) = IPIV( J ) + K - 1 + ELSE + IPIV( J ) = IPIV( J ) - K + 1 + END IF + 30 CONTINUE +* +* Increase K and return to the start of the main loop +* + K = K + KB + GO TO 20 +* + END IF +* + 40 CONTINUE + WORK( 1 ) = LWKOPT + RETURN +* +* End of ZSYTRF_ROOK +* + END diff --git a/lapack-netlib/SRC/zsytri_rook.f b/lapack-netlib/SRC/zsytri_rook.f new file mode 100644 index 000000000..5a9631e8e --- /dev/null +++ b/lapack-netlib/SRC/zsytri_rook.f @@ -0,0 +1,451 @@ +*> \brief \b ZSYTRI_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZSYTRI_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSYTRI_ROOK computes the inverse of a complex symmetric +*> matrix A using the factorization A = U*D*U**T or A = L*D*L**T +*> computed by ZSYTRF_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the block diagonal matrix D and the multipliers +*> used to obtain the factor U or L as computed by ZSYTRF_ROOK. +*> +*> On exit, if INFO = 0, the (symmetric) inverse of the original +*> matrix. If UPLO = 'U', the upper triangular part of the +*> inverse is formed and the part of A below the diagonal is not +*> referenced; if UPLO = 'L' the lower triangular part of the +*> inverse is formed and the part of A above the diagonal is +*> not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by ZSYTRF_ROOK. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup complex16SYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2011, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 CONE, CZERO + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), + $ CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER K, KP, KSTEP + COMPLEX*16 AK, AKKP1, AKP1, D, T, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME + COMPLEX*16 ZDOTU + EXTERNAL LSAME, ZDOTU +* .. +* .. External Subroutines .. + EXTERNAL ZCOPY, ZSWAP, ZSYMV, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZSYTRI_ROOK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO 10 INFO = N, 1, -1 + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO ) + $ RETURN + 10 CONTINUE + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO 20 INFO = 1, N + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO ) + $ RETURN + 20 CONTINUE + END IF + INFO = 0 +* + IF( UPPER ) THEN +* +* Compute inv(A) from the factorization A = U*D*U**T. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + 30 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 40 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Invert the diagonal block. +* + A( K, K ) = CONE / A( K, K ) +* +* Compute column K of the inverse. +* + IF( K.GT.1 ) THEN + CALL ZCOPY( K-1, A( 1, K ), 1, WORK, 1 ) + CALL ZSYMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO, + $ A( 1, K ), 1 ) + A( K, K ) = A( K, K ) - ZDOTU( K-1, WORK, 1, A( 1, K ), + $ 1 ) + END IF + KSTEP = 1 + ELSE +* +* 2 x 2 diagonal block +* +* Invert the diagonal block. +* + T = A( K, K+1 ) + AK = A( K, K ) / T + AKP1 = A( K+1, K+1 ) / T + AKKP1 = A( K, K+1 ) / T + D = T*( AK*AKP1-CONE ) + A( K, K ) = AKP1 / D + A( K+1, K+1 ) = AK / D + A( K, K+1 ) = -AKKP1 / D +* +* Compute columns K and K+1 of the inverse. +* + IF( K.GT.1 ) THEN + CALL ZCOPY( K-1, A( 1, K ), 1, WORK, 1 ) + CALL ZSYMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO, + $ A( 1, K ), 1 ) + A( K, K ) = A( K, K ) - ZDOTU( K-1, WORK, 1, A( 1, K ), + $ 1 ) + A( K, K+1 ) = A( K, K+1 ) - + $ ZDOTU( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 ) + CALL ZCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 ) + CALL ZSYMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, CZERO, + $ A( 1, K+1 ), 1 ) + A( K+1, K+1 ) = A( K+1, K+1 ) - + $ ZDOTU( K-1, WORK, 1, A( 1, K+1 ), 1 ) + END IF + KSTEP = 2 + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* Interchange rows and columns K and IPIV(K) in the leading +* submatrix A(1:k+1,1:k+1) +* + KP = IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.GT.1 ) + $ CALL ZSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) + CALL ZSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + ELSE +* +* Interchange rows and columns K and K+1 with -IPIV(K) and +* -IPIV(K+1)in the leading submatrix A(1:k+1,1:k+1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.GT.1 ) + $ CALL ZSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) + CALL ZSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) +* + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + TEMP = A( K, K+1 ) + A( K, K+1 ) = A( KP, K+1 ) + A( KP, K+1 ) = TEMP + END IF +* + K = K + 1 + KP = -IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.GT.1 ) + $ CALL ZSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) + CALL ZSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + END IF +* + K = K + 1 + GO TO 30 + 40 CONTINUE +* + ELSE +* +* Compute inv(A) from the factorization A = L*D*L**T. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = N + 50 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 60 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Invert the diagonal block. +* + A( K, K ) = CONE / A( K, K ) +* +* Compute column K of the inverse. +* + IF( K.LT.N ) THEN + CALL ZCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) + CALL ZSYMV( UPLO, N-K,-CONE, A( K+1, K+1 ), LDA, WORK, 1, + $ CZERO, A( K+1, K ), 1 ) + A( K, K ) = A( K, K ) - ZDOTU( N-K, WORK, 1, A( K+1, K ), + $ 1 ) + END IF + KSTEP = 1 + ELSE +* +* 2 x 2 diagonal block +* +* Invert the diagonal block. +* + T = A( K, K-1 ) + AK = A( K-1, K-1 ) / T + AKP1 = A( K, K ) / T + AKKP1 = A( K, K-1 ) / T + D = T*( AK*AKP1-CONE ) + A( K-1, K-1 ) = AKP1 / D + A( K, K ) = AK / D + A( K, K-1 ) = -AKKP1 / D +* +* Compute columns K-1 and K of the inverse. +* + IF( K.LT.N ) THEN + CALL ZCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) + CALL ZSYMV( UPLO, N-K,-CONE, A( K+1, K+1 ), LDA, WORK, 1, + $ CZERO, A( K+1, K ), 1 ) + A( K, K ) = A( K, K ) - ZDOTU( N-K, WORK, 1, A( K+1, K ), + $ 1 ) + A( K, K-1 ) = A( K, K-1 ) - + $ ZDOTU( N-K, A( K+1, K ), 1, A( K+1, K-1 ), + $ 1 ) + CALL ZCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 ) + CALL ZSYMV( UPLO, N-K,-CONE, A( K+1, K+1 ), LDA, WORK, 1, + $ CZERO, A( K+1, K-1 ), 1 ) + A( K-1, K-1 ) = A( K-1, K-1 ) - + $ ZDOTU( N-K, WORK, 1, A( K+1, K-1 ), 1 ) + END IF + KSTEP = 2 + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* Interchange rows and columns K and IPIV(K) in the trailing +* submatrix A(k-1:n,k-1:n) +* + KP = IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.LT.N ) + $ CALL ZSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) + CALL ZSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA ) + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + ELSE +* +* Interchange rows and columns K and K-1 with -IPIV(K) and +* -IPIV(K-1) in the trailing submatrix A(k-1:n,k-1:n) +* + KP = -IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.LT.N ) + $ CALL ZSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) + CALL ZSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA ) +* + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + TEMP = A( K, K-1 ) + A( K, K-1 ) = A( KP, K-1 ) + A( KP, K-1 ) = TEMP + END IF +* + K = K - 1 + KP = -IPIV( K ) + IF( KP.NE.K ) THEN + IF( KP.LT.N ) + $ CALL ZSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) + CALL ZSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA ) + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + END IF + END IF +* + K = K - 1 + GO TO 50 + 60 CONTINUE + END IF +* + RETURN +* +* End of ZSYTRI_ROOK +* + END diff --git a/lapack-netlib/SRC/zsytrs_rook.f b/lapack-netlib/SRC/zsytrs_rook.f new file mode 100644 index 000000000..a68abdb83 --- /dev/null +++ b/lapack-netlib/SRC/zsytrs_rook.f @@ -0,0 +1,484 @@ +*> \brief \b ZSYTRS_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZSYTRS_ROOK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSYTRS_ROOK solves a system of linear equations A*X = B with +*> a complex symmetric matrix A using the factorization A = U*D*U**T or +*> A = L*D*L**T computed by ZSYTRF_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by ZSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by ZSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2011 +* +*> \ingroup complex16SYcomputational +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2011, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, +*> School of Mathematics, +*> University of Manchester +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + $ INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J, K, KP + COMPLEX*16 AK, AKM1, AKM1K, BK, BKM1, DENOM +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZGEMV, ZGERU, ZSCAL, ZSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZSYTRS_ROOK', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Solve A*X = B, where A = U*D*U**T. +* +* First solve U*D*X = B, overwriting B with X. +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 30 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(U(K)), where U(K) is the transformation +* stored in column K of A. +* + CALL ZGERU( K-1, NRHS, -CONE, A( 1, K ), 1, B( K, 1 ), LDB, + $ B( 1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + CALL ZSCAL( NRHS, CONE / A( K, K ), B( K, 1 ), LDB ) + K = K - 1 + ELSE +* +* 2 x 2 diagonal block +* +* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K-1 ) + IF( KP.NE.K-1 ) + $ CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(U(K)), where U(K) is the transformation +* stored in columns K-1 and K of A. +* + IF( K.GT.2 ) THEN + CALL ZGERU( K-2, NRHS,-CONE, A( 1, K ), 1, B( K, 1 ), + $ LDB, B( 1, 1 ), LDB ) + CALL ZGERU( K-2, NRHS,-CONE, A( 1, K-1 ), 1, B( K-1, 1 ), + $ LDB, B( 1, 1 ), LDB ) + END IF +* +* Multiply by the inverse of the diagonal block. +* + AKM1K = A( K-1, K ) + AKM1 = A( K-1, K-1 ) / AKM1K + AK = A( K, K ) / AKM1K + DENOM = AKM1*AK - CONE + DO 20 J = 1, NRHS + BKM1 = B( K-1, J ) / AKM1K + BK = B( K, J ) / AKM1K + B( K-1, J ) = ( AK*BKM1-BK ) / DENOM + B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM + 20 CONTINUE + K = K - 2 + END IF +* + GO TO 10 + 30 CONTINUE +* +* Next solve U**T *X = B, overwriting B with X. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + 40 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 50 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Multiply by inv(U**T(K)), where U(K) is the transformation +* stored in column K of A. +* + IF( K.GT.1 ) + $ CALL ZGEMV( 'Transpose', K-1, NRHS, -CONE, B, + $ LDB, A( 1, K ), 1, CONE, B( K, 1 ), LDB ) +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K + 1 + ELSE +* +* 2 x 2 diagonal block +* +* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation +* stored in columns K and K+1 of A. +* + IF( K.GT.1 ) THEN + CALL ZGEMV( 'Transpose', K-1, NRHS, -CONE, B, + $ LDB, A( 1, K ), 1, CONE, B( K, 1 ), LDB ) + CALL ZGEMV( 'Transpose', K-1, NRHS, -CONE, B, + $ LDB, A( 1, K+1 ), 1, CONE, B( K+1, 1 ), LDB ) + END IF +* +* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1). +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K+1 ) + IF( KP.NE.K+1 ) + $ CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) +* + K = K + 2 + END IF +* + GO TO 40 + 50 CONTINUE +* + ELSE +* +* Solve A*X = B, where A = L*D*L**T. +* +* First solve L*D*X = B, overwriting B with X. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + 60 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 80 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(L(K)), where L(K) is the transformation +* stored in column K of A. +* + IF( K.LT.N ) + $ CALL ZGERU( N-K, NRHS, -CONE, A( K+1, K ), 1, B( K, 1 ), + $ LDB, B( K+1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + CALL ZSCAL( NRHS, CONE / A( K, K ), B( K, 1 ), LDB ) + K = K + 1 + ELSE +* +* 2 x 2 diagonal block +* +* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K+1 ) + IF( KP.NE.K+1 ) + $ CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Multiply by inv(L(K)), where L(K) is the transformation +* stored in columns K and K+1 of A. +* + IF( K.LT.N-1 ) THEN + CALL ZGERU( N-K-1, NRHS,-CONE, A( K+2, K ), 1, B( K, 1 ), + $ LDB, B( K+2, 1 ), LDB ) + CALL ZGERU( N-K-1, NRHS,-CONE, A( K+2, K+1 ), 1, + $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) + END IF +* +* Multiply by the inverse of the diagonal block. +* + AKM1K = A( K+1, K ) + AKM1 = A( K, K ) / AKM1K + AK = A( K+1, K+1 ) / AKM1K + DENOM = AKM1*AK - CONE + DO 70 J = 1, NRHS + BKM1 = B( K, J ) / AKM1K + BK = B( K+1, J ) / AKM1K + B( K, J ) = ( AK*BKM1-BK ) / DENOM + B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM + 70 CONTINUE + K = K + 2 + END IF +* + GO TO 60 + 80 CONTINUE +* +* Next solve L**T *X = B, overwriting B with X. +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = N + 90 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 100 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Multiply by inv(L**T(K)), where L(K) is the transformation +* stored in column K of A. +* + IF( K.LT.N ) + $ CALL ZGEMV( 'Transpose', N-K, NRHS, -CONE, B( K+1, 1 ), + $ LDB, A( K+1, K ), 1, CONE, B( K, 1 ), LDB ) +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K - 1 + ELSE +* +* 2 x 2 diagonal block +* +* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation +* stored in columns K-1 and K of A. +* + IF( K.LT.N ) THEN + CALL ZGEMV( 'Transpose', N-K, NRHS, -CONE, B( K+1, 1 ), + $ LDB, A( K+1, K ), 1, CONE, B( K, 1 ), LDB ) + CALL ZGEMV( 'Transpose', N-K, NRHS, -CONE, B( K+1, 1 ), + $ LDB, A( K+1, K-1 ), 1, CONE, B( K-1, 1 ), + $ LDB ) + END IF +* +* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1) +* + KP = -IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* + KP = -IPIV( K-1 ) + IF( KP.NE.K-1 ) + $ CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) +* + K = K - 2 + END IF +* + GO TO 90 + 100 CONTINUE + END IF +* + RETURN +* +* End of ZSYTRS_ROOK +* + END diff --git a/lapack-netlib/SRC/ztpmqrt.f b/lapack-netlib/SRC/ztpmqrt.f index 684f6d938..87ae54172 100644 --- a/lapack-netlib/SRC/ztpmqrt.f +++ b/lapack-netlib/SRC/ztpmqrt.f @@ -175,7 +175,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup complex16OTHERcomputational * @@ -216,10 +216,10 @@ SUBROUTINE ZTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, $ A, LDA, B, LDB, WORK, INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS @@ -235,7 +235,7 @@ * .. * .. Local Scalars .. LOGICAL LEFT, RIGHT, TRAN, NOTRAN - INTEGER I, IB, MB, LB, KF, Q + INTEGER I, IB, MB, LB, KF, LDAQ, LDVQ * .. * .. External Functions .. LOGICAL LSAME @@ -257,10 +257,12 @@ TRAN = LSAME( TRANS, 'C' ) NOTRAN = LSAME( TRANS, 'N' ) * - IF( LEFT ) THEN - Q = M + IF ( LEFT ) THEN + LDVQ = MAX( 1, M ) + LDAQ = MAX( 1, K ) ELSE IF ( RIGHT ) THEN - Q = N + LDVQ = MAX( 1, N ) + LDAQ = MAX( 1, M ) END IF IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN INFO = -1 @@ -274,13 +276,13 @@ INFO = -5 ELSE IF( L.LT.0 .OR. L.GT.K ) THEN INFO = -6 - ELSE IF( NB.LT.1 .OR. NB.GT.K ) THEN + ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0) ) THEN INFO = -7 - ELSE IF( LDV.LT.MAX( 1, Q ) ) THEN + ELSE IF( LDV.LT.LDVQ ) THEN INFO = -9 ELSE IF( LDT.LT.NB ) THEN INFO = -11 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + ELSE IF( LDA.LT.LDAQ ) THEN INFO = -13 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -15 diff --git a/lapack-netlib/SRC/ztpqrt.f b/lapack-netlib/SRC/ztpqrt.f index ac15f83bc..05fc88448 100644 --- a/lapack-netlib/SRC/ztpqrt.f +++ b/lapack-netlib/SRC/ztpqrt.f @@ -132,7 +132,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup complex16OTHERcomputational * @@ -189,10 +189,10 @@ SUBROUTINE ZTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, $ INFO ) * -* -- LAPACK computational routine (version 3.4.1) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDT, N, M, L, NB @@ -219,9 +219,9 @@ INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 - ELSE IF( L.LT.0 .OR. L.GT.MIN(M,N) ) THEN + ELSE IF( L.LT.0 .OR. (L.GT.MIN(M,N) .AND. MIN(M,N).GE.0)) THEN INFO = -3 - ELSE IF( NB.LT.1 .OR. NB.GT.N ) THEN + ELSE IF( NB.LT.1 .OR. (NB.GT.N .AND. N.GT.0)) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 diff --git a/lapack-netlib/SRC/zunbdb.f b/lapack-netlib/SRC/zunbdb.f index 24555401b..618c0a0d4 100644 --- a/lapack-netlib/SRC/zunbdb.f +++ b/lapack-netlib/SRC/zunbdb.f @@ -255,7 +255,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex16OTHERcomputational * @@ -287,10 +287,10 @@ $ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, $ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER SIGNS, TRANS @@ -314,7 +314,7 @@ * .. * .. Local Scalars .. LOGICAL COLMAJOR, LQUERY - INTEGER I, LWORKMIN, LWORKOPT + INTEGER I, LWORKMIN, LWORKOPT, PI1, QI1 DOUBLE PRECISION Z1, Z2, Z3, Z4 * .. * .. External Subroutines .. @@ -420,19 +420,33 @@ THETA(I) = ATAN2( DZNRM2( M-P-I+1, X21(I,I), 1 ), $ DZNRM2( P-I+1, X11(I,I), 1 ) ) * - CALL ZLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + IF( P .GT. I ) THEN + CALL ZLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + ELSE IF ( P .EQ. I ) THEN + CALL ZLARFGP( P-I+1, X11(I,I), X11(I,I), 1, TAUP1(I) ) + END IF X11(I,I) = ONE - CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + IF ( M-P .GT. I ) THEN + CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, + $ TAUP2(I) ) + ELSE IF ( M-P .EQ. I ) THEN + CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1, + $ TAUP2(I) ) + END IF X21(I,I) = ONE * - CALL ZLARF( 'L', P-I+1, Q-I, X11(I,I), 1, DCONJG(TAUP1(I)), - $ X11(I,I+1), LDX11, WORK ) - CALL ZLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, - $ DCONJG(TAUP1(I)), X12(I,I), LDX12, WORK ) - CALL ZLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, - $ DCONJG(TAUP2(I)), X21(I,I+1), LDX21, WORK ) - CALL ZLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, - $ DCONJG(TAUP2(I)), X22(I,I), LDX22, WORK ) + IF ( Q .GT. I ) THEN + CALL ZLARF( 'L', P-I+1, Q-I, X11(I,I), 1, + $ DCONJG(TAUP1(I)), X11(I,I+1), LDX11, WORK ) + CALL ZLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, + $ DCONJG(TAUP2(I)), X21(I,I+1), LDX21, WORK ) + END IF + IF ( M-Q+1 .GT. I ) THEN + CALL ZLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, + $ DCONJG(TAUP1(I)), X12(I,I), LDX12, WORK ) + CALL ZLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, + $ DCONJG(TAUP2(I)), X22(I,I), LDX22, WORK ) + END IF * IF( I .LT. Q ) THEN CALL ZSCAL( Q-I, DCMPLX( -Z1*Z3*SIN(THETA(I)), 0.0D0 ), @@ -451,13 +465,25 @@ * IF( I .LT. Q ) THEN CALL ZLACGV( Q-I, X11(I,I+1), LDX11 ) - CALL ZLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11, - $ TAUQ1(I) ) + IF ( I .EQ. Q-1 ) THEN + CALL ZLARFGP( Q-I, X11(I,I+1), X11(I,I+1), LDX11, + $ TAUQ1(I) ) + ELSE + CALL ZLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11, + $ TAUQ1(I) ) + END IF X11(I,I+1) = ONE END IF - CALL ZLACGV( M-Q-I+1, X12(I,I), LDX12 ) - CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, - $ TAUQ2(I) ) + IF ( M-Q+1 .GT. I ) THEN + CALL ZLACGV( M-Q-I+1, X12(I,I), LDX12 ) + IF ( M-Q .EQ. I ) THEN + CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12, + $ TAUQ2(I) ) + ELSE + CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, + $ TAUQ2(I) ) + END IF + END IF X12(I,I) = ONE * IF( I .LT. Q ) THEN @@ -466,10 +492,14 @@ CALL ZLARF( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I), $ X21(I+1,I+1), LDX21, WORK ) END IF - CALL ZLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), - $ X12(I+1,I), LDX12, WORK ) - CALL ZLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), - $ X22(I+1,I), LDX22, WORK ) + IF ( P .GT. I ) THEN + CALL ZLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), + $ X12(I+1,I), LDX12, WORK ) + END IF + IF ( M-P .GT. I ) THEN + CALL ZLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), X22(I+1,I), LDX22, WORK ) + END IF * IF( I .LT. Q ) $ CALL ZLACGV( Q-I, X11(I,I+1), LDX11 ) @@ -484,12 +514,19 @@ CALL ZSCAL( M-Q-I+1, DCMPLX( -Z1*Z4, 0.0D0 ), X12(I,I), $ LDX12 ) CALL ZLACGV( M-Q-I+1, X12(I,I), LDX12 ) - CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, - $ TAUQ2(I) ) + IF ( I .GE. M-Q ) THEN + CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12, + $ TAUQ2(I) ) + ELSE + CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, + $ TAUQ2(I) ) + END IF X12(I,I) = ONE * - CALL ZLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), - $ X12(I+1,I), LDX12, WORK ) + IF ( P .GT. I ) THEN + CALL ZLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), + $ X12(I+1,I), LDX12, WORK ) + END IF IF( M-P-Q .GE. 1 ) $ CALL ZLARF( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12, $ TAUQ2(I), X22(Q+1,I), LDX22, WORK ) @@ -548,8 +585,13 @@ * CALL ZLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, TAUP1(I) ) X11(I,I) = ONE - CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21, - $ TAUP2(I) ) + IF ( I .EQ. M-P ) THEN + CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I,I), LDX21, + $ TAUP2(I) ) + ELSE + CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21, + $ TAUP2(I) ) + END IF X21(I,I) = ONE * CALL ZLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I), @@ -594,8 +636,10 @@ END IF CALL ZLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, $ DCONJG(TAUQ2(I)), X12(I,I+1), LDX12, WORK ) - CALL ZLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, - $ DCONJG(TAUQ2(I)), X22(I,I+1), LDX22, WORK ) + IF ( M-P .GT. I ) THEN + CALL ZLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, + $ DCONJG(TAUQ2(I)), X22(I,I+1), LDX22, WORK ) + END IF * END DO * @@ -607,8 +651,10 @@ CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) ) X12(I,I) = ONE * - CALL ZLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, - $ DCONJG(TAUQ2(I)), X12(I,I+1), LDX12, WORK ) + IF ( P .GT. I ) THEN + CALL ZLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, + $ DCONJG(TAUQ2(I)), X12(I,I+1), LDX12, WORK ) + END IF IF( M-P-Q .GE. 1 ) $ CALL ZLARF( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1, $ DCONJG(TAUQ2(I)), X22(I,Q+1), LDX22, WORK ) @@ -625,9 +671,11 @@ $ TAUQ2(P+I) ) X22(P+I,Q+I) = ONE * - CALL ZLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1, - $ DCONJG(TAUQ2(P+I)), X22(P+I,Q+I+1), LDX22, - $ WORK ) + IF ( M-P-Q .NE. I ) THEN + CALL ZLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1, + $ DCONJG(TAUQ2(P+I)), X22(P+I,Q+I+1), LDX22, + $ WORK ) + END IF * END DO * diff --git a/lapack-netlib/SRC/zunbdb1.f b/lapack-netlib/SRC/zunbdb1.f new file mode 100644 index 000000000..4125450c7 --- /dev/null +++ b/lapack-netlib/SRC/zunbdb1.f @@ -0,0 +1,328 @@ +*> \brief \b ZUNBDB1 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZUNBDB1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION PHI(*), THETA(*) +* COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> ZUNBDB1 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonomal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. Q must be no larger than P, +*> M-P, or M-Q. Routines ZUNBDB2, ZUNBDB3, and ZUNBDB4 handle cases in +*> which Q is not the minimum dimension. +*> +*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are Q-by-Q bidiagonal matrices represented implicitly by +*> angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= +*> MIN(P,M-P,M-Q). +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is COMPLEX*16 array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is COMPLEX*16 array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is COMPLEX*16 array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is COMPLEX*16 array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is COMPLEX*16 array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +*> +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup complex16OTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or ZUNCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See ZUNCSD2BY1 for details on generating P1, P2, and Q1 using ZUNGQR +*> and ZUNGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE ZUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + DOUBLE PRECISION PHI(*), THETA(*) + COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = (1.0D0,0.0D0) ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, + $ LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL ZLARF, ZLARFGP, ZUNBDB5, ZDROT, XERBLA + EXTERNAL ZLACGV +* .. +* .. External Functions .. + DOUBLE PRECISION DZNRM2 + EXTERNAL DZNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( P .LT. Q .OR. M-P .LT. Q ) THEN + INFO = -2 + ELSE IF( Q .LT. 0 .OR. M-Q .LT. Q ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( P-1, M-P-1, Q-1 ) + IORBDB5 = 2 + LORBDB5 = Q-2 + LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'ZUNBDB1', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce columns 1, ..., Q of X11 and X21 +* + DO I = 1, Q +* + CALL ZLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + THETA(I) = ATAN2( DBLE( X21(I,I) ), DBLE( X11(I,I) ) ) + C = COS( THETA(I) ) + S = SIN( THETA(I) ) + X11(I,I) = ONE + X21(I,I) = ONE + CALL ZLARF( 'L', P-I+1, Q-I, X11(I,I), 1, DCONJG(TAUP1(I)), + $ X11(I,I+1), LDX11, WORK(ILARF) ) + CALL ZLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, DCONJG(TAUP2(I)), + $ X21(I,I+1), LDX21, WORK(ILARF) ) +* + IF( I .LT. Q ) THEN + CALL ZDROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C, + $ S ) + CALL ZLACGV( Q-I, X21(I,I+1), LDX21 ) + CALL ZLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, TAUQ1(I) ) + S = DBLE( X21(I,I+1) ) + X21(I,I+1) = ONE + CALL ZLARF( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), + $ X11(I+1,I+1), LDX11, WORK(ILARF) ) + CALL ZLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), + $ X21(I+1,I+1), LDX21, WORK(ILARF) ) + CALL ZLACGV( Q-I, X21(I,I+1), LDX21 ) + C = SQRT( DZNRM2( P-I, X11(I+1,I+1), 1, X11(I+1,I+1), + $ 1 )**2 + DZNRM2( M-P-I, X21(I+1,I+1), 1, X21(I+1,I+1), + $ 1 )**2 ) + PHI(I) = ATAN2( S, C ) + CALL ZUNBDB5( P-I, M-P-I, Q-I-1, X11(I+1,I+1), 1, + $ X21(I+1,I+1), 1, X11(I+1,I+2), LDX11, + $ X21(I+1,I+2), LDX21, WORK(IORBDB5), LORBDB5, + $ CHILDINFO ) + END IF +* + END DO +* + RETURN +* +* End of ZUNBDB1 +* + END + diff --git a/lapack-netlib/SRC/zunbdb2.f b/lapack-netlib/SRC/zunbdb2.f new file mode 100644 index 000000000..89104f650 --- /dev/null +++ b/lapack-netlib/SRC/zunbdb2.f @@ -0,0 +1,336 @@ +*> \brief \b ZUNBDB2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZUNBDB2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION PHI(*), THETA(*) +* COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> ZUNBDB2 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonomal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. P must be no larger than M-P, +*> Q, or M-Q. Routines ZUNBDB1, ZUNBDB3, and ZUNBDB4 handle cases in +*> which P is not the minimum dimension. +*> +*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are P-by-P bidiagonal matrices represented implicitly by +*> angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= min(M-P,Q,M-Q). +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M. +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is COMPLEX*16 array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is COMPLEX*16 array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is COMPLEX*16 array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is COMPLEX*16 array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is COMPLEX*16 array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup complex16OTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or ZUNCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See ZUNCSD2BY1 for details on generating P1, P2, and Q1 using ZUNGQR +*> and ZUNGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + DOUBLE PRECISION PHI(*), THETA(*) + COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + COMPLEX*16 NEGONE, ONE + PARAMETER ( NEGONE = (-1.0D0,0.0D0), + $ ONE = (1.0D0,0.0D0) ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, + $ LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL ZLARF, ZLARFGP, ZUNBDB5, ZDROT, ZSCAL, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DZNRM2 + EXTERNAL DZNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( P .LT. 0 .OR. P .GT. M-P ) THEN + INFO = -2 + ELSE IF( Q .LT. 0 .OR. Q .LT. P .OR. M-Q .LT. P ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( P-1, M-P, Q-1 ) + IORBDB5 = 2 + LORBDB5 = Q-1 + LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'ZUNBDB2', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce rows 1, ..., P of X11 and X21 +* + DO I = 1, P +* + IF( I .GT. 1 ) THEN + CALL ZDROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C, + $ S ) + END IF + CALL ZLACGV( Q-I+1, X11(I,I), LDX11 ) + CALL ZLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) ) + C = DBLE( X11(I,I) ) + X11(I,I) = ONE + CALL ZLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL ZLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X21(I,I), LDX21, WORK(ILARF) ) + CALL ZLACGV( Q-I+1, X11(I,I), LDX11 ) + S = SQRT( DZNRM2( P-I, X11(I+1,I), 1, X11(I+1,I), + $ 1 )**2 + DZNRM2( M-P-I+1, X21(I,I), 1, X21(I,I), 1 )**2 ) + THETA(I) = ATAN2( S, C ) +* + CALL ZUNBDB5( P-I, M-P-I+1, Q-I, X11(I+1,I), 1, X21(I,I), 1, + $ X11(I+1,I+1), LDX11, X21(I,I+1), LDX21, + $ WORK(IORBDB5), LORBDB5, CHILDINFO ) + CALL ZSCAL( P-I, NEGONE, X11(I+1,I), 1 ) + CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + IF( I .LT. P ) THEN + CALL ZLARFGP( P-I, X11(I+1,I), X11(I+2,I), 1, TAUP1(I) ) + PHI(I) = ATAN2( DBLE( X11(I+1,I) ), DBLE( X21(I,I) ) ) + C = COS( PHI(I) ) + S = SIN( PHI(I) ) + X11(I+1,I) = ONE + CALL ZLARF( 'L', P-I, Q-I, X11(I+1,I), 1, DCONJG(TAUP1(I)), + $ X11(I+1,I+1), LDX11, WORK(ILARF) ) + END IF + X21(I,I) = ONE + CALL ZLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, DCONJG(TAUP2(I)), + $ X21(I,I+1), LDX21, WORK(ILARF) ) +* + END DO +* +* Reduce the bottom-right portion of X21 to the identity matrix +* + DO I = P + 1, Q + CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + X21(I,I) = ONE + CALL ZLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, DCONJG(TAUP2(I)), + $ X21(I,I+1), LDX21, WORK(ILARF) ) + END DO +* + RETURN +* +* End of ZUNBDB2 +* + END + diff --git a/lapack-netlib/SRC/zunbdb3.f b/lapack-netlib/SRC/zunbdb3.f new file mode 100644 index 000000000..37a5c89f4 --- /dev/null +++ b/lapack-netlib/SRC/zunbdb3.f @@ -0,0 +1,336 @@ +*> \brief \b ZUNBDB3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZUNBDB3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION PHI(*), THETA(*) +* COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> ZUNBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonomal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-P must be no larger than P, +*> Q, or M-Q. Routines ZUNBDB1, ZUNBDB2, and ZUNBDB4 handle cases in +*> which M-P is not the minimum dimension. +*> +*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are (M-P)-by-(M-P) bidiagonal matrices represented +*> implicitly by angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= M. M-P <= min(P,Q,M-Q). +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M. +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is COMPLEX*16 array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is COMPLEX*16 array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is COMPLEX*16 array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is COMPLEX*16 array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is COMPLEX*16 array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup complex16OTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or ZUNCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See ZUNCSD2BY1 for details on generating P1, P2, and Q1 using ZUNGQR +*> and ZUNGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + DOUBLE PRECISION PHI(*), THETA(*) + COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = (1.0D0,0.0D0) ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, + $ LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL ZLARF, ZLARFGP, ZUNBDB5, ZDROT, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DZNRM2 + EXTERNAL DZNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( 2*P .LT. M .OR. P .GT. M ) THEN + INFO = -2 + ELSE IF( Q .LT. M-P .OR. M-Q .LT. M-P ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( P, M-P-1, Q-1 ) + IORBDB5 = 2 + LORBDB5 = Q-1 + LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'ZUNBDB3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce rows 1, ..., M-P of X11 and X21 +* + DO I = 1, M-P +* + IF( I .GT. 1 ) THEN + CALL ZDROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C, + $ S ) + END IF +* + CALL ZLACGV( Q-I+1, X21(I,I), LDX21 ) + CALL ZLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) ) + S = DBLE( X21(I,I) ) + X21(I,I) = ONE + CALL ZLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X11(I,I), LDX11, WORK(ILARF) ) + CALL ZLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X21(I+1,I), LDX21, WORK(ILARF) ) + CALL ZLACGV( Q-I+1, X21(I,I), LDX21 ) + C = SQRT( DZNRM2( P-I+1, X11(I,I), 1, X11(I,I), + $ 1 )**2 + DZNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), 1 )**2 ) + THETA(I) = ATAN2( S, C ) +* + CALL ZUNBDB5( P-I+1, M-P-I, Q-I, X11(I,I), 1, X21(I+1,I), 1, + $ X11(I,I+1), LDX11, X21(I+1,I+1), LDX21, + $ WORK(IORBDB5), LORBDB5, CHILDINFO ) + CALL ZLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + IF( I .LT. M-P ) THEN + CALL ZLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, TAUP2(I) ) + PHI(I) = ATAN2( DBLE( X21(I+1,I) ), DBLE( X11(I,I) ) ) + C = COS( PHI(I) ) + S = SIN( PHI(I) ) + X21(I+1,I) = ONE + CALL ZLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1, + $ DCONJG(TAUP2(I)), X21(I+1,I+1), LDX21, + $ WORK(ILARF) ) + END IF + X11(I,I) = ONE + CALL ZLARF( 'L', P-I+1, Q-I, X11(I,I), 1, DCONJG(TAUP1(I)), + $ X11(I,I+1), LDX11, WORK(ILARF) ) +* + END DO +* +* Reduce the bottom-right portion of X11 to the identity matrix +* + DO I = M-P + 1, Q + CALL ZLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + X11(I,I) = ONE + CALL ZLARF( 'L', P-I+1, Q-I, X11(I,I), 1, DCONJG(TAUP1(I)), + $ X11(I,I+1), LDX11, WORK(ILARF) ) + END DO +* + RETURN +* +* End of ZUNBDB3 +* + END + diff --git a/lapack-netlib/SRC/zunbdb4.f b/lapack-netlib/SRC/zunbdb4.f new file mode 100644 index 000000000..91ed9d052 --- /dev/null +++ b/lapack-netlib/SRC/zunbdb4.f @@ -0,0 +1,385 @@ +*> \brief \b ZUNBDB4 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZUNBDB4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION PHI(*), THETA(*) +* COMPLEX*16 PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*), +* $ WORK(*), X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> ZUNBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonomal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-Q must be no larger than P, +*> M-P, or Q. Routines ZUNBDB1, ZUNBDB2, and ZUNBDB3 handle cases in +*> which M-Q is not the minimum dimension. +*> +*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are (M-Q)-by-(M-Q) bidiagonal matrices represented +*> implicitly by angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M and +*> M-Q <= min(P,M-P,Q). +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is COMPLEX*16 array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is COMPLEX*16 array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is COMPLEX*16 array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is COMPLEX*16 array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is COMPLEX*16 array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] PHANTOM +*> \verbatim +*> PHANTOM is COMPLEX*16 array, dimension (M) +*> The routine computes an M-by-1 column vector Y that is +*> orthogonal to the columns of [ X11; X21 ]. PHANTOM(1:P) and +*> PHANTOM(P+1:M) contain Householder vectors for Y(1:P) and +*> Y(P+1:M), respectively. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup complex16OTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or ZUNCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See ZUNCSD2BY1 for details on generating P1, P2, and Q1 using ZUNGQR +*> and ZUNGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + $ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + DOUBLE PRECISION PHI(*), THETA(*) + COMPLEX*16 PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*), + $ WORK(*), X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + COMPLEX*16 NEGONE, ONE, ZERO + PARAMETER ( NEGONE = (-1.0D0,0.0D0), ONE = (1.0D0,0.0D0), + $ ZERO = (0.0D0,0.0D0) ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, J, LLARF, + $ LORBDB5, LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL ZLARF, ZLARFGP, ZUNBDB5, ZDROT, ZSCAL, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DZNRM2 + EXTERNAL DZNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( P .LT. M-Q .OR. M-P .LT. M-Q ) THEN + INFO = -2 + ELSE IF( Q .LT. M-Q .OR. Q .GT. M ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( Q-1, P-1, M-P-1 ) + IORBDB5 = 2 + LORBDB5 = Q + LWORKOPT = ILARF + LLARF - 1 + LWORKOPT = MAX( LWORKOPT, IORBDB5 + LORBDB5 - 1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'ZUNBDB4', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce columns 1, ..., M-Q of X11 and X21 +* + DO I = 1, M-Q +* + IF( I .EQ. 1 ) THEN + DO J = 1, M + PHANTOM(J) = ZERO + END DO + CALL ZUNBDB5( P, M-P, Q, PHANTOM(1), 1, PHANTOM(P+1), 1, + $ X11, LDX11, X21, LDX21, WORK(IORBDB5), + $ LORBDB5, CHILDINFO ) + CALL ZSCAL( P, NEGONE, PHANTOM(1), 1 ) + CALL ZLARFGP( P, PHANTOM(1), PHANTOM(2), 1, TAUP1(1) ) + CALL ZLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, TAUP2(1) ) + THETA(I) = ATAN2( DBLE( PHANTOM(1) ), DBLE( PHANTOM(P+1) ) ) + C = COS( THETA(I) ) + S = SIN( THETA(I) ) + PHANTOM(1) = ONE + PHANTOM(P+1) = ONE + CALL ZLARF( 'L', P, Q, PHANTOM(1), 1, DCONJG(TAUP1(1)), X11, + $ LDX11, WORK(ILARF) ) + CALL ZLARF( 'L', M-P, Q, PHANTOM(P+1), 1, DCONJG(TAUP2(1)), + $ X21, LDX21, WORK(ILARF) ) + ELSE + CALL ZUNBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1, + $ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I), + $ LDX21, WORK(IORBDB5), LORBDB5, CHILDINFO ) + CALL ZSCAL( P-I+1, NEGONE, X11(I,I-1), 1 ) + CALL ZLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, TAUP1(I) ) + CALL ZLARFGP( M-P-I+1, X21(I,I-1), X21(I+1,I-1), 1, + $ TAUP2(I) ) + THETA(I) = ATAN2( DBLE( X11(I,I-1) ), DBLE( X21(I,I-1) ) ) + C = COS( THETA(I) ) + S = SIN( THETA(I) ) + X11(I,I-1) = ONE + X21(I,I-1) = ONE + CALL ZLARF( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, + $ DCONJG(TAUP1(I)), X11(I,I), LDX11, WORK(ILARF) ) + CALL ZLARF( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, + $ DCONJG(TAUP2(I)), X21(I,I), LDX21, WORK(ILARF) ) + END IF +* + CALL ZDROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C ) + CALL ZLACGV( Q-I+1, X21(I,I), LDX21 ) + CALL ZLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) ) + C = DBLE( X21(I,I) ) + X21(I,I) = ONE + CALL ZLARF( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL ZLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X21(I+1,I), LDX21, WORK(ILARF) ) + CALL ZLACGV( Q-I+1, X21(I,I), LDX21 ) + IF( I .LT. M-Q ) THEN + S = SQRT( DZNRM2( P-I, X11(I+1,I), 1, X11(I+1,I), + $ 1 )**2 + DZNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), + $ 1 )**2 ) + PHI(I) = ATAN2( S, C ) + END IF +* + END DO +* +* Reduce the bottom-right portion of X11 to [ I 0 ] +* + DO I = M - Q + 1, P + CALL ZLACGV( Q-I+1, X11(I,I), LDX11 ) + CALL ZLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) ) + X11(I,I) = ONE + CALL ZLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL ZLARF( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X21(M-Q+1,I), LDX21, WORK(ILARF) ) + CALL ZLACGV( Q-I+1, X11(I,I), LDX11 ) + END DO +* +* Reduce the bottom-right portion of X21 to [ 0 I ] +* + DO I = P + 1, Q + CALL ZLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 ) + CALL ZLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), LDX21, + $ TAUQ1(I) ) + X21(M-Q+I-P,I) = ONE + CALL ZLARF( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, TAUQ1(I), + $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) ) + CALL ZLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 ) + END DO +* + RETURN +* +* End of ZUNBDB4 +* + END + diff --git a/lapack-netlib/SRC/zunbdb5.f b/lapack-netlib/SRC/zunbdb5.f new file mode 100644 index 000000000..f777324b7 --- /dev/null +++ b/lapack-netlib/SRC/zunbdb5.f @@ -0,0 +1,274 @@ +*> \brief \b ZUNBDB5 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZUNBDB5 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZUNBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, +* LDQ2, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, +* $ N +* .. +* .. Array Arguments .. +* COMPLEX*16 Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> ZUNBDB5 orthogonalizes the column vector +*> X = [ X1 ] +*> [ X2 ] +*> with respect to the columns of +*> Q = [ Q1 ] . +*> [ Q2 ] +*> The columns of Q must be orthonormal. +*> +*> If the projection is zero according to Kahan's "twice is enough" +*> criterion, then some other vector from the orthogonal complement +*> is returned. This vector is chosen in an arbitrary but deterministic +*> way. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M1 +*> \verbatim +*> M1 is INTEGER +*> The dimension of X1 and the number of rows in Q1. 0 <= M1. +*> \endverbatim +*> +*> \param[in] M2 +*> \verbatim +*> M2 is INTEGER +*> The dimension of X2 and the number of rows in Q2. 0 <= M2. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns in Q1 and Q2. 0 <= N. +*> \endverbatim +*> +*> \param[in,out] X1 +*> \verbatim +*> X1 is COMPLEX*16 array, dimension (M1) +*> On entry, the top part of the vector to be orthogonalized. +*> On exit, the top part of the projected vector. +*> \endverbatim +*> +*> \param[in] INCX1 +*> \verbatim +*> INCX1 is INTEGER +*> Increment for entries of X1. +*> \endverbatim +*> +*> \param[in,out] X2 +*> \verbatim +*> X2 is COMPLEX*16 array, dimension (M2) +*> On entry, the bottom part of the vector to be +*> orthogonalized. On exit, the bottom part of the projected +*> vector. +*> \endverbatim +*> +*> \param[in] INCX2 +*> \verbatim +*> INCX2 is INTEGER +*> Increment for entries of X2. +*> \endverbatim +*> +*> \param[in] Q1 +*> \verbatim +*> Q1 is COMPLEX*16 array, dimension (LDQ1, N) +*> The top part of the orthonormal basis matrix. +*> \endverbatim +*> +*> \param[in] LDQ1 +*> \verbatim +*> LDQ1 is INTEGER +*> The leading dimension of Q1. LDQ1 >= M1. +*> \endverbatim +*> +*> \param[in] Q2 +*> \verbatim +*> Q2 is COMPLEX*16 array, dimension (LDQ2, N) +*> The bottom part of the orthonormal basis matrix. +*> \endverbatim +*> +*> \param[in] LDQ2 +*> \verbatim +*> LDQ2 is INTEGER +*> The leading dimension of Q2. LDQ2 >= M2. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= N. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup complex16OTHERcomputational +* +* ===================================================================== + SUBROUTINE ZUNBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, + $ LDQ2, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, + $ N +* .. +* .. Array Arguments .. + COMPLEX*16 Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = (1.0D0,0.0D0), ZERO = (0.0D0,0.0D0) ) +* .. +* .. Local Scalars .. + INTEGER CHILDINFO, I, J +* .. +* .. External Subroutines .. + EXTERNAL ZUNBDB6, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DZNRM2 + EXTERNAL DZNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + IF( M1 .LT. 0 ) THEN + INFO = -1 + ELSE IF( M2 .LT. 0 ) THEN + INFO = -2 + ELSE IF( N .LT. 0 ) THEN + INFO = -3 + ELSE IF( INCX1 .LT. 1 ) THEN + INFO = -5 + ELSE IF( INCX2 .LT. 1 ) THEN + INFO = -7 + ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN + INFO = -9 + ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN + INFO = -11 + ELSE IF( LWORK .LT. N ) THEN + INFO = -13 + END IF +* + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'ZUNBDB5', -INFO ) + RETURN + END IF +* +* Project X onto the orthogonal complement of Q +* + CALL ZUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, LDQ2, + $ WORK, LWORK, CHILDINFO ) +* +* If the projection is nonzero, then return +* + IF( DZNRM2(M1,X1,INCX1) .NE. ZERO + $ .OR. DZNRM2(M2,X2,INCX2) .NE. ZERO ) THEN + RETURN + END IF +* +* Project each standard basis vector e_1,...,e_M1 in turn, stopping +* when a nonzero projection is found +* + DO I = 1, M1 + DO J = 1, M1 + X1(J) = ZERO + END DO + X1(I) = ONE + DO J = 1, M2 + X2(J) = ZERO + END DO + CALL ZUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, + $ LDQ2, WORK, LWORK, CHILDINFO ) + IF( DZNRM2(M1,X1,INCX1) .NE. ZERO + $ .OR. DZNRM2(M2,X2,INCX2) .NE. ZERO ) THEN + RETURN + END IF + END DO +* +* Project each standard basis vector e_(M1+1),...,e_(M1+M2) in turn, +* stopping when a nonzero projection is found +* + DO I = 1, M2 + DO J = 1, M1 + X1(J) = ZERO + END DO + DO J = 1, M2 + X2(J) = ZERO + END DO + X2(I) = ONE + CALL ZUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, + $ LDQ2, WORK, LWORK, CHILDINFO ) + IF( DZNRM2(M1,X1,INCX1) .NE. ZERO + $ .OR. DZNRM2(M2,X2,INCX2) .NE. ZERO ) THEN + RETURN + END IF + END DO +* + RETURN +* +* End of ZUNBDB5 +* + END + diff --git a/lapack-netlib/SRC/zunbdb6.f b/lapack-netlib/SRC/zunbdb6.f new file mode 100644 index 000000000..931710d06 --- /dev/null +++ b/lapack-netlib/SRC/zunbdb6.f @@ -0,0 +1,313 @@ +*> \brief \b ZUNBDB6 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZUNBDB6 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, +* LDQ2, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, +* $ N +* .. +* .. Array Arguments .. +* COMPLEX*16 Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> ZUNBDB6 orthogonalizes the column vector +*> X = [ X1 ] +*> [ X2 ] +*> with respect to the columns of +*> Q = [ Q1 ] . +*> [ Q2 ] +*> The columns of Q must be orthonormal. +*> +*> If the projection is zero according to Kahan's "twice is enough" +*> criterion, then the zero vector is returned. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M1 +*> \verbatim +*> M1 is INTEGER +*> The dimension of X1 and the number of rows in Q1. 0 <= M1. +*> \endverbatim +*> +*> \param[in] M2 +*> \verbatim +*> M2 is INTEGER +*> The dimension of X2 and the number of rows in Q2. 0 <= M2. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns in Q1 and Q2. 0 <= N. +*> \endverbatim +*> +*> \param[in,out] X1 +*> \verbatim +*> X1 is COMPLEX*16 array, dimension (M1) +*> On entry, the top part of the vector to be orthogonalized. +*> On exit, the top part of the projected vector. +*> \endverbatim +*> +*> \param[in] INCX1 +*> \verbatim +*> INCX1 is INTEGER +*> Increment for entries of X1. +*> \endverbatim +*> +*> \param[in,out] X2 +*> \verbatim +*> X2 is COMPLEX*16 array, dimension (M2) +*> On entry, the bottom part of the vector to be +*> orthogonalized. On exit, the bottom part of the projected +*> vector. +*> \endverbatim +*> +*> \param[in] INCX2 +*> \verbatim +*> INCX2 is INTEGER +*> Increment for entries of X2. +*> \endverbatim +*> +*> \param[in] Q1 +*> \verbatim +*> Q1 is COMPLEX*16 array, dimension (LDQ1, N) +*> The top part of the orthonormal basis matrix. +*> \endverbatim +*> +*> \param[in] LDQ1 +*> \verbatim +*> LDQ1 is INTEGER +*> The leading dimension of Q1. LDQ1 >= M1. +*> \endverbatim +*> +*> \param[in] Q2 +*> \verbatim +*> Q2 is COMPLEX*16 array, dimension (LDQ2, N) +*> The bottom part of the orthonormal basis matrix. +*> \endverbatim +*> +*> \param[in] LDQ2 +*> \verbatim +*> LDQ2 is INTEGER +*> The leading dimension of Q2. LDQ2 >= M2. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= N. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup complex16OTHERcomputational +* +* ===================================================================== + SUBROUTINE ZUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, + $ LDQ2, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2, + $ N +* .. +* .. Array Arguments .. + COMPLEX*16 Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ALPHASQ, REALONE, REALZERO + PARAMETER ( ALPHASQ = 0.01D0, REALONE = 1.0D0, + $ REALZERO = 0.0D0 ) + COMPLEX*16 NEGONE, ONE, ZERO + PARAMETER ( NEGONE = (-1.0D0,0.0D0), ONE = (1.0D0,0.0D0), + $ ZERO = (0.0D0,0.0D0) ) +* .. +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION NORMSQ1, NORMSQ2, SCL1, SCL2, SSQ1, SSQ2 +* .. +* .. External Subroutines .. + EXTERNAL ZGEMV, ZLASSQ, XERBLA +* .. +* .. Intrinsic Function .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + IF( M1 .LT. 0 ) THEN + INFO = -1 + ELSE IF( M2 .LT. 0 ) THEN + INFO = -2 + ELSE IF( N .LT. 0 ) THEN + INFO = -3 + ELSE IF( INCX1 .LT. 1 ) THEN + INFO = -5 + ELSE IF( INCX2 .LT. 1 ) THEN + INFO = -7 + ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN + INFO = -9 + ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN + INFO = -11 + ELSE IF( LWORK .LT. N ) THEN + INFO = -13 + END IF +* + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'ZUNBDB6', -INFO ) + RETURN + END IF +* +* First, project X onto the orthogonal complement of Q's column +* space +* + SCL1 = REALZERO + SSQ1 = REALONE + CALL ZLASSQ( M1, X1, INCX1, SCL1, SSQ1 ) + SCL2 = REALZERO + SSQ2 = REALONE + CALL ZLASSQ( M2, X2, INCX2, SCL2, SSQ2 ) + NORMSQ1 = SCL1**2*SSQ1 + SCL2**2*SSQ2 +* + IF( M1 .EQ. 0 ) THEN + DO I = 1, N + WORK(I) = ZERO + END DO + ELSE + CALL ZGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK, + $ 1 ) + END IF +* + CALL ZGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 ) +* + CALL ZGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1, + $ INCX1 ) + CALL ZGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2, + $ INCX2 ) +* + SCL1 = REALZERO + SSQ1 = REALONE + CALL ZLASSQ( M1, X1, INCX1, SCL1, SSQ1 ) + SCL2 = REALZERO + SSQ2 = REALONE + CALL ZLASSQ( M2, X2, INCX2, SCL2, SSQ2 ) + NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2 +* +* If projection is sufficiently large in norm, then stop. +* If projection is zero, then stop. +* Otherwise, project again. +* + IF( NORMSQ2 .GE. ALPHASQ*NORMSQ1 ) THEN + RETURN + END IF +* + IF( NORMSQ2 .EQ. ZERO ) THEN + RETURN + END IF +* + NORMSQ1 = NORMSQ2 +* + DO I = 1, N + WORK(I) = ZERO + END DO +* + IF( M1 .EQ. 0 ) THEN + DO I = 1, N + WORK(I) = ZERO + END DO + ELSE + CALL ZGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK, + $ 1 ) + END IF +* + CALL ZGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 ) +* + CALL ZGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1, + $ INCX1 ) + CALL ZGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2, + $ INCX2 ) +* + SCL1 = REALZERO + SSQ1 = REALONE + CALL ZLASSQ( M1, X1, INCX1, SCL1, SSQ1 ) + SCL2 = REALZERO + SSQ2 = REALONE + CALL ZLASSQ( M1, X1, INCX1, SCL1, SSQ1 ) + NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2 +* +* If second projection is sufficiently large in norm, then do +* nothing more. Alternatively, if it shrunk significantly, then +* truncate it to zero. +* + IF( NORMSQ2 .LT. ALPHASQ*NORMSQ1 ) THEN + DO I = 1, M1 + X1(I) = ZERO + END DO + DO I = 1, M2 + X2(I) = ZERO + END DO + END IF +* + RETURN +* +* End of ZUNBDB6 +* + END + diff --git a/lapack-netlib/SRC/zuncsd.f b/lapack-netlib/SRC/zuncsd.f index 3f7861d2a..18982f8ff 100644 --- a/lapack-netlib/SRC/zuncsd.f +++ b/lapack-netlib/SRC/zuncsd.f @@ -308,7 +308,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex16OTHERcomputational * @@ -320,10 +320,10 @@ $ LDV2T, WORK, LWORK, RWORK, LRWORK, $ IWORK, INFO ) * -* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK computational routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, SIGNS, TRANS @@ -356,7 +356,7 @@ $ LBBCSDWORKOPT, LORBDBWORK, LORBDBWORKMIN, $ LORBDBWORKOPT, LORGLQWORK, LORGLQWORKMIN, $ LORGLQWORKOPT, LORGQRWORK, LORGQRWORKMIN, - $ LORGQRWORKOPT, LWORKMIN, LWORKOPT + $ LORGQRWORKOPT, LWORKMIN, LWORKOPT, P1, Q1 LOGICAL COLMAJOR, DEFAULTSIGNS, LQUERY, WANTU1, WANTU2, $ WANTV1T, WANTV2T INTEGER LRWORKMIN, LRWORKOPT @@ -371,7 +371,7 @@ EXTERNAL LSAME * .. * .. Intrinsic Functions - INTRINSIC COS, INT, MAX, MIN, SIN + INTRINSIC INT, MAX, MIN * .. * .. Executable Statements .. * @@ -392,9 +392,22 @@ INFO = -8 ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN INFO = -9 - ELSE IF( ( COLMAJOR .AND. LDX11 .LT. MAX(1,P) ) .OR. - $ ( .NOT.COLMAJOR .AND. LDX11 .LT. MAX(1,Q) ) ) THEN - INFO = -11 + ELSE IF ( COLMAJOR .AND. LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF (.NOT. COLMAJOR .AND. LDX11 .LT. MAX( 1, Q ) ) THEN + INFO = -11 + ELSE IF (COLMAJOR .AND. LDX12 .LT. MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF (.NOT. COLMAJOR .AND. LDX12 .LT. MAX( 1, M-Q ) ) THEN + INFO = -13 + ELSE IF (COLMAJOR .AND. LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -15 + ELSE IF (.NOT. COLMAJOR .AND. LDX21 .LT. MAX( 1, Q ) ) THEN + INFO = -15 + ELSE IF (COLMAJOR .AND. LDX22 .LT. MAX( 1, M-P ) ) THEN + INFO = -17 + ELSE IF (.NOT. COLMAJOR .AND. LDX22 .LT. MAX( 1, M-Q ) ) THEN + INFO = -17 ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN INFO = -20 ELSE IF( WANTU2 .AND. LDU2 .LT. M-P ) THEN @@ -458,9 +471,10 @@ IB22D = IB21E + MAX( 1, Q - 1 ) IB22E = IB22D + MAX( 1, Q ) IBBCSD = IB22E + MAX( 1, Q - 1 ) - CALL ZBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, 0, - $ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, 0, - $ 0, 0, 0, 0, 0, 0, 0, RWORK, -1, CHILDINFO ) + CALL ZBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, + $ THETA, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, + $ V2T, LDV2T, THETA, THETA, THETA, THETA, THETA, + $ THETA, THETA, THETA, RWORK, -1, CHILDINFO ) LBBCSDWORKOPT = INT( RWORK(1) ) LBBCSDWORKMIN = LBBCSDWORKOPT LRWORKOPT = IBBCSD + LBBCSDWORKOPT - 1 @@ -474,19 +488,19 @@ ITAUQ1 = ITAUP2 + MAX( 1, M - P ) ITAUQ2 = ITAUQ1 + MAX( 1, Q ) IORGQR = ITAUQ2 + MAX( 1, M - Q ) - CALL ZUNGQR( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), 0, WORK, -1, + CALL ZUNGQR( M-Q, M-Q, M-Q, U1, MAX(1,M-Q), U1, WORK, -1, $ CHILDINFO ) LORGQRWORKOPT = INT( WORK(1) ) LORGQRWORKMIN = MAX( 1, M - Q ) IORGLQ = ITAUQ2 + MAX( 1, M - Q ) - CALL ZUNGLQ( M-Q, M-Q, M-Q, 0, MAX(1,M-Q), 0, WORK, -1, + CALL ZUNGLQ( M-Q, M-Q, M-Q, U1, MAX(1,M-Q), U1, WORK, -1, $ CHILDINFO ) LORGLQWORKOPT = INT( WORK(1) ) LORGLQWORKMIN = MAX( 1, M - Q ) IORBDB = ITAUQ2 + MAX( 1, M - Q ) CALL ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, - $ X21, LDX21, X22, LDX22, 0, 0, 0, 0, 0, 0, WORK, - $ -1, CHILDINFO ) + $ X21, LDX21, X22, LDX22, THETA, THETA, U1, U2, + $ V1T, V2T, WORK, -1, CHILDINFO ) LORBDBWORKOPT = INT( WORK(1) ) LORBDBWORKMIN = LORBDBWORKOPT LWORKOPT = MAX( IORGQR + LORGQRWORKOPT, IORGLQ + LORGLQWORKOPT, @@ -551,10 +565,14 @@ END IF IF( WANTV2T .AND. M-Q .GT. 0 ) THEN CALL ZLACPY( 'U', P, M-Q, X12, LDX12, V2T, LDV2T ) - CALL ZLACPY( 'U', M-P-Q, M-P-Q, X22(Q+1,P+1), LDX22, - $ V2T(P+1,P+1), LDV2T ) - CALL ZUNGLQ( M-Q, M-Q, M-Q, V2T, LDV2T, WORK(ITAUQ2), - $ WORK(IORGLQ), LORGLQWORK, INFO ) + IF( M-P .GT. Q) THEN + CALL ZLACPY( 'U', M-P-Q, M-P-Q, X22(Q+1,P+1), LDX22, + $ V2T(P+1,P+1), LDV2T ) + END IF + IF( M .GT. Q ) THEN + CALL ZUNGLQ( M-Q, M-Q, M-Q, V2T, LDV2T, WORK(ITAUQ2), + $ WORK(IORGLQ), LORGLQWORK, INFO ) + END IF END IF ELSE IF( WANTU1 .AND. P .GT. 0 ) THEN @@ -579,9 +597,13 @@ $ WORK(IORGQR), LORGQRWORK, INFO ) END IF IF( WANTV2T .AND. M-Q .GT. 0 ) THEN + P1 = MIN( P+1, M ) + Q1 = MIN( Q+1, M ) CALL ZLACPY( 'L', M-Q, P, X12, LDX12, V2T, LDV2T ) - CALL ZLACPY( 'L', M-P-Q, M-P-Q, X22(P+1,Q+1), LDX22, - $ V2T(P+1,P+1), LDV2T ) + IF( M .GT. P+Q ) THEN + CALL ZLACPY( 'L', M-P-Q, M-P-Q, X22(P1,Q1), LDX22, + $ V2T(P+1,P+1), LDV2T ) + END IF CALL ZUNGQR( M-Q, M-Q, M-Q, V2T, LDV2T, WORK(ITAUQ2), $ WORK(IORGQR), LORGQRWORK, INFO ) END IF diff --git a/lapack-netlib/SRC/zuncsd2by1.f b/lapack-netlib/SRC/zuncsd2by1.f new file mode 100644 index 000000000..777f132e7 --- /dev/null +++ b/lapack-netlib/SRC/zuncsd2by1.f @@ -0,0 +1,756 @@ +*> \brief \b ZUNCSD2BY1 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZUNCSD2BY1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, +* X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T, +* LDV1T, WORK, LWORK, RWORK, LRWORK, IWORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBU1, JOBU2, JOBV1T +* INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21, +* $ M, P, Q +* INTEGER LRWORK, LRWORKMIN, LRWORKOPT +* .. +* .. Array Arguments .. +* DOUBLE PRECISION RWORK(*) +* DOUBLE PRECISION THETA(*) +* COMPLEX*16 U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* INTEGER IWORK(*) +* .. +* +* +*> \par Purpose: +*> ============= +*> +*>\verbatim +*> +*> ZUNCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with +*> orthonormal columns that has been partitioned into a 2-by-1 block +*> structure: +*> +*> [ I 0 0 ] +*> [ 0 C 0 ] +*> [ X11 ] [ U1 | ] [ 0 0 0 ] +*> X = [-----] = [---------] [----------] V1**T . +*> [ X21 ] [ | U2 ] [ 0 0 0 ] +*> [ 0 S 0 ] +*> [ 0 0 I ] +*> +*> X11 is P-by-Q. The unitary matrices U1, U2, V1, and V2 are P-by-P, +*> (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are +*> R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in +*> which R = MIN(P,M-P,Q,M-Q). +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBU1 +*> \verbatim +*> JOBU1 is CHARACTER +*> = 'Y': U1 is computed; +*> otherwise: U1 is not computed. +*> \endverbatim +*> +*> \param[in] JOBU2 +*> \verbatim +*> JOBU2 is CHARACTER +*> = 'Y': U2 is computed; +*> otherwise: U2 is not computed. +*> \endverbatim +*> +*> \param[in] JOBV1T +*> \verbatim +*> JOBV1T is CHARACTER +*> = 'Y': V1T is computed; +*> otherwise: V1T is not computed. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows and columns in X. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11 and X12. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M. +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is COMPLEX*16 array, dimension (LDX11,Q) +*> On entry, part of the unitary matrix whose CSD is +*> desired. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= MAX(1,P). +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is COMPLEX*16 array, dimension (LDX21,Q) +*> On entry, part of the unitary matrix whose CSD is +*> desired. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= MAX(1,M-P). +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is COMPLEX*16 array, dimension (R), in which R = +*> MIN(P,M-P,Q,M-Q). +*> C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and +*> S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ). +*> \endverbatim +*> +*> \param[out] U1 +*> \verbatim +*> U1 is COMPLEX*16 array, dimension (P) +*> If JOBU1 = 'Y', U1 contains the P-by-P unitary matrix U1. +*> \endverbatim +*> +*> \param[in] LDU1 +*> \verbatim +*> LDU1 is INTEGER +*> The leading dimension of U1. If JOBU1 = 'Y', LDU1 >= +*> MAX(1,P). +*> \endverbatim +*> +*> \param[out] U2 +*> \verbatim +*> U2 is COMPLEX*16 array, dimension (M-P) +*> If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) unitary +*> matrix U2. +*> \endverbatim +*> +*> \param[in] LDU2 +*> \verbatim +*> LDU2 is INTEGER +*> The leading dimension of U2. If JOBU2 = 'Y', LDU2 >= +*> MAX(1,M-P). +*> \endverbatim +*> +*> \param[out] V1T +*> \verbatim +*> V1T is COMPLEX*16 array, dimension (Q) +*> If JOBV1T = 'Y', V1T contains the Q-by-Q matrix unitary +*> matrix V1**T. +*> \endverbatim +*> +*> \param[in] LDV1T +*> \verbatim +*> LDV1T is INTEGER +*> The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >= +*> MAX(1,Q). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> If INFO > 0 on exit, WORK(2:R) contains the values PHI(1), +*> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R), +*> define the matrix in intermediate bidiagonal-block form +*> remaining after nonconvergence. INFO specifies the number +*> of nonzero PHI's. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> \endverbatim +*> \verbatim +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the work array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK)) +*> On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. +*> If INFO > 0 on exit, RWORK(2:R) contains the values PHI(1), +*> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R), +*> define the matrix in intermediate bidiagonal-block form +*> remaining after nonconvergence. INFO specifies the number +*> of nonzero PHI's. +*> \endverbatim +*> +*> \param[in] LRWORK +*> \verbatim +*> LRWORK is INTEGER +*> The dimension of the array RWORK. +*> +*> If LRWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the RWORK array, returns +*> this value as the first entry of the work array, and no error +*> message related to LRWORK is issued by XERBLA. +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (M-MIN(P,M-P,Q,M-Q)) +*> \endverbatim +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: ZBBCSD did not converge. See the description of WORK +*> above for details. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date July 2012 +* +*> \ingroup complex16OTHERcomputational +* +* ===================================================================== + SUBROUTINE ZUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11, + $ X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T, + $ LDV1T, WORK, LWORK, RWORK, LRWORK, IWORK, + $ INFO ) +* +* -- LAPACK computational routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* July 2012 +* +* .. Scalar Arguments .. + CHARACTER JOBU1, JOBU2, JOBV1T + INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21, + $ M, P, Q + INTEGER LRWORK, LRWORKMIN, LRWORKOPT +* .. +* .. Array Arguments .. + DOUBLE PRECISION RWORK(*) + DOUBLE PRECISION THETA(*) + COMPLEX*16 U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) + INTEGER IWORK(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = (1.0D0,0.0D0), ZERO = (0.0D0,0.0D0) ) +* .. +* .. Local Scalars .. + INTEGER CHILDINFO, I, IB11D, IB11E, IB12D, IB12E, + $ IB21D, IB21E, IB22D, IB22E, IBBCSD, IORBDB, + $ IORGLQ, IORGQR, IPHI, ITAUP1, ITAUP2, ITAUQ1, + $ J, LBBCSD, LORBDB, LORGLQ, LORGLQMIN, + $ LORGLQOPT, LORGQR, LORGQRMIN, LORGQROPT, + $ LWORKMIN, LWORKOPT, R + LOGICAL LQUERY, WANTU1, WANTU2, WANTV1T +* .. +* .. External Subroutines .. + EXTERNAL ZBBCSD, ZCOPY, ZLACPY, ZLAPMR, ZLAPMT, ZUNBDB1, + $ ZUNBDB2, ZUNBDB3, ZUNBDB4, ZUNGLQ, ZUNGQR, + $ XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Function .. + INTRINSIC INT, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + WANTU1 = LSAME( JOBU1, 'Y' ) + WANTU2 = LSAME( JOBU2, 'Y' ) + WANTV1T = LSAME( JOBV1T, 'Y' ) + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -4 + ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN + INFO = -5 + ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN + INFO = -6 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -8 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -10 + ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN + INFO = -13 + ELSE IF( WANTU2 .AND. LDU2 .LT. M - P ) THEN + INFO = -15 + ELSE IF( WANTV1T .AND. LDV1T .LT. Q ) THEN + INFO = -17 + END IF +* + R = MIN( P, M-P, Q, M-Q ) +* +* Compute workspace +* +* WORK layout: +* |-----------------------------------------| +* | LWORKOPT (1) | +* |-----------------------------------------| +* | TAUP1 (MAX(1,P)) | +* | TAUP2 (MAX(1,M-P)) | +* | TAUQ1 (MAX(1,Q)) | +* |-----------------------------------------| +* | ZUNBDB WORK | ZUNGQR WORK | ZUNGLQ WORK | +* | | | | +* | | | | +* | | | | +* | | | | +* |-----------------------------------------| +* RWORK layout: +* |------------------| +* | LRWORKOPT (1) | +* |------------------| +* | PHI (MAX(1,R-1)) | +* |------------------| +* | B11D (R) | +* | B11E (R-1) | +* | B12D (R) | +* | B12E (R-1) | +* | B21D (R) | +* | B21E (R-1) | +* | B22D (R) | +* | B22E (R-1) | +* | ZBBCSD RWORK | +* |------------------| +* + IF( INFO .EQ. 0 ) THEN + IPHI = 2 + IB11D = IPHI + MAX( 1, R-1 ) + IB11E = IB11D + MAX( 1, R ) + IB12D = IB11E + MAX( 1, R - 1 ) + IB12E = IB12D + MAX( 1, R ) + IB21D = IB12E + MAX( 1, R - 1 ) + IB21E = IB21D + MAX( 1, R ) + IB22D = IB21E + MAX( 1, R - 1 ) + IB22E = IB22D + MAX( 1, R ) + IBBCSD = IB22E + MAX( 1, R - 1 ) + ITAUP1 = 2 + ITAUP2 = ITAUP1 + MAX( 1, P ) + ITAUQ1 = ITAUP2 + MAX( 1, M-P ) + IORBDB = ITAUQ1 + MAX( 1, Q ) + IORGQR = ITAUQ1 + MAX( 1, Q ) + IORGLQ = ITAUQ1 + MAX( 1, Q ) + IF( R .EQ. Q ) THEN + CALL ZUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, + $ 0, 0, WORK, -1, CHILDINFO ) + LORBDB = INT( WORK(1) ) + IF( P .GE. M-P ) THEN + CALL ZUNGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, P ) + LORGQROPT = INT( WORK(1) ) + ELSE + CALL ZUNGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, M-P ) + LORGQROPT = INT( WORK(1) ) + END IF + CALL ZUNGLQ( MAX(0,Q-1), MAX(0,Q-1), MAX(0,Q-1), V1T, LDV1T, + $ 0, WORK(1), -1, CHILDINFO ) + LORGLQMIN = MAX( 1, Q-1 ) + LORGLQOPT = INT( WORK(1) ) + CALL ZBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA, + $ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, 0, 0, + $ 0, 0, 0, 0, 0, 0, RWORK(1), -1, CHILDINFO ) + LBBCSD = INT( RWORK(1) ) + ELSE IF( R .EQ. P ) THEN + CALL ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, + $ 0, 0, WORK(1), -1, CHILDINFO ) + LORBDB = INT( WORK(1) ) + IF( P-1 .GE. M-P ) THEN + CALL ZUNGQR( P-1, P-1, P-1, U1(2,2), LDU1, 0, WORK(1), + $ -1, CHILDINFO ) + LORGQRMIN = MAX( 1, P-1 ) + LORGQROPT = INT( WORK(1) ) + ELSE + CALL ZUNGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, M-P ) + LORGQROPT = INT( WORK(1) ) + END IF + CALL ZUNGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1, + $ CHILDINFO ) + LORGLQMIN = MAX( 1, Q ) + LORGLQOPT = INT( WORK(1) ) + CALL ZBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA, + $ 0, V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, 0, 0, + $ 0, 0, 0, 0, 0, 0, RWORK(1), -1, CHILDINFO ) + LBBCSD = INT( RWORK(1) ) + ELSE IF( R .EQ. M-P ) THEN + CALL ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, + $ 0, 0, WORK(1), -1, CHILDINFO ) + LORBDB = INT( WORK(1) ) + IF( P .GE. M-P-1 ) THEN + CALL ZUNGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, P ) + LORGQROPT = INT( WORK(1) ) + ELSE + CALL ZUNGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, 0, + $ WORK(1), -1, CHILDINFO ) + LORGQRMIN = MAX( 1, M-P-1 ) + LORGQROPT = INT( WORK(1) ) + END IF + CALL ZUNGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1, + $ CHILDINFO ) + LORGLQMIN = MAX( 1, Q ) + LORGLQOPT = INT( WORK(1) ) + CALL ZBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P, + $ THETA, 0, 0, 1, V1T, LDV1T, U2, LDU2, U1, LDU1, + $ 0, 0, 0, 0, 0, 0, 0, 0, RWORK(1), -1, + $ CHILDINFO ) + LBBCSD = INT( RWORK(1) ) + ELSE + CALL ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0, + $ 0, 0, 0, WORK(1), -1, CHILDINFO ) + LORBDB = M + INT( WORK(1) ) + IF( P .GE. M-P ) THEN + CALL ZUNGQR( P, P, M-Q, U1, LDU1, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, P ) + LORGQROPT = INT( WORK(1) ) + ELSE + CALL ZUNGQR( M-P, M-P, M-Q, U2, LDU2, 0, WORK(1), -1, + $ CHILDINFO ) + LORGQRMIN = MAX( 1, M-P ) + LORGQROPT = INT( WORK(1) ) + END IF + CALL ZUNGLQ( Q, Q, Q, V1T, LDV1T, 0, WORK(1), -1, + $ CHILDINFO ) + LORGLQMIN = MAX( 1, Q ) + LORGLQOPT = INT( WORK(1) ) + CALL ZBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q, + $ THETA, 0, U2, LDU2, U1, LDU1, 0, 1, V1T, LDV1T, + $ 0, 0, 0, 0, 0, 0, 0, 0, RWORK(1), -1, + $ CHILDINFO ) + LBBCSD = INT( RWORK(1) ) + END IF + LRWORKMIN = IBBCSD+LBBCSD-1 + LRWORKOPT = LRWORKMIN + RWORK(1) = LRWORKOPT + LWORKMIN = MAX( IORBDB+LORBDB-1, + $ IORGQR+LORGQRMIN-1, + $ IORGLQ+LORGLQMIN-1 ) + LWORKOPT = MAX( IORBDB+LORBDB-1, + $ IORGQR+LORGQROPT-1, + $ IORGLQ+LORGLQOPT-1 ) + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -19 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'ZUNCSD2BY1', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF + LORGQR = LWORK-IORGQR+1 + LORGLQ = LWORK-IORGLQ+1 +* +* Handle four cases separately: R = Q, R = P, R = M-P, and R = M-Q, +* in which R = MIN(P,M-P,Q,M-Q) +* + IF( R .EQ. Q ) THEN +* +* Case 1: R = Q +* +* Simultaneously bidiagonalize X11 and X21 +* + CALL ZUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2), + $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO ) +* +* Accumulate Householder reflectors +* + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL ZLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 ) + CALL ZUNGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR), + $ LORGQR, CHILDINFO ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL ZLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 ) + CALL ZUNGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + V1T(1,1) = ONE + DO J = 2, Q + V1T(1,J) = ZERO + V1T(J,1) = ZERO + END DO + CALL ZLACPY( 'U', Q-1, Q-1, X21(1,2), LDX21, V1T(2,2), + $ LDV1T ) + CALL ZUNGLQ( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1), + $ WORK(IORGLQ), LORGLQ, CHILDINFO ) + END IF +* +* Simultaneously diagonalize X11 and X21. +* + CALL ZBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA, + $ RWORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, + $ RWORK(IB11D), RWORK(IB11E), RWORK(IB12D), + $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E), + $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD, + $ CHILDINFO ) +* +* Permute rows and columns to place zero submatrices in +* preferred positions +* + IF( Q .GT. 0 .AND. WANTU2 ) THEN + DO I = 1, Q + IWORK(I) = M - P - Q + I + END DO + DO I = Q + 1, M - P + IWORK(I) = I - Q + END DO + CALL ZLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK ) + END IF + ELSE IF( R .EQ. P ) THEN +* +* Case 2: R = P +* +* Simultaneously bidiagonalize X11 and X21 +* + CALL ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2), + $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO ) +* +* Accumulate Householder reflectors +* + IF( WANTU1 .AND. P .GT. 0 ) THEN + U1(1,1) = ONE + DO J = 2, P + U1(1,J) = ZERO + U1(J,1) = ZERO + END DO + CALL ZLACPY( 'L', P-1, P-1, X11(2,1), LDX11, U1(2,2), LDU1 ) + CALL ZUNGQR( P-1, P-1, P-1, U1(2,2), LDU1, WORK(ITAUP1), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL ZLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 ) + CALL ZUNGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL ZLACPY( 'U', P, Q, X11, LDX11, V1T, LDV1T ) + CALL ZUNGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1), + $ WORK(IORGLQ), LORGLQ, CHILDINFO ) + END IF +* +* Simultaneously diagonalize X11 and X21. +* + CALL ZBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA, + $ RWORK(IPHI), V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, + $ RWORK(IB11D), RWORK(IB11E), RWORK(IB12D), + $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E), + $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD, + $ CHILDINFO ) +* +* Permute rows and columns to place identity submatrices in +* preferred positions +* + IF( Q .GT. 0 .AND. WANTU2 ) THEN + DO I = 1, Q + IWORK(I) = M - P - Q + I + END DO + DO I = Q + 1, M - P + IWORK(I) = I - Q + END DO + CALL ZLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK ) + END IF + ELSE IF( R .EQ. M-P ) THEN +* +* Case 3: R = M-P +* +* Simultaneously bidiagonalize X11 and X21 +* + CALL ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2), + $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO ) +* +* Accumulate Householder reflectors +* + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL ZLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 ) + CALL ZUNGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR), + $ LORGQR, CHILDINFO ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + U2(1,1) = ONE + DO J = 2, M-P + U2(1,J) = ZERO + U2(J,1) = ZERO + END DO + CALL ZLACPY( 'L', M-P-1, M-P-1, X21(2,1), LDX21, U2(2,2), + $ LDU2 ) + CALL ZUNGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, + $ WORK(ITAUP2), WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL ZLACPY( 'U', M-P, Q, X21, LDX21, V1T, LDV1T ) + CALL ZUNGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1), + $ WORK(IORGLQ), LORGLQ, CHILDINFO ) + END IF +* +* Simultaneously diagonalize X11 and X21. +* + CALL ZBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P, + $ THETA, RWORK(IPHI), 0, 1, V1T, LDV1T, U2, LDU2, + $ U1, LDU1, RWORK(IB11D), RWORK(IB11E), + $ RWORK(IB12D), RWORK(IB12E), RWORK(IB21D), + $ RWORK(IB21E), RWORK(IB22D), RWORK(IB22E), + $ RWORK(IBBCSD), LBBCSD, CHILDINFO ) +* +* Permute rows and columns to place identity submatrices in +* preferred positions +* + IF( Q .GT. R ) THEN + DO I = 1, R + IWORK(I) = Q - R + I + END DO + DO I = R + 1, Q + IWORK(I) = I - R + END DO + IF( WANTU1 ) THEN + CALL ZLAPMT( .FALSE., P, Q, U1, LDU1, IWORK ) + END IF + IF( WANTV1T ) THEN + CALL ZLAPMR( .FALSE., Q, Q, V1T, LDV1T, IWORK ) + END IF + END IF + ELSE +* +* Case 4: R = M-Q +* +* Simultaneously bidiagonalize X11 and X21 +* + CALL ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2), + $ WORK(ITAUQ1), WORK(IORBDB), WORK(IORBDB+M), + $ LORBDB-M, CHILDINFO ) +* +* Accumulate Householder reflectors +* + IF( WANTU1 .AND. P .GT. 0 ) THEN + CALL ZCOPY( P, WORK(IORBDB), 1, U1, 1 ) + DO J = 2, P + U1(1,J) = ZERO + END DO + CALL ZLACPY( 'L', P-1, M-Q-1, X11(2,1), LDX11, U1(2,2), + $ LDU1 ) + CALL ZUNGQR( P, P, M-Q, U1, LDU1, WORK(ITAUP1), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTU2 .AND. M-P .GT. 0 ) THEN + CALL ZCOPY( M-P, WORK(IORBDB+P), 1, U2, 1 ) + DO J = 2, M-P + U2(1,J) = ZERO + END DO + CALL ZLACPY( 'L', M-P-1, M-Q-1, X21(2,1), LDX21, U2(2,2), + $ LDU2 ) + CALL ZUNGQR( M-P, M-P, M-Q, U2, LDU2, WORK(ITAUP2), + $ WORK(IORGQR), LORGQR, CHILDINFO ) + END IF + IF( WANTV1T .AND. Q .GT. 0 ) THEN + CALL ZLACPY( 'U', M-Q, Q, X21, LDX21, V1T, LDV1T ) + CALL ZLACPY( 'U', P-(M-Q), Q-(M-Q), X11(M-Q+1,M-Q+1), LDX11, + $ V1T(M-Q+1,M-Q+1), LDV1T ) + CALL ZLACPY( 'U', -P+Q, Q-P, X21(M-Q+1,P+1), LDX21, + $ V1T(P+1,P+1), LDV1T ) + CALL ZUNGLQ( Q, Q, Q, V1T, LDV1T, WORK(ITAUQ1), + $ WORK(IORGLQ), LORGLQ, CHILDINFO ) + END IF +* +* Simultaneously diagonalize X11 and X21. +* + CALL ZBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q, + $ THETA, RWORK(IPHI), U2, LDU2, U1, LDU1, 0, 1, V1T, + $ LDV1T, RWORK(IB11D), RWORK(IB11E), RWORK(IB12D), + $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E), + $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD, + $ CHILDINFO ) +* +* Permute rows and columns to place identity submatrices in +* preferred positions +* + IF( P .GT. R ) THEN + DO I = 1, R + IWORK(I) = P - R + I + END DO + DO I = R + 1, P + IWORK(I) = I - R + END DO + IF( WANTU1 ) THEN + CALL ZLAPMT( .FALSE., P, P, U1, LDU1, IWORK ) + END IF + IF( WANTV1T ) THEN + CALL ZLAPMR( .FALSE., P, Q, V1T, LDV1T, IWORK ) + END IF + END IF + END IF +* + RETURN +* +* End of ZUNCSD2BY1 +* + END + diff --git a/lapack-netlib/TESTING/EIG/alahdg.f b/lapack-netlib/TESTING/EIG/alahdg.f index 1431d8ee0..51959416c 100644 --- a/lapack-netlib/TESTING/EIG/alahdg.f +++ b/lapack-netlib/TESTING/EIG/alahdg.f @@ -209,14 +209,23 @@ * * CSD * - WRITE( IOUNIT, FMT = 9920 )1 - WRITE( IOUNIT, FMT = 9921 )2 - WRITE( IOUNIT, FMT = 9922 )3 - WRITE( IOUNIT, FMT = 9923 )4 - WRITE( IOUNIT, FMT = 9924 )5 - WRITE( IOUNIT, FMT = 9925 )6 - WRITE( IOUNIT, FMT = 9926 )7 - WRITE( IOUNIT, FMT = 9927 )8 + WRITE( IOUNIT, FMT = 9910 ) + WRITE( IOUNIT, FMT = 9911 )1 + WRITE( IOUNIT, FMT = 9912 )2 + WRITE( IOUNIT, FMT = 9913 )3 + WRITE( IOUNIT, FMT = 9914 )4 + WRITE( IOUNIT, FMT = 9915 )5 + WRITE( IOUNIT, FMT = 9916 )6 + WRITE( IOUNIT, FMT = 9917 )7 + WRITE( IOUNIT, FMT = 9918 )8 + WRITE( IOUNIT, FMT = 9919 )9 + WRITE( IOUNIT, FMT = 9920 ) + WRITE( IOUNIT, FMT = 9921 )10 + WRITE( IOUNIT, FMT = 9922 )11 + WRITE( IOUNIT, FMT = 9923 )12 + WRITE( IOUNIT, FMT = 9924 )13 + WRITE( IOUNIT, FMT = 9925 )14 + WRITE( IOUNIT, FMT = 9926 )15 END IF * 9999 FORMAT( 1X, A ) @@ -291,18 +300,29 @@ * * CSD test ratio * - 9920 FORMAT( 3X, I2, ': norm( U1'' * X11 * V1 - C ) / ( max( P, Q)', + 9910 FORMAT( 3X, '2-by-2 CSD' ) + 9911 FORMAT( 3X, I2, ': norm( U1'' * X11 * V1 - C ) / ( max( P, Q)', $ ' * max(norm(I-X''*X),EPS) )' ) - 9921 FORMAT( 3X, I2, ': norm( U1'' * X12 * V2-(-S)) / ( max( P,', + 9912 FORMAT( 3X, I2, ': norm( U1'' * X12 * V2-(-S)) / ( max( P,', $ 'M-Q) * max(norm(I-X''*X),EPS) )' ) - 9922 FORMAT( 3X, I2, ': norm( U2'' * X21 * V1 - S ) / ( max(M-P,', + 9913 FORMAT( 3X, I2, ': norm( U2'' * X21 * V1 - S ) / ( max(M-P,', $ ' Q) * max(norm(I-X''*X),EPS) )' ) - 9923 FORMAT( 3X, I2, ': norm( U2'' * X22 * V2 - C ) / ( max(M-P,', + 9914 FORMAT( 3X, I2, ': norm( U2'' * X22 * V2 - C ) / ( max(M-P,', $ 'M-Q) * max(norm(I-X''*X),EPS) )' ) - 9924 FORMAT( 3X, I2, ': norm( I - U1''*U1 ) / ( P * EPS )' ) - 9925 FORMAT( 3X, I2, ': norm( I - U2''*U2 ) / ( (M-P) * EPS )' ) - 9926 FORMAT( 3X, I2, ': norm( I - V1''*V1 ) / ( Q * EPS )' ) - 9927 FORMAT( 3X, I2, ': norm( I - V2''*V2 ) / ( (M-Q) * EPS )' ) + 9915 FORMAT( 3X, I2, ': norm( I - U1''*U1 ) / ( P * EPS )' ) + 9916 FORMAT( 3X, I2, ': norm( I - U2''*U2 ) / ( (M-P) * EPS )' ) + 9917 FORMAT( 3X, I2, ': norm( I - V1''*V1 ) / ( Q * EPS )' ) + 9918 FORMAT( 3X, I2, ': norm( I - V2''*V2 ) / ( (M-Q) * EPS )' ) + 9919 FORMAT( 3X, I2, ': principal angle ordering ( 0 or ULP )' ) + 9920 FORMAT( 3X, '2-by-1 CSD' ) + 9921 FORMAT( 3X, I2, ': norm( U1'' * X11 * V1 - C ) / ( max( P, Q)', + $ ' * max(norm(I-X''*X),EPS) )' ) + 9922 FORMAT( 3X, I2, ': norm( U2'' * X21 * V1 - S ) / ( max( M-P,', + $ 'Q) * max(norm(I-X''*X),EPS) )' ) + 9923 FORMAT( 3X, I2, ': norm( I - U1''*U1 ) / ( P * EPS )' ) + 9924 FORMAT( 3X, I2, ': norm( I - U2''*U2 ) / ( (M-P) * EPS )' ) + 9925 FORMAT( 3X, I2, ': norm( I - V1''*V1 ) / ( Q * EPS )' ) + 9926 FORMAT( 3X, I2, ': principal angle ordering ( 0 or ULP )' ) RETURN * * End of ALAHDG diff --git a/lapack-netlib/TESTING/EIG/cchkee.f b/lapack-netlib/TESTING/EIG/cchkee.f index f310f7988..31715d568 100644 --- a/lapack-netlib/TESTING/EIG/cchkee.f +++ b/lapack-netlib/TESTING/EIG/cchkee.f @@ -1026,17 +1026,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup complex_eig * * ===================================================================== PROGRAM CCHKEE * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * ===================================================================== * @@ -1129,6 +1129,10 @@ * .. * .. Executable Statements .. * + A = 0.0 + B = 0.0 + C = 0.0 + DC = 0.0 S1 = SECOND( ) FATAL = .FALSE. NUNIT = NOUT diff --git a/lapack-netlib/TESTING/EIG/cckcsd.f b/lapack-netlib/TESTING/EIG/cckcsd.f index c6cb13b06..a4146c743 100644 --- a/lapack-netlib/TESTING/EIG/cckcsd.f +++ b/lapack-netlib/TESTING/EIG/cckcsd.f @@ -205,13 +205,16 @@ * * .. Parameters .. INTEGER NTESTS - PARAMETER ( NTESTS = 9 ) + PARAMETER ( NTESTS = 15 ) INTEGER NTYPES - PARAMETER ( NTYPES = 3 ) - REAL GAPDIGIT, ORTH, PIOVER2, TEN + PARAMETER ( NTYPES = 4 ) + REAL GAPDIGIT, ORTH, PIOVER2, REALONE, REALZERO, TEN PARAMETER ( GAPDIGIT = 10.0E0, ORTH = 1.0E-4, $ PIOVER2 = 1.57079632679489662E0, - $ TEN = 10.0D0 ) + $ REALONE = 1.0E0, REALZERO = 0.0E0, + $ TEN = 10.0E0 ) + COMPLEX ONE, ZERO + PARAMETER ( ONE = (1.0E0,0.0E0), ZERO = (0.0E0,0.0E0) ) * .. * .. Local Scalars .. LOGICAL FIRSTT @@ -231,8 +234,8 @@ INTRINSIC ABS, MIN * .. * .. External Functions .. - REAL SLARND - EXTERNAL SLARND + REAL SLARAN, SLARND + EXTERNAL SLARAN, SLARND * .. * .. Executable Statements .. * @@ -286,7 +289,7 @@ $ ORTH*SLARND(2,ISEED) END DO END DO - ELSE + ELSE IF( IMAT.EQ.3 ) THEN R = MIN( P, M-P, Q, M-Q ) DO I = 1, R+1 THETA(I) = TEN**(-SLARND(1,ISEED)*GAPDIGIT) @@ -298,9 +301,18 @@ THETA(I) = PIOVER2 * THETA(I) / THETA(R+1) END DO CALL CLACSG( M, P, Q, THETA, ISEED, X, LDX, WORK ) + ELSE + CALL CLASET( 'F', M, M, ZERO, ONE, X, LDX ) + DO I = 1, M + J = INT( SLARAN( ISEED ) * M ) + 1 + IF( J .NE. I ) THEN + CALL CSROT( M, X(1+(I-1)*LDX), 1, X(1+(J-1)*LDX), + $ 1, REALZERO, REALONE ) + END IF + END DO END IF * - NT = 9 + NT = 15 * CALL CCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, $ LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK, diff --git a/lapack-netlib/TESTING/EIG/ccsdts.f b/lapack-netlib/TESTING/EIG/ccsdts.f index da6ac6b75..bdb85b832 100644 --- a/lapack-netlib/TESTING/EIG/ccsdts.f +++ b/lapack-netlib/TESTING/EIG/ccsdts.f @@ -17,7 +17,7 @@ * .. * .. Array Arguments .. * INTEGER IWORK( * ) -* REAL RESULT( 9 ), RWORK( * ), THETA( * ) +* REAL RESULT( 15 ), RWORK( * ), THETA( * ) * COMPLEX U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ), * $ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ), * $ XF( LDX, * ) @@ -47,6 +47,21 @@ *> [ 0 0 0 | I 0 0 ] [ D21 D22 ] *> [ 0 S 0 | 0 C 0 ] *> [ 0 0 I | 0 0 0 ] +*> +*> and also SORCSD2BY1, which, given +*> Q +*> [ X11 ] P , +*> [ X21 ] M-P +*> +*> computes the 2-by-1 CSD +*> +*> [ I 0 0 ] +*> [ 0 C 0 ] +*> [ 0 0 0 ] +*> [ U1 ]**T * [ X11 ] * V1 = [----------] = [ D11 ] , +*> [ U2 ] [ X21 ] [ 0 0 0 ] [ D21 ] +*> [ 0 S 0 ] +*> [ 0 0 I ] *> \endverbatim * * Arguments: @@ -171,8 +186,9 @@ *> *> \param[out] RESULT *> \verbatim -*> RESULT is REAL array, dimension (9) +*> RESULT is REAL array, dimension (15) *> The test ratios: +*> First, the 2-by-2 CSD: *> RESULT(1) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) *> RESULT(2) = norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 ) *> RESULT(3) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) @@ -184,6 +200,15 @@ *> RESULT(9) = 0 if THETA is in increasing order and *> all angles are in [0,pi/2]; *> = ULPINV otherwise. +*> Then, the 2-by-1 CSD: +*> RESULT(10) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) +*> RESULT(11) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) +*> RESULT(12) = norm( I - U1'*U1 ) / ( MAX(1,P)*ULP ) +*> RESULT(13) = norm( I - U2'*U2 ) / ( MAX(1,M-P)*ULP ) +*> RESULT(14) = norm( I - V1T'*V1T ) / ( MAX(1,Q)*ULP ) +*> RESULT(15) = 0 if THETA is in increasing order and +*> all angles are in [0,pi/2]; +*> = ULPINV otherwise. *> ( EPS2 = MAX( norm( I - X'*X ) / M, ULP ). ) *> \endverbatim * @@ -214,7 +239,7 @@ * .. * .. Array Arguments .. INTEGER IWORK( * ) - REAL RESULT( 9 ), RWORK( * ), THETA( * ) + REAL RESULT( 15 ), RWORK( * ), THETA( * ) COMPLEX U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ), $ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ), $ XF( LDX, * ) @@ -238,15 +263,19 @@ EXTERNAL SLAMCH, CLANGE, CLANHE * .. * .. External Subroutines .. - EXTERNAL CGEMM, CLACPY, CLASET, CUNCSD, CHERK + EXTERNAL CGEMM, CHERK, CLACPY, CLASET, CUNCSD, + $ CUNCSD2BY1 * .. * .. Intrinsic Functions .. - INTRINSIC REAL, MAX, MIN + INTRINSIC CMPLX, COS, MAX, MIN, REAL, SIN * .. * .. Executable Statements .. * ULP = SLAMCH( 'Precision' ) ULPINV = REALONE / ULP +* +* The first half of the routine checks the 2-by-2 CSD +* CALL CLASET( 'Full', M, M, ZERO, ONE, WORK, LDX ) CALL CHERK( 'Upper', 'Conjugate transpose', M, M, -REALONE, $ X, LDX, REALONE, WORK, LDX ) @@ -269,86 +298,88 @@ $ THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, $ WORK, LWORK, RWORK, 17*(R+2), IWORK, INFO ) * -* Compute X := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22] +* Compute XF := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22] +* + CALL CLACPY( 'Full', M, M, X, LDX, XF, LDX ) * CALL CGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE, - $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX ) + $ XF, LDX, V1T, LDV1T, ZERO, WORK, LDX ) * CALL CGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE, - $ U1, LDU1, WORK, LDX, ZERO, X, LDX ) + $ U1, LDU1, WORK, LDX, ZERO, XF, LDX ) * DO I = 1, MIN(P,Q)-R - X(I,I) = X(I,I) - ONE + XF(I,I) = XF(I,I) - ONE END DO DO I = 1, R - X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) = - $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - CMPLX( COS(THETA(I)), + XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) = + $ XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - CMPLX( COS(THETA(I)), $ 0.0E0 ) END DO * CALL CGEMM( 'No transpose', 'Conjugate transpose', P, M-Q, M-Q, - $ ONE, X(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX ) + $ ONE, XF(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX ) * CALL CGEMM( 'Conjugate transpose', 'No transpose', P, M-Q, P, - $ ONE, U1, LDU1, WORK, LDX, ZERO, X(1,Q+1), LDX ) + $ ONE, U1, LDU1, WORK, LDX, ZERO, XF(1,Q+1), LDX ) * DO I = 1, MIN(P,M-Q)-R - X(P-I+1,M-I+1) = X(P-I+1,M-I+1) + ONE + XF(P-I+1,M-I+1) = XF(P-I+1,M-I+1) + ONE END DO DO I = 1, R - X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) = - $ X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) + + XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) = + $ XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) + $ CMPLX( SIN(THETA(R-I+1)), 0.0E0 ) END DO * CALL CGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE, - $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX ) + $ XF(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX ) * CALL CGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P, - $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX ) + $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,1), LDX ) * DO I = 1, MIN(M-P,Q)-R - X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE + XF(M-I+1,Q-I+1) = XF(M-I+1,Q-I+1) - ONE END DO DO I = 1, R - X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) = - $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) - + XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) = + $ XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) - $ CMPLX( SIN(THETA(R-I+1)), 0.0E0 ) END DO * CALL CGEMM( 'No transpose', 'Conjugate transpose', M-P, M-Q, M-Q, - $ ONE, X(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX ) + $ ONE, XF(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX ) * CALL CGEMM( 'Conjugate transpose', 'No transpose', M-P, M-Q, M-P, - $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,Q+1), LDX ) + $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,Q+1), LDX ) * DO I = 1, MIN(M-P,M-Q)-R - X(P+I,Q+I) = X(P+I,Q+I) - ONE + XF(P+I,Q+I) = XF(P+I,Q+I) - ONE END DO DO I = 1, R - X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) = - $ X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) - + XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) = + $ XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) - $ CMPLX( COS(THETA(I)), 0.0E0 ) END DO * * Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) . * - RESID = CLANGE( '1', P, Q, X, LDX, RWORK ) + RESID = CLANGE( '1', P, Q, XF, LDX, RWORK ) RESULT( 1 ) = ( RESID / REAL(MAX(1,P,Q)) ) / EPS2 * * Compute norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 ) . * - RESID = CLANGE( '1', P, M-Q, X(1,Q+1), LDX, RWORK ) + RESID = CLANGE( '1', P, M-Q, XF(1,Q+1), LDX, RWORK ) RESULT( 2 ) = ( RESID / REAL(MAX(1,P,M-Q)) ) / EPS2 * * Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) . * - RESID = CLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK ) + RESID = CLANGE( '1', M-P, Q, XF(P+1,1), LDX, RWORK ) RESULT( 3 ) = ( RESID / REAL(MAX(1,M-P,Q)) ) / EPS2 * * Compute norm( U2'*X22*V2 - D22 ) / ( MAX(1,M-P,M-Q)*EPS2 ) . * - RESID = CLANGE( '1', M-P, M-Q, X(P+1,Q+1), LDX, RWORK ) + RESID = CLANGE( '1', M-P, M-Q, XF(P+1,Q+1), LDX, RWORK ) RESULT( 4 ) = ( RESID / REAL(MAX(1,M-P,M-Q)) ) / EPS2 * * Compute I - U1'*U1 @@ -397,14 +428,126 @@ * * Check sorting * - RESULT(9) = REALZERO + RESULT( 9 ) = REALZERO + DO I = 1, R + IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN + RESULT( 9 ) = ULPINV + END IF + IF( I.GT.1) THEN + IF ( THETA(I).LT.THETA(I-1) ) THEN + RESULT( 9 ) = ULPINV + END IF + END IF + END DO +* +* The second half of the routine checks the 2-by-1 CSD +* + CALL CLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDX ) + CALL CHERK( 'Upper', 'Conjugate transpose', Q, M, -REALONE, + $ X, LDX, REALONE, WORK, LDX ) + IF (M.GT.0) THEN + EPS2 = MAX( ULP, + $ CLANGE( '1', Q, Q, WORK, LDX, RWORK ) / REAL( M ) ) + ELSE + EPS2 = ULP + END IF + R = MIN( P, M-P, Q, M-Q ) +* +* Copy the matrix X to the array XF. +* + CALL CLACPY( 'Full', M, Q, X, LDX, XF, LDX ) +* +* Compute the CSD +* + CALL CUNCSD2BY1( 'Y', 'Y', 'Y', M, P, Q, XF(1,1), LDX, XF(P+1,1), + $ LDX, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, WORK, + $ LWORK, RWORK, 17*(R+2), IWORK, INFO ) +* +* Compute [X11;X21] := diag(U1,U2)'*[X11;X21]*V1 - [D11;D21] +* + CALL CGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE, + $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX ) +* + CALL CGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE, + $ U1, LDU1, WORK, LDX, ZERO, X, LDX ) +* + DO I = 1, MIN(P,Q)-R + X(I,I) = X(I,I) - ONE + END DO + DO I = 1, R + X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) = + $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - CMPLX( COS(THETA(I)), + $ 0.0E0 ) + END DO +* + CALL CGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE, + $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX ) +* + CALL CGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P, + $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX ) +* + DO I = 1, MIN(M-P,Q)-R + X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE + END DO + DO I = 1, R + X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) = + $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) - + $ CMPLX( SIN(THETA(R-I+1)), 0.0E0 ) + END DO +* +* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) . +* + RESID = CLANGE( '1', P, Q, X, LDX, RWORK ) + RESULT( 10 ) = ( RESID / REAL(MAX(1,P,Q)) ) / EPS2 +* +* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) . +* + RESID = CLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK ) + RESULT( 11 ) = ( RESID / REAL(MAX(1,M-P,Q)) ) / EPS2 +* +* Compute I - U1'*U1 +* + CALL CLASET( 'Full', P, P, ZERO, ONE, WORK, LDU1 ) + CALL CHERK( 'Upper', 'Conjugate transpose', P, P, -REALONE, + $ U1, LDU1, REALONE, WORK, LDU1 ) +* +* Compute norm( I - U1'*U1 ) / ( MAX(1,P) * ULP ) . +* + RESID = CLANHE( '1', 'Upper', P, WORK, LDU1, RWORK ) + RESULT( 12 ) = ( RESID / REAL(MAX(1,P)) ) / ULP +* +* Compute I - U2'*U2 +* + CALL CLASET( 'Full', M-P, M-P, ZERO, ONE, WORK, LDU2 ) + CALL CHERK( 'Upper', 'Conjugate transpose', M-P, M-P, -REALONE, + $ U2, LDU2, REALONE, WORK, LDU2 ) +* +* Compute norm( I - U2'*U2 ) / ( MAX(1,M-P) * ULP ) . +* + RESID = CLANHE( '1', 'Upper', M-P, WORK, LDU2, RWORK ) + RESULT( 13 ) = ( RESID / REAL(MAX(1,M-P)) ) / ULP +* +* Compute I - V1T*V1T' +* + CALL CLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDV1T ) + CALL CHERK( 'Upper', 'No transpose', Q, Q, -REALONE, + $ V1T, LDV1T, REALONE, WORK, LDV1T ) +* +* Compute norm( I - V1T*V1T' ) / ( MAX(1,Q) * ULP ) . +* + RESID = CLANHE( '1', 'Upper', Q, WORK, LDV1T, RWORK ) + RESULT( 14 ) = ( RESID / REAL(MAX(1,Q)) ) / ULP +* +* Check sorting +* + RESULT( 15 ) = REALZERO DO I = 1, R IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN - RESULT(9) = ULPINV + RESULT( 15 ) = ULPINV END IF IF( I.GT.1) THEN IF ( THETA(I).LT.THETA(I-1) ) THEN - RESULT(9) = ULPINV + RESULT( 15 ) = ULPINV END IF END IF END DO @@ -414,4 +557,3 @@ * End of CCSDTS * END - diff --git a/lapack-netlib/TESTING/EIG/dchkee.f b/lapack-netlib/TESTING/EIG/dchkee.f index 86cf7ba87..bde28f234 100644 --- a/lapack-netlib/TESTING/EIG/dchkee.f +++ b/lapack-netlib/TESTING/EIG/dchkee.f @@ -1032,17 +1032,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup double_eig * * ===================================================================== PROGRAM DCHKEE * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * ===================================================================== * @@ -1133,6 +1133,10 @@ * .. * .. Executable Statements .. * + A = 0.0 + B = 0.0 + C = 0.0 + D = 0.0 S1 = DSECND( ) FATAL = .FALSE. NUNIT = NOUT diff --git a/lapack-netlib/TESTING/EIG/dckcsd.f b/lapack-netlib/TESTING/EIG/dckcsd.f index 94892b793..219ebafcf 100644 --- a/lapack-netlib/TESTING/EIG/dckcsd.f +++ b/lapack-netlib/TESTING/EIG/dckcsd.f @@ -205,13 +205,14 @@ * * .. Parameters .. INTEGER NTESTS - PARAMETER ( NTESTS = 9 ) + PARAMETER ( NTESTS = 15 ) INTEGER NTYPES - PARAMETER ( NTYPES = 3 ) - DOUBLE PRECISION GAPDIGIT, ORTH, PIOVER2, TEN - PARAMETER ( GAPDIGIT = 18.0D0, ORTH = 1.0D-12, + PARAMETER ( NTYPES = 4 ) + DOUBLE PRECISION GAPDIGIT, ONE, ORTH, PIOVER2, TEN, ZERO + PARAMETER ( GAPDIGIT = 18.0D0, ONE = 1.0D0, + $ ORTH = 1.0D-12, $ PIOVER2 = 1.57079632679489662D0, - $ TEN = 10.0D0 ) + $ TEN = 10.0D0, ZERO = 0.0D0 ) * .. * .. Local Scalars .. LOGICAL FIRSTT @@ -231,8 +232,8 @@ INTRINSIC ABS, MIN * .. * .. External Functions .. - DOUBLE PRECISION DLARND - EXTERNAL DLARND + DOUBLE PRECISION DLARAN, DLARND + EXTERNAL DLARAN, DLARND * .. * .. Executable Statements .. * @@ -286,7 +287,7 @@ $ ORTH*DLARND(2,ISEED) END DO END DO - ELSE + ELSE IF( IMAT.EQ.3 ) THEN R = MIN( P, M-P, Q, M-Q ) DO I = 1, R+1 THETA(I) = TEN**(-DLARND(1,ISEED)*GAPDIGIT) @@ -298,9 +299,18 @@ THETA(I) = PIOVER2 * THETA(I) / THETA(R+1) END DO CALL DLACSG( M, P, Q, THETA, ISEED, X, LDX, WORK ) + ELSE + CALL DLASET( 'F', M, M, ZERO, ONE, X, LDX ) + DO I = 1, M + J = INT( DLARAN( ISEED ) * M ) + 1 + IF( J .NE. I ) THEN + CALL DROT( M, X(1+(I-1)*LDX), 1, X(1+(J-1)*LDX), 1, + $ ZERO, ONE ) + END IF + END DO END IF * - NT = 9 + NT = 15 * CALL DCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, $ LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK, diff --git a/lapack-netlib/TESTING/EIG/dcsdts.f b/lapack-netlib/TESTING/EIG/dcsdts.f index de0e3a93a..528092a1d 100644 --- a/lapack-netlib/TESTING/EIG/dcsdts.f +++ b/lapack-netlib/TESTING/EIG/dcsdts.f @@ -17,7 +17,7 @@ * .. * .. Array Arguments .. * INTEGER IWORK( * ) -* DOUBLE PRECISION RESULT( 9 ), RWORK( * ), THETA( * ) +* DOUBLE PRECISION RESULT( 15 ), RWORK( * ), THETA( * ) * DOUBLE PRECISION U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ), * $ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ), * $ XF( LDX, * ) @@ -43,10 +43,25 @@ *> [ I 0 0 | 0 0 0 ] *> [ 0 C 0 | 0 -S 0 ] *> [ 0 0 0 | 0 0 -I ] -*> = [---------------------] = [ D11 D12 ] . +*> = [---------------------] = [ D11 D12 ] , *> [ 0 0 0 | I 0 0 ] [ D21 D22 ] *> [ 0 S 0 | 0 C 0 ] *> [ 0 0 I | 0 0 0 ] +*> +*> and also DORCSD2BY1, which, given +*> Q +*> [ X11 ] P , +*> [ X21 ] M-P +*> +*> computes the 2-by-1 CSD +*> +*> [ I 0 0 ] +*> [ 0 C 0 ] +*> [ 0 0 0 ] +*> [ U1 ]**T * [ X11 ] * V1 = [----------] = [ D11 ] , +*> [ U2 ] [ X21 ] [ 0 0 0 ] [ D21 ] +*> [ 0 S 0 ] +*> [ 0 0 I ] *> \endverbatim * * Arguments: @@ -171,8 +186,9 @@ *> *> \param[out] RESULT *> \verbatim -*> RESULT is DOUBLE PRECISION array, dimension (9) +*> RESULT is DOUBLE PRECISION array, dimension (15) *> The test ratios: +*> First, the 2-by-2 CSD: *> RESULT(1) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) *> RESULT(2) = norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 ) *> RESULT(3) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) @@ -184,6 +200,15 @@ *> RESULT(9) = 0 if THETA is in increasing order and *> all angles are in [0,pi/2]; *> = ULPINV otherwise. +*> Then, the 2-by-1 CSD: +*> RESULT(10) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) +*> RESULT(11) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) +*> RESULT(12) = norm( I - U1'*U1 ) / ( MAX(1,P)*ULP ) +*> RESULT(13) = norm( I - U2'*U2 ) / ( MAX(1,M-P)*ULP ) +*> RESULT(14) = norm( I - V1T'*V1T ) / ( MAX(1,Q)*ULP ) +*> RESULT(15) = 0 if THETA is in increasing order and +*> all angles are in [0,pi/2]; +*> = ULPINV otherwise. *> ( EPS2 = MAX( norm( I - X'*X ) / M, ULP ). ) *> \endverbatim * @@ -214,7 +239,7 @@ * .. * .. Array Arguments .. INTEGER IWORK( * ) - DOUBLE PRECISION RESULT( 9 ), RWORK( * ), THETA( * ) + DOUBLE PRECISION RESULT( 15 ), RWORK( * ), THETA( * ) DOUBLE PRECISION U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ), $ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ), $ XF( LDX, * ) @@ -238,15 +263,19 @@ EXTERNAL DLAMCH, DLANGE, DLANSY * .. * .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DLASET, DORCSD, DSYRK + EXTERNAL DGEMM, DLACPY, DLASET, DORCSD, DORCSD2BY1, + $ DSYRK * .. * .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN + INTRINSIC COS, DBLE, MAX, MIN, SIN * .. * .. Executable Statements .. * ULP = DLAMCH( 'Precision' ) ULPINV = REALONE / ULP +* +* The first half of the routine checks the 2-by-2 CSD +* CALL DLASET( 'Full', M, M, ZERO, ONE, WORK, LDX ) CALL DSYRK( 'Upper', 'Conjugate transpose', M, M, -ONE, X, LDX, $ ONE, WORK, LDX ) @@ -269,85 +298,87 @@ $ THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, $ WORK, LWORK, IWORK, INFO ) * -* Compute X := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22] +* Compute XF := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22] +* + CALL DLACPY( 'Full', M, M, X, LDX, XF, LDX ) * CALL DGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE, - $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX ) + $ XF, LDX, V1T, LDV1T, ZERO, WORK, LDX ) * CALL DGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE, - $ U1, LDU1, WORK, LDX, ZERO, X, LDX ) + $ U1, LDU1, WORK, LDX, ZERO, XF, LDX ) * DO I = 1, MIN(P,Q)-R - X(I,I) = X(I,I) - ONE + XF(I,I) = XF(I,I) - ONE END DO DO I = 1, R - X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) = - $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - COS(THETA(I)) + XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) = + $ XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - COS(THETA(I)) END DO * CALL DGEMM( 'No transpose', 'Conjugate transpose', P, M-Q, M-Q, - $ ONE, X(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX ) + $ ONE, XF(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX ) * CALL DGEMM( 'Conjugate transpose', 'No transpose', P, M-Q, P, - $ ONE, U1, LDU1, WORK, LDX, ZERO, X(1,Q+1), LDX ) + $ ONE, U1, LDU1, WORK, LDX, ZERO, XF(1,Q+1), LDX ) * DO I = 1, MIN(P,M-Q)-R - X(P-I+1,M-I+1) = X(P-I+1,M-I+1) + ONE + XF(P-I+1,M-I+1) = XF(P-I+1,M-I+1) + ONE END DO DO I = 1, R - X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) = - $ X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) + + XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) = + $ XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) + $ SIN(THETA(R-I+1)) END DO * CALL DGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE, - $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX ) + $ XF(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX ) * CALL DGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P, - $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX ) + $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,1), LDX ) * DO I = 1, MIN(M-P,Q)-R - X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE + XF(M-I+1,Q-I+1) = XF(M-I+1,Q-I+1) - ONE END DO DO I = 1, R - X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) = - $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) - + XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) = + $ XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) - $ SIN(THETA(R-I+1)) END DO * CALL DGEMM( 'No transpose', 'Conjugate transpose', M-P, M-Q, M-Q, - $ ONE, X(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX ) + $ ONE, XF(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX ) * CALL DGEMM( 'Conjugate transpose', 'No transpose', M-P, M-Q, M-P, - $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,Q+1), LDX ) + $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,Q+1), LDX ) * DO I = 1, MIN(M-P,M-Q)-R - X(P+I,Q+I) = X(P+I,Q+I) - ONE + XF(P+I,Q+I) = XF(P+I,Q+I) - ONE END DO DO I = 1, R - X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) = - $ X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) - + XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) = + $ XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) - $ COS(THETA(I)) END DO * * Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) . * - RESID = DLANGE( '1', P, Q, X, LDX, RWORK ) + RESID = DLANGE( '1', P, Q, XF, LDX, RWORK ) RESULT( 1 ) = ( RESID / DBLE(MAX(1,P,Q)) ) / EPS2 * * Compute norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 ) . * - RESID = DLANGE( '1', P, M-Q, X(1,Q+1), LDX, RWORK ) + RESID = DLANGE( '1', P, M-Q, XF(1,Q+1), LDX, RWORK ) RESULT( 2 ) = ( RESID / DBLE(MAX(1,P,M-Q)) ) / EPS2 * * Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) . * - RESID = DLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK ) + RESID = DLANGE( '1', M-P, Q, XF(P+1,1), LDX, RWORK ) RESULT( 3 ) = ( RESID / DBLE(MAX(1,M-P,Q)) ) / EPS2 * * Compute norm( U2'*X22*V2 - D22 ) / ( MAX(1,M-P,M-Q)*EPS2 ) . * - RESID = DLANGE( '1', M-P, M-Q, X(P+1,Q+1), LDX, RWORK ) + RESID = DLANGE( '1', M-P, M-Q, XF(P+1,Q+1), LDX, RWORK ) RESULT( 4 ) = ( RESID / DBLE(MAX(1,M-P,M-Q)) ) / EPS2 * * Compute I - U1'*U1 @@ -396,14 +427,125 @@ * * Check sorting * - RESULT(9) = REALZERO + RESULT( 9 ) = REALZERO + DO I = 1, R + IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN + RESULT( 9 ) = ULPINV + END IF + IF( I.GT.1 ) THEN + IF ( THETA(I).LT.THETA(I-1) ) THEN + RESULT( 9 ) = ULPINV + END IF + END IF + END DO +* +* The second half of the routine checks the 2-by-1 CSD +* + CALL DLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDX ) + CALL DSYRK( 'Upper', 'Conjugate transpose', Q, M, -ONE, X, LDX, + $ ONE, WORK, LDX ) + IF( M.GT.0 ) THEN + EPS2 = MAX( ULP, + $ DLANGE( '1', Q, Q, WORK, LDX, RWORK ) / DBLE( M ) ) + ELSE + EPS2 = ULP + END IF + R = MIN( P, M-P, Q, M-Q ) +* +* Copy the matrix [ X11; X21 ] to the array XF. +* + CALL DLACPY( 'Full', M, Q, X, LDX, XF, LDX ) +* +* Compute the CSD +* + CALL DORCSD2BY1( 'Y', 'Y', 'Y', M, P, Q, XF(1,1), LDX, XF(P+1,1), + $ LDX, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, WORK, + $ LWORK, IWORK, INFO ) +* +* Compute [X11;X21] := diag(U1,U2)'*[X11;X21]*V1 - [D11;D21] +* + CALL DGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE, + $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX ) +* + CALL DGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE, + $ U1, LDU1, WORK, LDX, ZERO, X, LDX ) +* + DO I = 1, MIN(P,Q)-R + X(I,I) = X(I,I) - ONE + END DO + DO I = 1, R + X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) = + $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - COS(THETA(I)) + END DO +* + CALL DGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE, + $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX ) +* + CALL DGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P, + $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX ) +* + DO I = 1, MIN(M-P,Q)-R + X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE + END DO + DO I = 1, R + X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) = + $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) - + $ SIN(THETA(R-I+1)) + END DO +* +* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) . +* + RESID = DLANGE( '1', P, Q, X, LDX, RWORK ) + RESULT( 10 ) = ( RESID / DBLE(MAX(1,P,Q)) ) / EPS2 +* +* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) . +* + RESID = DLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK ) + RESULT( 11 ) = ( RESID / DBLE(MAX(1,M-P,Q)) ) / EPS2 +* +* Compute I - U1'*U1 +* + CALL DLASET( 'Full', P, P, ZERO, ONE, WORK, LDU1 ) + CALL DSYRK( 'Upper', 'Conjugate transpose', P, P, -ONE, U1, LDU1, + $ ONE, WORK, LDU1 ) +* +* Compute norm( I - U1'*U1 ) / ( MAX(1,P) * ULP ) . +* + RESID = DLANSY( '1', 'Upper', P, WORK, LDU1, RWORK ) + RESULT( 12 ) = ( RESID / DBLE(MAX(1,P)) ) / ULP +* +* Compute I - U2'*U2 +* + CALL DLASET( 'Full', M-P, M-P, ZERO, ONE, WORK, LDU2 ) + CALL DSYRK( 'Upper', 'Conjugate transpose', M-P, M-P, -ONE, U2, + $ LDU2, ONE, WORK, LDU2 ) +* +* Compute norm( I - U2'*U2 ) / ( MAX(1,M-P) * ULP ) . +* + RESID = DLANSY( '1', 'Upper', M-P, WORK, LDU2, RWORK ) + RESULT( 13 ) = ( RESID / DBLE(MAX(1,M-P)) ) / ULP +* +* Compute I - V1T*V1T' +* + CALL DLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDV1T ) + CALL DSYRK( 'Upper', 'No transpose', Q, Q, -ONE, V1T, LDV1T, ONE, + $ WORK, LDV1T ) +* +* Compute norm( I - V1T*V1T' ) / ( MAX(1,Q) * ULP ) . +* + RESID = DLANSY( '1', 'Upper', Q, WORK, LDV1T, RWORK ) + RESULT( 14 ) = ( RESID / DBLE(MAX(1,Q)) ) / ULP +* +* Check sorting +* + RESULT( 15 ) = REALZERO DO I = 1, R IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN - RESULT(9) = ULPINV + RESULT( 15 ) = ULPINV END IF - IF( I.GT.1) THEN + IF( I.GT.1 ) THEN IF ( THETA(I).LT.THETA(I-1) ) THEN - RESULT(9) = ULPINV + RESULT( 15 ) = ULPINV END IF END IF END DO diff --git a/lapack-netlib/TESTING/EIG/dlahd2.f b/lapack-netlib/TESTING/EIG/dlahd2.f index 2f1cc068a..530c5d66e 100644 --- a/lapack-netlib/TESTING/EIG/dlahd2.f +++ b/lapack-netlib/TESTING/EIG/dlahd2.f @@ -58,17 +58,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup double_eig * * ===================================================================== SUBROUTINE DLAHD2( IOUNIT, PATH ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -501,8 +501,8 @@ $ / ' 2: norm( I - Q'' Q ) / ( m ulp )', $ / ' 3: norm( I - PT PT'' ) / ( n ulp )', $ / ' 4: norm( Y - Q'' C ) / ( norm(Y) max(m,nrhs) ulp )' ) - 9968 FORMAT( / ' Tests performed: See sdrvst.f' ) - 9967 FORMAT( / ' Tests performed: See cdrvst.f' ) + 9968 FORMAT( / ' Tests performed: See ddrvst.f' ) + 9967 FORMAT( / ' Tests performed: See sdrvst.f' ) * * End of DLAHD2 * diff --git a/lapack-netlib/TESTING/EIG/schkee.f b/lapack-netlib/TESTING/EIG/schkee.f index 78268622c..946b73cb0 100644 --- a/lapack-netlib/TESTING/EIG/schkee.f +++ b/lapack-netlib/TESTING/EIG/schkee.f @@ -1032,17 +1032,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup single_eig * * ===================================================================== PROGRAM SCHKEE * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * ===================================================================== * @@ -1133,6 +1133,10 @@ * .. * .. Executable Statements .. * + A = 0.0 + B = 0.0 + C = 0.0 + D = 0.0 S1 = SECOND( ) FATAL = .FALSE. NUNIT = NOUT diff --git a/lapack-netlib/TESTING/EIG/sckcsd.f b/lapack-netlib/TESTING/EIG/sckcsd.f index fe5de85a7..20ba3d66f 100644 --- a/lapack-netlib/TESTING/EIG/sckcsd.f +++ b/lapack-netlib/TESTING/EIG/sckcsd.f @@ -205,13 +205,14 @@ * * .. Parameters .. INTEGER NTESTS - PARAMETER ( NTESTS = 9 ) + PARAMETER ( NTESTS = 15 ) INTEGER NTYPES - PARAMETER ( NTYPES = 3 ) - REAL GAPDIGIT, ORTH, PIOVER2, TEN - PARAMETER ( GAPDIGIT = 10.0E0, ORTH = 1.0E-4, + PARAMETER ( NTYPES = 4 ) + REAL GAPDIGIT, ONE, ORTH, PIOVER2, TEN, ZERO + PARAMETER ( GAPDIGIT = 10.0E0, ONE = 1.0E0, + $ ORTH = 1.0E-4, $ PIOVER2 = 1.57079632679489662E0, - $ TEN = 10.0D0 ) + $ TEN = 10.0E0, ZERO = 0.0E0 ) * .. * .. Local Scalars .. LOGICAL FIRSTT @@ -231,8 +232,8 @@ INTRINSIC ABS, MIN * .. * .. External Functions .. - REAL SLARND - EXTERNAL SLARND + REAL SLARAN, SLARND + EXTERNAL SLARAN, SLARND * .. * .. Executable Statements .. * @@ -286,7 +287,7 @@ $ ORTH*SLARND(2,ISEED) END DO END DO - ELSE + ELSE IF( IMAT.EQ.3 ) THEN R = MIN( P, M-P, Q, M-Q ) DO I = 1, R+1 THETA(I) = TEN**(-SLARND(1,ISEED)*GAPDIGIT) @@ -298,9 +299,18 @@ THETA(I) = PIOVER2 * THETA(I) / THETA(R+1) END DO CALL SLACSG( M, P, Q, THETA, ISEED, X, LDX, WORK ) + ELSE + CALL SLASET( 'F', M, M, ZERO, ONE, X, LDX ) + DO I = 1, M + J = INT( SLARAN( ISEED ) * M ) + 1 + IF( J .NE. I ) THEN + CALL SROT( M, X(1+(I-1)*LDX), 1, X(1+(J-1)*LDX), 1, + $ ZERO, ONE ) + END IF + END DO END IF * - NT = 9 + NT = 15 * CALL SCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, $ LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK, diff --git a/lapack-netlib/TESTING/EIG/scsdts.f b/lapack-netlib/TESTING/EIG/scsdts.f index 74b32eadd..a326f356c 100644 --- a/lapack-netlib/TESTING/EIG/scsdts.f +++ b/lapack-netlib/TESTING/EIG/scsdts.f @@ -17,7 +17,7 @@ * .. * .. Array Arguments .. * INTEGER IWORK( * ) -* REAL RESULT( 9 ), RWORK( * ), THETA( * ) +* REAL RESULT( 15 ), RWORK( * ), THETA( * ) * REAL U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ), * $ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ), * $ XF( LDX, * ) @@ -47,6 +47,21 @@ *> [ 0 0 0 | I 0 0 ] [ D21 D22 ] *> [ 0 S 0 | 0 C 0 ] *> [ 0 0 I | 0 0 0 ] +*> +*> and also SORCSD2BY1, which, given +*> Q +*> [ X11 ] P , +*> [ X21 ] M-P +*> +*> computes the 2-by-1 CSD +*> +*> [ I 0 0 ] +*> [ 0 C 0 ] +*> [ 0 0 0 ] +*> [ U1 ]**T * [ X11 ] * V1 = [----------] = [ D11 ] , +*> [ U2 ] [ X21 ] [ 0 0 0 ] [ D21 ] +*> [ 0 S 0 ] +*> [ 0 0 I ] *> \endverbatim * * Arguments: @@ -171,8 +186,9 @@ *> *> \param[out] RESULT *> \verbatim -*> RESULT is REAL array, dimension (9) +*> RESULT is REAL array, dimension (15) *> The test ratios: +*> First, the 2-by-2 CSD: *> RESULT(1) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) *> RESULT(2) = norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 ) *> RESULT(3) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) @@ -184,6 +200,15 @@ *> RESULT(9) = 0 if THETA is in increasing order and *> all angles are in [0,pi/2]; *> = ULPINV otherwise. +*> Then, the 2-by-1 CSD: +*> RESULT(10) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) +*> RESULT(11) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) +*> RESULT(12) = norm( I - U1'*U1 ) / ( MAX(1,P)*ULP ) +*> RESULT(13) = norm( I - U2'*U2 ) / ( MAX(1,M-P)*ULP ) +*> RESULT(14) = norm( I - V1T'*V1T ) / ( MAX(1,Q)*ULP ) +*> RESULT(15) = 0 if THETA is in increasing order and +*> all angles are in [0,pi/2]; +*> = ULPINV otherwise. *> ( EPS2 = MAX( norm( I - X'*X ) / M, ULP ). ) *> \endverbatim * @@ -214,7 +239,7 @@ * .. * .. Array Arguments .. INTEGER IWORK( * ) - REAL RESULT( 9 ), RWORK( * ), THETA( * ) + REAL RESULT( 15 ), RWORK( * ), THETA( * ) REAL U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ), $ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ), $ XF( LDX, * ) @@ -238,15 +263,19 @@ EXTERNAL SLAMCH, SLANGE, SLANSY * .. * .. External Subroutines .. - EXTERNAL SGEMM, SLACPY, SLASET, SORCSD, SSYRK + EXTERNAL SGEMM, SLACPY, SLASET, SORCSD, SORCSD2BY1, + $ SSYRK * .. * .. Intrinsic Functions .. - INTRINSIC REAL, MAX, MIN + INTRINSIC COS, MAX, MIN, REAL, SIN * .. * .. Executable Statements .. * ULP = SLAMCH( 'Precision' ) ULPINV = REALONE / ULP +* +* The first half of the routine checks the 2-by-2 CSD +* CALL SLASET( 'Full', M, M, ZERO, ONE, WORK, LDX ) CALL SSYRK( 'Upper', 'Conjugate transpose', M, M, -ONE, X, LDX, $ ONE, WORK, LDX ) @@ -269,85 +298,87 @@ $ THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, $ WORK, LWORK, IWORK, INFO ) * -* Compute X := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22] +* Compute XF := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22] +* + CALL SLACPY( 'Full', M, M, X, LDX, XF, LDX ) * CALL SGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE, - $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX ) + $ XF, LDX, V1T, LDV1T, ZERO, WORK, LDX ) * CALL SGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE, - $ U1, LDU1, WORK, LDX, ZERO, X, LDX ) + $ U1, LDU1, WORK, LDX, ZERO, XF, LDX ) * DO I = 1, MIN(P,Q)-R - X(I,I) = X(I,I) - ONE + XF(I,I) = XF(I,I) - ONE END DO DO I = 1, R - X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) = - $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - COS(THETA(I)) + XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) = + $ XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - COS(THETA(I)) END DO * CALL SGEMM( 'No transpose', 'Conjugate transpose', P, M-Q, M-Q, - $ ONE, X(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX ) + $ ONE, XF(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX ) * CALL SGEMM( 'Conjugate transpose', 'No transpose', P, M-Q, P, - $ ONE, U1, LDU1, WORK, LDX, ZERO, X(1,Q+1), LDX ) + $ ONE, U1, LDU1, WORK, LDX, ZERO, XF(1,Q+1), LDX ) * DO I = 1, MIN(P,M-Q)-R - X(P-I+1,M-I+1) = X(P-I+1,M-I+1) + ONE + XF(P-I+1,M-I+1) = XF(P-I+1,M-I+1) + ONE END DO DO I = 1, R - X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) = - $ X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) + + XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) = + $ XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) + $ SIN(THETA(R-I+1)) END DO * CALL SGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE, - $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX ) + $ XF(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX ) * CALL SGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P, - $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX ) + $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,1), LDX ) * DO I = 1, MIN(M-P,Q)-R - X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE + XF(M-I+1,Q-I+1) = XF(M-I+1,Q-I+1) - ONE END DO DO I = 1, R - X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) = - $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) - + XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) = + $ XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) - $ SIN(THETA(R-I+1)) END DO * CALL SGEMM( 'No transpose', 'Conjugate transpose', M-P, M-Q, M-Q, - $ ONE, X(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX ) + $ ONE, XF(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX ) * CALL SGEMM( 'Conjugate transpose', 'No transpose', M-P, M-Q, M-P, - $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,Q+1), LDX ) + $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,Q+1), LDX ) * DO I = 1, MIN(M-P,M-Q)-R - X(P+I,Q+I) = X(P+I,Q+I) - ONE + XF(P+I,Q+I) = XF(P+I,Q+I) - ONE END DO DO I = 1, R - X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) = - $ X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) - + XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) = + $ XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) - $ COS(THETA(I)) END DO * * Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) . * - RESID = SLANGE( '1', P, Q, X, LDX, RWORK ) + RESID = SLANGE( '1', P, Q, XF, LDX, RWORK ) RESULT( 1 ) = ( RESID / REAL(MAX(1,P,Q)) ) / EPS2 * * Compute norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 ) . * - RESID = SLANGE( '1', P, M-Q, X(1,Q+1), LDX, RWORK ) + RESID = SLANGE( '1', P, M-Q, XF(1,Q+1), LDX, RWORK ) RESULT( 2 ) = ( RESID / REAL(MAX(1,P,M-Q)) ) / EPS2 * * Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) . * - RESID = SLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK ) + RESID = SLANGE( '1', M-P, Q, XF(P+1,1), LDX, RWORK ) RESULT( 3 ) = ( RESID / REAL(MAX(1,M-P,Q)) ) / EPS2 * * Compute norm( U2'*X22*V2 - D22 ) / ( MAX(1,M-P,M-Q)*EPS2 ) . * - RESID = SLANGE( '1', M-P, M-Q, X(P+1,Q+1), LDX, RWORK ) + RESID = SLANGE( '1', M-P, M-Q, XF(P+1,Q+1), LDX, RWORK ) RESULT( 4 ) = ( RESID / REAL(MAX(1,M-P,M-Q)) ) / EPS2 * * Compute I - U1'*U1 @@ -396,14 +427,125 @@ * * Check sorting * - RESULT(9) = REALZERO + RESULT( 9 ) = REALZERO + DO I = 1, R + IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN + RESULT( 9 ) = ULPINV + END IF + IF( I.GT.1 ) THEN + IF ( THETA(I).LT.THETA(I-1) ) THEN + RESULT( 9 ) = ULPINV + END IF + END IF + END DO +* +* The second half of the routine checks the 2-by-1 CSD +* + CALL SLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDX ) + CALL SSYRK( 'Upper', 'Conjugate transpose', Q, M, -ONE, X, LDX, + $ ONE, WORK, LDX ) + IF (M.GT.0) THEN + EPS2 = MAX( ULP, + $ SLANGE( '1', Q, Q, WORK, LDX, RWORK ) / REAL( M ) ) + ELSE + EPS2 = ULP + END IF + R = MIN( P, M-P, Q, M-Q ) +* +* Copy the matrix [X11;X21] to the array XF. +* + CALL SLACPY( 'Full', M, Q, X, LDX, XF, LDX ) +* +* Compute the CSD +* + CALL SORCSD2BY1( 'Y', 'Y', 'Y', M, P, Q, XF(1,1), LDX, XF(P+1,1), + $ LDX, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, WORK, + $ LWORK, IWORK, INFO ) +* +* Compute [X11;X21] := diag(U1,U2)'*[X11;X21]*V1 - [D11;D21] +* + CALL SGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE, + $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX ) +* + CALL SGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE, + $ U1, LDU1, WORK, LDX, ZERO, X, LDX ) +* + DO I = 1, MIN(P,Q)-R + X(I,I) = X(I,I) - ONE + END DO + DO I = 1, R + X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) = + $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - COS(THETA(I)) + END DO +* + CALL SGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE, + $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX ) +* + CALL SGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P, + $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX ) +* + DO I = 1, MIN(M-P,Q)-R + X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE + END DO + DO I = 1, R + X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) = + $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) - + $ SIN(THETA(R-I+1)) + END DO +* +* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) . +* + RESID = SLANGE( '1', P, Q, X, LDX, RWORK ) + RESULT( 10 ) = ( RESID / REAL(MAX(1,P,Q)) ) / EPS2 +* +* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) . +* + RESID = SLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK ) + RESULT( 11 ) = ( RESID / REAL(MAX(1,M-P,Q)) ) / EPS2 +* +* Compute I - U1'*U1 +* + CALL SLASET( 'Full', P, P, ZERO, ONE, WORK, LDU1 ) + CALL SSYRK( 'Upper', 'Conjugate transpose', P, P, -ONE, U1, LDU1, + $ ONE, WORK, LDU1 ) +* +* Compute norm( I - U1'*U1 ) / ( MAX(1,P) * ULP ) . +* + RESID = SLANSY( '1', 'Upper', P, WORK, LDU1, RWORK ) + RESULT( 12 ) = ( RESID / REAL(MAX(1,P)) ) / ULP +* +* Compute I - U2'*U2 +* + CALL SLASET( 'Full', M-P, M-P, ZERO, ONE, WORK, LDU2 ) + CALL SSYRK( 'Upper', 'Conjugate transpose', M-P, M-P, -ONE, U2, + $ LDU2, ONE, WORK, LDU2 ) +* +* Compute norm( I - U2'*U2 ) / ( MAX(1,M-P) * ULP ) . +* + RESID = SLANSY( '1', 'Upper', M-P, WORK, LDU2, RWORK ) + RESULT( 13 ) = ( RESID / REAL(MAX(1,M-P)) ) / ULP +* +* Compute I - V1T*V1T' +* + CALL SLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDV1T ) + CALL SSYRK( 'Upper', 'No transpose', Q, Q, -ONE, V1T, LDV1T, ONE, + $ WORK, LDV1T ) +* +* Compute norm( I - V1T*V1T' ) / ( MAX(1,Q) * ULP ) . +* + RESID = SLANSY( '1', 'Upper', Q, WORK, LDV1T, RWORK ) + RESULT( 14 ) = ( RESID / REAL(MAX(1,Q)) ) / ULP +* +* Check sorting +* + RESULT( 15 ) = REALZERO DO I = 1, R IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN - RESULT(9) = ULPINV + RESULT( 15 ) = ULPINV END IF - IF( I.GT.1) THEN + IF( I.GT.1 ) THEN IF ( THETA(I).LT.THETA(I-1) ) THEN - RESULT(9) = ULPINV + RESULT( 15 ) = ULPINV END IF END IF END DO diff --git a/lapack-netlib/TESTING/EIG/zchkee.f b/lapack-netlib/TESTING/EIG/zchkee.f index 93ca8971e..ea58f377b 100644 --- a/lapack-netlib/TESTING/EIG/zchkee.f +++ b/lapack-netlib/TESTING/EIG/zchkee.f @@ -1026,17 +1026,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup complex16_eig * * ===================================================================== PROGRAM ZCHKEE * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * ===================================================================== * @@ -1129,6 +1129,10 @@ * .. * .. Executable Statements .. * + A = 0.0 + B = 0.0 + C = 0.0 + DC = 0.0 S1 = DSECND( ) FATAL = .FALSE. NUNIT = NOUT diff --git a/lapack-netlib/TESTING/EIG/zckcsd.f b/lapack-netlib/TESTING/EIG/zckcsd.f index 5385131ca..99ed5bd5d 100644 --- a/lapack-netlib/TESTING/EIG/zckcsd.f +++ b/lapack-netlib/TESTING/EIG/zckcsd.f @@ -205,13 +205,16 @@ * * .. Parameters .. INTEGER NTESTS - PARAMETER ( NTESTS = 9 ) + PARAMETER ( NTESTS = 15 ) INTEGER NTYPES - PARAMETER ( NTYPES = 3 ) - DOUBLE PRECISION GAPDIGIT, ORTH, PIOVER2, TEN + PARAMETER ( NTYPES = 4 ) + DOUBLE PRECISION GAPDIGIT, ORTH, PIOVER2, REALONE, REALZERO, TEN PARAMETER ( GAPDIGIT = 18.0D0, ORTH = 1.0D-12, $ PIOVER2 = 1.57079632679489662D0, + $ REALONE = 1.0D0, REALZERO = 0.0D0, $ TEN = 10.0D0 ) + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = (1.0D0,0.0D0), ZERO = (0.0D0,0.0D0) ) * .. * .. Local Scalars .. LOGICAL FIRSTT @@ -231,8 +234,8 @@ INTRINSIC ABS, MIN * .. * .. External Functions .. - DOUBLE PRECISION DLARND - EXTERNAL DLARND + DOUBLE PRECISION DLARAN, DLARND + EXTERNAL DLARAN, DLARND * .. * .. Executable Statements .. * @@ -286,7 +289,7 @@ $ ORTH*DLARND(2,ISEED) END DO END DO - ELSE + ELSE IF( IMAT.EQ.3 ) THEN R = MIN( P, M-P, Q, M-Q ) DO I = 1, R+1 THETA(I) = TEN**(-DLARND(1,ISEED)*GAPDIGIT) @@ -298,9 +301,18 @@ THETA(I) = PIOVER2 * THETA(I) / THETA(R+1) END DO CALL ZLACSG( M, P, Q, THETA, ISEED, X, LDX, WORK ) + ELSE + CALL ZLASET( 'F', M, M, ZERO, ONE, X, LDX ) + DO I = 1, M + J = INT( DLARAN( ISEED ) * M ) + 1 + IF( J .NE. I ) THEN + CALL ZDROT( M, X(1+(I-1)*LDX), 1, X(1+(J-1)*LDX), + $ 1, REALZERO, REALONE ) + END IF + END DO END IF * - NT = 9 + NT = 15 * CALL ZCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, $ LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK, diff --git a/lapack-netlib/TESTING/EIG/zcsdts.f b/lapack-netlib/TESTING/EIG/zcsdts.f index 9d8ba2b55..c745d186b 100644 --- a/lapack-netlib/TESTING/EIG/zcsdts.f +++ b/lapack-netlib/TESTING/EIG/zcsdts.f @@ -17,7 +17,7 @@ * .. * .. Array Arguments .. * INTEGER IWORK( * ) -* DOUBLE PRECISION RESULT( 9 ), RWORK( * ), THETA( * ) +* DOUBLE PRECISION RESULT( 15 ), RWORK( * ), THETA( * ) * COMPLEX*16 U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ), * $ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ), * $ XF( LDX, * ) @@ -47,6 +47,21 @@ *> [ 0 0 0 | I 0 0 ] [ D21 D22 ] *> [ 0 S 0 | 0 C 0 ] *> [ 0 0 I | 0 0 0 ] +*> +*> and also SORCSD2BY1, which, given +*> Q +*> [ X11 ] P , +*> [ X21 ] M-P +*> +*> computes the 2-by-1 CSD +*> +*> [ I 0 0 ] +*> [ 0 C 0 ] +*> [ 0 0 0 ] +*> [ U1 ]**T * [ X11 ] * V1 = [----------] = [ D11 ] , +*> [ U2 ] [ X21 ] [ 0 0 0 ] [ D21 ] +*> [ 0 S 0 ] +*> [ 0 0 I ] *> \endverbatim * * Arguments: @@ -171,8 +186,9 @@ *> *> \param[out] RESULT *> \verbatim -*> RESULT is DOUBLE PRECISION array, dimension (9) +*> RESULT is DOUBLE PRECISION array, dimension (15) *> The test ratios: +*> First, the 2-by-2 CSD: *> RESULT(1) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) *> RESULT(2) = norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 ) *> RESULT(3) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) @@ -184,6 +200,15 @@ *> RESULT(9) = 0 if THETA is in increasing order and *> all angles are in [0,pi/2]; *> = ULPINV otherwise. +*> Then, the 2-by-1 CSD: +*> RESULT(10) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) +*> RESULT(11) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) +*> RESULT(12) = norm( I - U1'*U1 ) / ( MAX(1,P)*ULP ) +*> RESULT(13) = norm( I - U2'*U2 ) / ( MAX(1,M-P)*ULP ) +*> RESULT(14) = norm( I - V1T'*V1T ) / ( MAX(1,Q)*ULP ) +*> RESULT(15) = 0 if THETA is in increasing order and +*> all angles are in [0,pi/2]; +*> = ULPINV otherwise. *> ( EPS2 = MAX( norm( I - X'*X ) / M, ULP ). ) *> \endverbatim * @@ -214,7 +239,7 @@ * .. * .. Array Arguments .. INTEGER IWORK( * ) - DOUBLE PRECISION RESULT( 9 ), RWORK( * ), THETA( * ) + DOUBLE PRECISION RESULT( 15 ), RWORK( * ), THETA( * ) COMPLEX*16 U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ), $ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ), $ XF( LDX, * ) @@ -238,15 +263,19 @@ EXTERNAL DLAMCH, ZLANGE, ZLANHE * .. * .. External Subroutines .. - EXTERNAL ZGEMM, ZLACPY, ZLASET, ZUNCSD, ZHERK + EXTERNAL ZGEMM, ZHERK, ZLACPY, ZLASET, ZUNCSD, + $ ZUNCSD2BY1 * .. * .. Intrinsic Functions .. - INTRINSIC REAL, MAX, MIN + INTRINSIC COS, DBLE, DCMPLX, MAX, MIN, REAL, SIN * .. * .. Executable Statements .. * ULP = DLAMCH( 'Precision' ) ULPINV = REALONE / ULP +* +* The first half of the routine checks the 2-by-2 CSD +* CALL ZLASET( 'Full', M, M, ZERO, ONE, WORK, LDX ) CALL ZHERK( 'Upper', 'Conjugate transpose', M, M, -REALONE, $ X, LDX, REALONE, WORK, LDX ) @@ -269,86 +298,88 @@ $ THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, $ WORK, LWORK, RWORK, 17*(R+2), IWORK, INFO ) * -* Compute X := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22] +* Compute XF := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22] +* + CALL ZLACPY( 'Full', M, M, X, LDX, XF, LDX ) * CALL ZGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE, - $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX ) + $ XF, LDX, V1T, LDV1T, ZERO, WORK, LDX ) * CALL ZGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE, - $ U1, LDU1, WORK, LDX, ZERO, X, LDX ) + $ U1, LDU1, WORK, LDX, ZERO, XF, LDX ) * DO I = 1, MIN(P,Q)-R - X(I,I) = X(I,I) - ONE + XF(I,I) = XF(I,I) - ONE END DO DO I = 1, R - X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) = - $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - DCMPLX( COS(THETA(I)), + XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) = + $ XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - DCMPLX( COS(THETA(I)), $ 0.0D0 ) END DO * CALL ZGEMM( 'No transpose', 'Conjugate transpose', P, M-Q, M-Q, - $ ONE, X(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX ) + $ ONE, XF(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX ) * CALL ZGEMM( 'Conjugate transpose', 'No transpose', P, M-Q, P, - $ ONE, U1, LDU1, WORK, LDX, ZERO, X(1,Q+1), LDX ) + $ ONE, U1, LDU1, WORK, LDX, ZERO, XF(1,Q+1), LDX ) * DO I = 1, MIN(P,M-Q)-R - X(P-I+1,M-I+1) = X(P-I+1,M-I+1) + ONE + XF(P-I+1,M-I+1) = XF(P-I+1,M-I+1) + ONE END DO DO I = 1, R - X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) = - $ X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) + + XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) = + $ XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) + $ DCMPLX( SIN(THETA(R-I+1)), 0.0D0 ) END DO * CALL ZGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE, - $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX ) + $ XF(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX ) * CALL ZGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P, - $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX ) + $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,1), LDX ) * DO I = 1, MIN(M-P,Q)-R - X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE + XF(M-I+1,Q-I+1) = XF(M-I+1,Q-I+1) - ONE END DO DO I = 1, R - X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) = - $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) - + XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) = + $ XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) - $ DCMPLX( SIN(THETA(R-I+1)), 0.0D0 ) END DO * CALL ZGEMM( 'No transpose', 'Conjugate transpose', M-P, M-Q, M-Q, - $ ONE, X(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX ) + $ ONE, XF(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX ) * CALL ZGEMM( 'Conjugate transpose', 'No transpose', M-P, M-Q, M-P, - $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,Q+1), LDX ) + $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,Q+1), LDX ) * DO I = 1, MIN(M-P,M-Q)-R - X(P+I,Q+I) = X(P+I,Q+I) - ONE + XF(P+I,Q+I) = XF(P+I,Q+I) - ONE END DO DO I = 1, R - X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) = - $ X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) - + XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) = + $ XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) - $ DCMPLX( COS(THETA(I)), 0.0D0 ) END DO * * Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) . * - RESID = ZLANGE( '1', P, Q, X, LDX, RWORK ) + RESID = ZLANGE( '1', P, Q, XF, LDX, RWORK ) RESULT( 1 ) = ( RESID / REAL(MAX(1,P,Q)) ) / EPS2 * * Compute norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 ) . * - RESID = ZLANGE( '1', P, M-Q, X(1,Q+1), LDX, RWORK ) + RESID = ZLANGE( '1', P, M-Q, XF(1,Q+1), LDX, RWORK ) RESULT( 2 ) = ( RESID / REAL(MAX(1,P,M-Q)) ) / EPS2 * * Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) . * - RESID = ZLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK ) + RESID = ZLANGE( '1', M-P, Q, XF(P+1,1), LDX, RWORK ) RESULT( 3 ) = ( RESID / REAL(MAX(1,M-P,Q)) ) / EPS2 * * Compute norm( U2'*X22*V2 - D22 ) / ( MAX(1,M-P,M-Q)*EPS2 ) . * - RESID = ZLANGE( '1', M-P, M-Q, X(P+1,Q+1), LDX, RWORK ) + RESID = ZLANGE( '1', M-P, M-Q, XF(P+1,Q+1), LDX, RWORK ) RESULT( 4 ) = ( RESID / REAL(MAX(1,M-P,M-Q)) ) / EPS2 * * Compute I - U1'*U1 @@ -397,14 +428,126 @@ * * Check sorting * - RESULT(9) = REALZERO + RESULT( 9 ) = REALZERO + DO I = 1, R + IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN + RESULT( 9 ) = ULPINV + END IF + IF( I.GT.1) THEN + IF ( THETA(I).LT.THETA(I-1) ) THEN + RESULT( 9 ) = ULPINV + END IF + END IF + END DO +* +* The second half of the routine checks the 2-by-1 CSD +* + CALL ZLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDX ) + CALL ZHERK( 'Upper', 'Conjugate transpose', Q, M, -REALONE, + $ X, LDX, REALONE, WORK, LDX ) + IF (M.GT.0) THEN + EPS2 = MAX( ULP, + $ ZLANGE( '1', Q, Q, WORK, LDX, RWORK ) / DBLE( M ) ) + ELSE + EPS2 = ULP + END IF + R = MIN( P, M-P, Q, M-Q ) +* +* Copy the matrix X to the array XF. +* + CALL ZLACPY( 'Full', M, M, X, LDX, XF, LDX ) +* +* Compute the CSD +* + CALL ZUNCSD2BY1( 'Y', 'Y', 'Y', M, P, Q, XF(1,1), LDX, XF(P+1,1), + $ LDX, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, WORK, + $ LWORK, RWORK, 17*(R+2), IWORK, INFO ) +* +* Compute [X11;X21] := diag(U1,U2)'*[X11;X21]*V1 - [D11;D21] +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE, + $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX ) +* + CALL ZGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE, + $ U1, LDU1, WORK, LDX, ZERO, X, LDX ) +* + DO I = 1, MIN(P,Q)-R + X(I,I) = X(I,I) - ONE + END DO + DO I = 1, R + X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) = + $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - DCMPLX( COS(THETA(I)), + $ 0.0D0 ) + END DO +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE, + $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX ) +* + CALL ZGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P, + $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX ) +* + DO I = 1, MIN(M-P,Q)-R + X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE + END DO + DO I = 1, R + X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) = + $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) - + $ DCMPLX( SIN(THETA(R-I+1)), 0.0D0 ) + END DO +* +* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) . +* + RESID = ZLANGE( '1', P, Q, X, LDX, RWORK ) + RESULT( 10 ) = ( RESID / REAL(MAX(1,P,Q)) ) / EPS2 +* +* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) . +* + RESID = ZLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK ) + RESULT( 11 ) = ( RESID / REAL(MAX(1,M-P,Q)) ) / EPS2 +* +* Compute I - U1'*U1 +* + CALL ZLASET( 'Full', P, P, ZERO, ONE, WORK, LDU1 ) + CALL ZHERK( 'Upper', 'Conjugate transpose', P, P, -REALONE, + $ U1, LDU1, REALONE, WORK, LDU1 ) +* +* Compute norm( I - U'*U ) / ( MAX(1,P) * ULP ) . +* + RESID = ZLANHE( '1', 'Upper', P, WORK, LDU1, RWORK ) + RESULT( 12 ) = ( RESID / REAL(MAX(1,P)) ) / ULP +* +* Compute I - U2'*U2 +* + CALL ZLASET( 'Full', M-P, M-P, ZERO, ONE, WORK, LDU2 ) + CALL ZHERK( 'Upper', 'Conjugate transpose', M-P, M-P, -REALONE, + $ U2, LDU2, REALONE, WORK, LDU2 ) +* +* Compute norm( I - U2'*U2 ) / ( MAX(1,M-P) * ULP ) . +* + RESID = ZLANHE( '1', 'Upper', M-P, WORK, LDU2, RWORK ) + RESULT( 13 ) = ( RESID / REAL(MAX(1,M-P)) ) / ULP +* +* Compute I - V1T*V1T' +* + CALL ZLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDV1T ) + CALL ZHERK( 'Upper', 'No transpose', Q, Q, -REALONE, + $ V1T, LDV1T, REALONE, WORK, LDV1T ) +* +* Compute norm( I - V1T*V1T' ) / ( MAX(1,Q) * ULP ) . +* + RESID = ZLANHE( '1', 'Upper', Q, WORK, LDV1T, RWORK ) + RESULT( 14 ) = ( RESID / REAL(MAX(1,Q)) ) / ULP +* +* Check sorting +* + RESULT( 15 ) = REALZERO DO I = 1, R IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN - RESULT(9) = ULPINV + RESULT( 15 ) = ULPINV END IF IF( I.GT.1) THEN IF ( THETA(I).LT.THETA(I-1) ) THEN - RESULT(9) = ULPINV + RESULT( 15 ) = ULPINV END IF END IF END DO diff --git a/lapack-netlib/TESTING/LIN/CMakeLists.txt b/lapack-netlib/TESTING/LIN/CMakeLists.txt index e6489c585..d7fb86254 100644 --- a/lapack-netlib/TESTING/LIN/CMakeLists.txt +++ b/lapack-netlib/TESTING/LIN/CMakeLists.txt @@ -10,10 +10,10 @@ set(SLINTST schkaa.f schkeq.f schkgb.f schkge.f schkgt.f schklq.f schkpb.f schkpo.f schkps.f schkpp.f schkpt.f schkq3.f schkql.f schkqp.f schkqr.f schkrq.f - schksp.f schksy.f schktb.f schktp.f schktr.f + schksp.f schksy.f schksy_rook.f schktb.f schktp.f schktr.f schktz.f sdrvgt.f sdrvls.f sdrvpb.f - sdrvpp.f sdrvpt.f sdrvsp.f sdrvsy.f + sdrvpp.f sdrvpt.f sdrvsp.f sdrvsy.f sdrvsy_rook.f serrgt.f serrlq.f serrls.f serrpo.f serrps.f serrql.f serrqp.f serrqr.f serrrq.f serrsy.f serrtr.f serrtz.f serrvx.f @@ -21,7 +21,7 @@ set(SLINTST schkaa.f sgerqs.f sget01.f sget02.f sget03.f sget04.f sget06.f sget07.f sgtt01.f sgtt02.f sgtt05.f slaptm.f slarhs.f slatb4.f slatb5.f slattb.f slattp.f - slattr.f slavsp.f slavsy.f slqt01.f slqt02.f + slattr.f slavsp.f slavsy.f slavsy_rook.f slqt01.f slqt02.f slqt03.f spbt01.f spbt02.f spbt05.f spot01.f spot02.f spot03.f spot05.f spst01.f sppt01.f sppt02.f sppt03.f sppt05.f sptt01.f sptt02.f @@ -29,7 +29,7 @@ set(SLINTST schkaa.f sqrt01.f sqrt01p.f sqrt02.f sqrt03.f sqrt11.f sqrt12.f sqrt13.f sqrt14.f sqrt15.f sqrt16.f sqrt17.f srqt01.f srqt02.f srqt03.f srzt01.f srzt02.f - sspt01.f ssyt01.f + sspt01.f ssyt01.f ssyt01_rook.f stbt02.f stbt03.f stbt05.f stbt06.f stpt01.f stpt02.f stpt03.f stpt05.f stpt06.f strt01.f strt02.f strt03.f strt05.f strt06.f @@ -44,13 +44,13 @@ endif() set(CLINTST cchkaa.f cchkeq.f cchkgb.f cchkge.f cchkgt.f - cchkhe.f cchkhp.f cchklq.f cchkpb.f + cchkhe.f cchkhe_rook.f cchkhp.f cchklq.f cchkpb.f cchkpo.f cchkps.f cchkpp.f cchkpt.f cchkq3.f cchkql.f cchkqp.f - cchkqr.f cchkrq.f cchksp.f cchksy.f cchktb.f + cchkqr.f cchkrq.f cchksp.f cchksy.f cchksy_rook.f cchktb.f cchktp.f cchktr.f cchktz.f - cdrvgt.f cdrvhe.f cdrvhp.f + cdrvgt.f cdrvhe.f cdrvhe_rook.f cdrvhp.f cdrvls.f cdrvpb.f cdrvpp.f cdrvpt.f - cdrvsp.f cdrvsy.f + cdrvsp.f cdrvsy.f cdrvsy_rook.f cerrgt.f cerrhe.f cerrlq.f cerrls.f cerrps.f cerrql.f cerrqp.f cerrqr.f cerrrq.f cerrsy.f cerrtr.f cerrtz.f @@ -58,9 +58,9 @@ set(CLINTST cchkaa.f cgbt01.f cgbt02.f cgbt05.f cgelqs.f cgeqls.f cgeqrs.f cgerqs.f cget01.f cget02.f cget03.f cget04.f cget07.f cgtt01.f cgtt02.f - cgtt05.f chet01.f chpt01.f claipd.f claptm.f clarhs.f clatb4.f clatb5.f + cgtt05.f chet01.f chet01_rook.f chpt01.f claipd.f claptm.f clarhs.f clatb4.f clatb5.f clatsp.f clatsy.f clattb.f clattp.f clattr.f - clavhe.f clavhp.f clavsp.f clavsy.f clqt01.f + clavhe.f clavhe_rook.f clavhp.f clavsp.f clavsy.f clavsy_rook.f clqt01.f clqt02.f clqt03.f cpbt01.f cpbt02.f cpbt05.f cpot01.f cpot02.f cpot03.f cpot05.f cpst01.f cppt01.f cppt02.f cppt03.f cppt05.f cptt01.f @@ -69,7 +69,7 @@ set(CLINTST cchkaa.f cqrt12.f cqrt13.f cqrt14.f cqrt15.f cqrt16.f cqrt17.f crqt01.f crqt02.f crqt03.f crzt01.f crzt02.f csbmv.f cspt01.f - cspt02.f cspt03.f csyt01.f csyt02.f csyt03.f + cspt02.f cspt03.f csyt01.f csyt01_rook.f csyt02.f csyt03.f ctbt02.f ctbt03.f ctbt05.f ctbt06.f ctpt01.f ctpt02.f ctpt03.f ctpt05.f ctpt06.f ctrt01.f ctrt02.f ctrt03.f ctrt05.f ctrt06.f @@ -87,10 +87,10 @@ set(DLINTST dchkaa.f dchkeq.f dchkgb.f dchkge.f dchkgt.f dchklq.f dchkpb.f dchkpo.f dchkps.f dchkpp.f dchkpt.f dchkq3.f dchkql.f dchkqp.f dchkqr.f dchkrq.f - dchksp.f dchksy.f dchktb.f dchktp.f dchktr.f + dchksp.f dchksy.f dchksy_rook.f dchktb.f dchktp.f dchktr.f dchktz.f ddrvgt.f ddrvls.f ddrvpb.f - ddrvpp.f ddrvpt.f ddrvsp.f ddrvsy.f + ddrvpp.f ddrvpt.f ddrvsp.f ddrvsy.f ddrvsy_rook.f derrgt.f derrlq.f derrls.f derrps.f derrql.f derrqp.f derrqr.f derrrq.f derrsy.f derrtr.f derrtz.f derrvx.f @@ -98,7 +98,7 @@ set(DLINTST dchkaa.f dgerqs.f dget01.f dget02.f dget03.f dget04.f dget06.f dget07.f dgtt01.f dgtt02.f dgtt05.f dlaptm.f dlarhs.f dlatb4.f dlatb5.f dlattb.f dlattp.f - dlattr.f dlavsp.f dlavsy.f dlqt01.f dlqt02.f + dlattr.f dlavsp.f dlavsy.f dlavsy_rook.f dlqt01.f dlqt02.f dlqt03.f dpbt01.f dpbt02.f dpbt05.f dpot01.f dpot02.f dpot03.f dpot05.f dpst01.f dppt01.f dppt02.f dppt03.f dppt05.f dptt01.f dptt02.f @@ -106,7 +106,7 @@ set(DLINTST dchkaa.f dqrt01.f dqrt01p.f dqrt02.f dqrt03.f dqrt11.f dqrt12.f dqrt13.f dqrt14.f dqrt15.f dqrt16.f dqrt17.f drqt01.f drqt02.f drqt03.f drzt01.f drzt02.f - dspt01.f dsyt01.f + dspt01.f dsyt01.f dsyt01_rook.f dtbt02.f dtbt03.f dtbt05.f dtbt06.f dtpt01.f dtpt02.f dtpt03.f dtpt05.f dtpt06.f dtrt01.f dtrt02.f dtrt03.f dtrt05.f dtrt06.f @@ -123,13 +123,13 @@ endif() set(ZLINTST zchkaa.f zchkeq.f zchkgb.f zchkge.f zchkgt.f - zchkhe.f zchkhp.f zchklq.f zchkpb.f + zchkhe.f zchkhe_rook.f zchkhp.f zchklq.f zchkpb.f zchkpo.f zchkps.f zchkpp.f zchkpt.f zchkq3.f zchkql.f zchkqp.f - zchkqr.f zchkrq.f zchksp.f zchksy.f zchktb.f + zchkqr.f zchkrq.f zchksp.f zchksy.f zchksy_rook.f zchktb.f zchktp.f zchktr.f zchktz.f - zdrvgt.f zdrvhe.f zdrvhp.f + zdrvgt.f zdrvhe.f zdrvhe_rook.f zdrvhp.f zdrvls.f zdrvpb.f zdrvpp.f zdrvpt.f - zdrvsp.f zdrvsy.f + zdrvsp.f zdrvsy.f zdrvsy_rook.f zerrgt.f zerrhe.f zerrlq.f zerrls.f zerrps.f zerrql.f zerrqp.f zerrqr.f zerrrq.f zerrsy.f zerrtr.f zerrtz.f @@ -137,9 +137,9 @@ set(ZLINTST zchkaa.f zgbt01.f zgbt02.f zgbt05.f zgelqs.f zgeqls.f zgeqrs.f zgerqs.f zget01.f zget02.f zget03.f zget04.f zget07.f zgtt01.f zgtt02.f - zgtt05.f zhet01.f zhpt01.f zlaipd.f zlaptm.f zlarhs.f zlatb4.f zlatb5.f + zgtt05.f zhet01.f zhet01.f zhet01_rook.f zhpt01.f zlaipd.f zlaptm.f zlarhs.f zlatb4.f zlatb5.f zlatsp.f zlatsy.f zlattb.f zlattp.f zlattr.f - zlavhe.f zlavhp.f zlavsp.f zlavsy.f zlqt01.f + zlavhe.f zlavhe_rook.f zlavhp.f zlavsp.f zlavsy.f zlavsy_rook.f zlqt01.f zlqt02.f zlqt03.f zpbt01.f zpbt02.f zpbt05.f zpot01.f zpot02.f zpot03.f zpot05.f zpst01.f zppt01.f zppt02.f zppt03.f zppt05.f zptt01.f @@ -148,7 +148,7 @@ set(ZLINTST zchkaa.f zqrt12.f zqrt13.f zqrt14.f zqrt15.f zqrt16.f zqrt17.f zrqt01.f zrqt02.f zrqt03.f zrzt01.f zrzt02.f zsbmv.f zspt01.f - zspt02.f zspt03.f zsyt01.f zsyt02.f zsyt03.f + zspt02.f zspt03.f zsyt01.f zsyt01_rook.f zsyt02.f zsyt03.f ztbt02.f ztbt03.f ztbt05.f ztbt06.f ztpt01.f ztpt02.f ztpt03.f ztpt05.f ztpt06.f ztrt01.f ztrt02.f ztrt03.f ztrt05.f ztrt06.f diff --git a/lapack-netlib/TESTING/LIN/Makefile b/lapack-netlib/TESTING/LIN/Makefile index 5b68b8f69..2352da64c 100644 --- a/lapack-netlib/TESTING/LIN/Makefile +++ b/lapack-netlib/TESTING/LIN/Makefile @@ -51,10 +51,10 @@ SLINTST = schkaa.o \ schkeq.o schkgb.o schkge.o schkgt.o \ schklq.o schkpb.o schkpo.o schkps.o schkpp.o \ schkpt.o schkq3.o schkql.o schkqp.o schkqr.o schkrq.o \ - schksp.o schksy.o schktb.o schktp.o schktr.o \ + schksp.o schksy.o schksy_rook.o schktb.o schktp.o schktr.o \ schktz.o \ sdrvgt.o sdrvls.o sdrvpb.o \ - sdrvpp.o sdrvpt.o sdrvsp.o \ + sdrvpp.o sdrvpt.o sdrvsp.o sdrvsy_rook.o\ serrgt.o serrlq.o serrls.o \ serrps.o serrql.o serrqp.o serrqr.o \ serrrq.o serrtr.o serrtz.o \ @@ -62,7 +62,7 @@ SLINTST = schkaa.o \ sgerqs.o sget01.o sget02.o \ sget03.o sget04.o sget06.o sget07.o sgtt01.o sgtt02.o \ sgtt05.o slaptm.o slarhs.o slatb4.o slatb5.o slattb.o slattp.o \ - slattr.o slavsp.o slavsy.o slqt01.o slqt02.o \ + slattr.o slavsp.o slavsy.o slavsy_rook.o slqt01.o slqt02.o \ slqt03.o spbt01.o spbt02.o spbt05.o spot01.o \ spot02.o spot03.o spot05.o spst01.o sppt01.o \ sppt02.o sppt03.o sppt05.o sptt01.o sptt02.o \ @@ -70,7 +70,7 @@ SLINTST = schkaa.o \ sqrt01.o sqrt01p.o sqrt02.o sqrt03.o sqrt11.o sqrt12.o \ sqrt13.o sqrt14.o sqrt15.o sqrt16.o sqrt17.o \ srqt01.o srqt02.o srqt03.o srzt01.o srzt02.o \ - sspt01.o ssyt01.o \ + sspt01.o ssyt01.o ssyt01_rook.o \ stbt02.o stbt03.o stbt05.o stbt06.o stpt01.o \ stpt02.o stpt03.o stpt05.o stpt06.o strt01.o \ strt02.o strt03.o strt05.o strt06.o \ @@ -78,30 +78,30 @@ SLINTST = schkaa.o \ ifdef USEXBLAS SLINTST += serrvxx.o sdrvgex.o sdrvsyx.o serrgex.o sdrvgbx.o sdrvpox.o \ - sebchvxx.o serrsyx.o serrpox.o + sebchvxx.o serrsyx.o serrpox.o else SLINTST += serrvx.o sdrvge.o sdrvsy.o serrge.o sdrvgb.o sdrvpo.o \ - serrsy.o serrpo.o + serrsy.o serrpo.o endif CLINTST = cchkaa.o \ cchkeq.o cchkgb.o cchkge.o cchkgt.o \ - cchkhe.o cchkhp.o cchklq.o cchkpb.o \ + cchkhe.o cchkhe_rook.o cchkhp.o cchklq.o cchkpb.o \ cchkpo.o cchkps.o cchkpp.o cchkpt.o cchkq3.o cchkql.o cchkqp.o \ - cchkqr.o cchkrq.o cchksp.o cchksy.o cchktb.o \ + cchkqr.o cchkrq.o cchksp.o cchksy.o cchksy_rook.o cchktb.o \ cchktp.o cchktr.o cchktz.o \ - cdrvgt.o cdrvhp.o \ + cdrvgt.o cdrvhe_rook.o cdrvhp.o \ cdrvls.o cdrvpb.o cdrvpp.o cdrvpt.o \ - cdrvsp.o \ + cdrvsp.o cdrvsy_rook.o \ cerrgt.o cerrlq.o \ cerrls.o cerrps.o cerrql.o cerrqp.o \ cerrqr.o cerrrq.o cerrtr.o cerrtz.o \ cgbt01.o cgbt02.o cgbt05.o cgelqs.o cgeqls.o cgeqrs.o \ cgerqs.o cget01.o cget02.o \ cget03.o cget04.o cget07.o cgtt01.o cgtt02.o \ - cgtt05.o chet01.o chpt01.o claipd.o claptm.o clarhs.o clatb4.o clatb5.o \ + cgtt05.o chet01.o chet01_rook.o chpt01.o claipd.o claptm.o clarhs.o clatb4.o clatb5.o \ clatsp.o clatsy.o clattb.o clattp.o clattr.o \ - clavhe.o clavhp.o clavsp.o clavsy.o clqt01.o \ + clavhe.o clavhe_rook.o clavhp.o clavsp.o clavsy.o clavsy_rook.o clqt01.o \ clqt02.o clqt03.o cpbt01.o cpbt02.o cpbt05.o \ cpot01.o cpot02.o cpot03.o cpot05.o cpst01.o \ cppt01.o cppt02.o cppt03.o cppt05.o cptt01.o \ @@ -110,7 +110,7 @@ CLINTST = cchkaa.o \ cqrt12.o cqrt13.o cqrt14.o cqrt15.o cqrt16.o \ cqrt17.o crqt01.o crqt02.o crqt03.o crzt01.o crzt02.o \ cspt01.o \ - cspt02.o cspt03.o csyt01.o csyt02.o csyt03.o \ + cspt02.o cspt03.o csyt01.o csyt01_rook.o csyt02.o csyt03.o \ ctbt02.o ctbt03.o ctbt05.o ctbt06.o ctpt01.o \ ctpt02.o ctpt03.o ctpt05.o ctpt06.o ctrt01.o \ ctrt02.o ctrt03.o ctrt05.o ctrt06.o \ @@ -118,21 +118,21 @@ CLINTST = cchkaa.o \ cqrt04.o cqrt05.o cchkqrt.o cerrqrt.o cchkqrtp.o cerrqrtp.o ifdef USEXBLAS -CLINTST += cerrvxx.o cdrvgex.o cdrvsyx.o cdrvgbx.o cerrgex.o cdrvpox.o cdrvhex.o \ - cerrpox.o cebchvxx.o cerrsyx.o cerrhex.o +CLINTST += cerrvxx.o cdrvgex.o cdrvsyx.o cdrvgbx.o cerrgex.o cdrvpox.o \ + cdrvhex.o cerrpox.o cebchvxx.o cerrsyx.o cerrhex.o else -CLINTST += cerrvx.o cdrvge.o cdrvsy.o cdrvgb.o cerrge.o cdrvpo.o cdrvhe.o \ - cerrpo.o cerrsy.o cerrhe.o +CLINTST += cerrvx.o cdrvge.o cdrvsy.o cdrvgb.o cerrge.o cdrvpo.o \ + cdrvhe.o cerrpo.o cerrsy.o cerrhe.o endif DLINTST = dchkaa.o \ dchkeq.o dchkgb.o dchkge.o dchkgt.o \ dchklq.o dchkpb.o dchkpo.o dchkps.o dchkpp.o \ dchkpt.o dchkq3.o dchkql.o dchkqp.o dchkqr.o dchkrq.o \ - dchksp.o dchksy.o dchktb.o dchktp.o dchktr.o \ + dchksp.o dchksy.o dchksy_rook.o dchktb.o dchktp.o dchktr.o \ dchktz.o \ ddrvgt.o ddrvls.o ddrvpb.o \ - ddrvpp.o ddrvpt.o ddrvsp.o \ + ddrvpp.o ddrvpt.o ddrvsp.o ddrvsy_rook.o \ derrgt.o derrlq.o derrls.o \ derrps.o derrql.o derrqp.o derrqr.o \ derrrq.o derrtr.o derrtz.o \ @@ -140,7 +140,7 @@ DLINTST = dchkaa.o \ dgerqs.o dget01.o dget02.o \ dget03.o dget04.o dget06.o dget07.o dgtt01.o dgtt02.o \ dgtt05.o dlaptm.o dlarhs.o dlatb4.o dlatb5.o dlattb.o dlattp.o \ - dlattr.o dlavsp.o dlavsy.o dlqt01.o dlqt02.o \ + dlattr.o dlavsp.o dlavsy.o dlavsy_rook.o dlqt01.o dlqt02.o \ dlqt03.o dpbt01.o dpbt02.o dpbt05.o dpot01.o \ dpot02.o dpot03.o dpot05.o dpst01.o dppt01.o \ dppt02.o dppt03.o dppt05.o dptt01.o dptt02.o \ @@ -148,7 +148,7 @@ DLINTST = dchkaa.o \ dqrt01.o dqrt01p.o dqrt02.o dqrt03.o dqrt11.o dqrt12.o \ dqrt13.o dqrt14.o dqrt15.o dqrt16.o dqrt17.o \ drqt01.o drqt02.o drqt03.o drzt01.o drzt02.o \ - dspt01.o dsyt01.o \ + dspt01.o dsyt01.o dsyt01_rook.o \ dtbt02.o dtbt03.o dtbt05.o dtbt06.o dtpt01.o \ dtpt02.o dtpt03.o dtpt05.o dtpt06.o dtrt01.o \ dtrt02.o dtrt03.o dtrt05.o dtrt06.o \ @@ -157,30 +157,30 @@ DLINTST = dchkaa.o \ ifdef USEXBLAS DLINTST += derrvxx.o ddrvgex.o ddrvsyx.o ddrvgbx.o derrgex.o ddrvpox.o derrpox.o \ - debchvxx.o derrsyx.o + debchvxx.o derrsyx.o else DLINTST += derrvx.o ddrvge.o ddrvsy.o ddrvgb.o derrge.o ddrvpo.o derrpo.o \ - derrsy.o + derrsy.o endif ZLINTST = zchkaa.o \ zchkeq.o zchkgb.o zchkge.o zchkgt.o \ - zchkhe.o zchkhp.o zchklq.o zchkpb.o \ + zchkhe.o zchkhe_rook.o zchkhp.o zchklq.o zchkpb.o \ zchkpo.o zchkps.o zchkpp.o zchkpt.o zchkq3.o zchkql.o zchkqp.o \ - zchkqr.o zchkrq.o zchksp.o zchksy.o zchktb.o \ + zchkqr.o zchkrq.o zchksp.o zchksy.o zchksy_rook.o zchktb.o \ zchktp.o zchktr.o zchktz.o \ - zdrvgt.o zdrvhp.o \ + zdrvgt.o zdrvhe_rook.o zdrvhp.o \ zdrvls.o zdrvpb.o zdrvpp.o zdrvpt.o \ - zdrvsp.o \ + zdrvsp.o zdrvsy_rook.o \ zerrgt.o zerrlq.o \ zerrls.o zerrps.o zerrql.o zerrqp.o \ zerrqr.o zerrrq.o zerrtr.o zerrtz.o \ zgbt01.o zgbt02.o zgbt05.o zgelqs.o zgeqls.o zgeqrs.o \ zgerqs.o zget01.o zget02.o \ zget03.o zget04.o zget07.o zgtt01.o zgtt02.o \ - zgtt05.o zhet01.o zhpt01.o zlaipd.o zlaptm.o zlarhs.o zlatb4.o zlatb5.o \ + zgtt05.o zhet01.o zhet01_rook.o zhpt01.o zlaipd.o zlaptm.o zlarhs.o zlatb4.o zlatb5.o \ zlatsp.o zlatsy.o zlattb.o zlattp.o zlattr.o \ - zlavhe.o zlavhp.o zlavsp.o zlavsy.o zlqt01.o \ + zlavhe.o zlavhe_rook.o zlavhp.o zlavsp.o zlavsy.o zlavsy_rook.o zlqt01.o \ zlqt02.o zlqt03.o zpbt01.o zpbt02.o zpbt05.o \ zpot01.o zpot02.o zpot03.o zpot05.o zpst01.o \ zppt01.o zppt02.o zppt03.o zppt05.o zptt01.o \ @@ -189,7 +189,7 @@ ZLINTST = zchkaa.o \ zqrt12.o zqrt13.o zqrt14.o zqrt15.o zqrt16.o \ zqrt17.o zrqt01.o zrqt02.o zrqt03.o zrzt01.o zrzt02.o \ zspt01.o \ - zspt02.o zspt03.o zsyt01.o zsyt02.o zsyt03.o \ + zspt02.o zspt03.o zsyt01.o zsyt01_rook.o zsyt02.o zsyt03.o \ ztbt02.o ztbt03.o ztbt05.o ztbt06.o ztpt01.o \ ztpt02.o ztpt03.o ztpt05.o ztpt06.o ztrt01.o \ ztrt02.o ztrt03.o ztrt05.o ztrt06.o \ @@ -198,10 +198,10 @@ ZLINTST = zchkaa.o \ ifdef USEXBLAS ZLINTST += zerrvxx.o zdrvgex.o zdrvsyx.o zdrvgbx.o zerrgex.o zdrvpox.o zdrvhex.o \ - zerrpox.o zebchvxx.o zerrsyx.o zerrhex.o + zerrpox.o zebchvxx.o zerrsyx.o zerrhex.o else -ZLINTST += zerrvx.o zdrvge.o zdrvsy.o zdrvgb.o zerrge.o zdrvpo.o zdrvhe.o \ - zerrpo.o zerrsy.o zerrhe.o +ZLINTST += zerrvx.o zdrvge.o zdrvsy.o zdrvgb.o zerrge.o zdrvpo.o \ + zdrvhe.o zerrpo.o zerrsy.o zerrhe.o endif DSLINTST = dchkab.o \ @@ -251,39 +251,39 @@ xlintsts : $(ALINTST) $(SLINTST) $(SCLNTST) ../../$(LAPACKLIB) xlintstc : $(ALINTST) $(CLINTST) $(SCLNTST) ../../$(LAPACKLIB) $(LOADER) $(LOADOPTS) $(ALINTST) $(SCLNTST) $(CLINTST) \ ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) -o $@ $(CEXTRALIB) - + xlintstd : $(ALINTST) $(DLINTST) $(DZLNTST) ../../$(LAPACKLIB) $(LOADER) $(LOADOPTS) $^ \ ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) -o $@ $(CEXTRALIB) - + xlintstz : $(ALINTST) $(ZLINTST) $(DZLNTST) ../../$(LAPACKLIB) $(LOADER) $(LOADOPTS) $(ALINTST) $(DZLNTST) $(ZLINTST) \ ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) -o $@ $(CEXTRALIB) - + xlintstds : $(DSLINTST) ../../$(LAPACKLIB) $(LOADER) $(LOADOPTS) $(DSLINTST) \ ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ $(CEXTRALIB) - + xlintstzc : $(ZCLINTST) ../../$(LAPACKLIB) $(LOADER) $(LOADOPTS) $(ZCLINTST) \ ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ $(CEXTRALIB) - + xlintstrfs : $(SLINTSTRFP) ../../$(LAPACKLIB) $(LOADER) $(LOADOPTS) $(SLINTSTRFP) \ ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ $(CEXTRALIB) - + xlintstrfd : $(DLINTSTRFP) ../../$(LAPACKLIB) $(LOADER) $(LOADOPTS) $(DLINTSTRFP) \ ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ $(CEXTRALIB) - + xlintstrfc : $(CLINTSTRFP) ../../$(LAPACKLIB) $(LOADER) $(LOADOPTS) $(CLINTSTRFP) \ ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ $(CEXTRALIB) - + xlintstrfz : $(ZLINTSTRFP) ../../$(LAPACKLIB) $(LOADER) $(LOADOPTS) $(ZLINTSTRFP) \ ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ $(CEXTRALIB) - + ../xlintsts: xlintsts mv xlintsts $@ diff --git a/lapack-netlib/TESTING/LIN/aladhd.f b/lapack-netlib/TESTING/LIN/aladhd.f index 6daae587b..b2bb2e038 100644 --- a/lapack-netlib/TESTING/LIN/aladhd.f +++ b/lapack-netlib/TESTING/LIN/aladhd.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ALADHD( IOUNIT, PATH ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER IOUNIT * .. -* +* * *> \par Purpose: * ============= @@ -47,10 +47,18 @@ *> _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 +*> _SY: Symmetric indefinite, +*> with partial (Bunch-Kaufman) pivoting +*> _SR: Symmetric indefinite, +*> with "rook" (bounded Bunch-Kaufman) pivoting +*> _SP: Symmetric indefinite packed, +*> with partial (Bunch-Kaufman) pivoting +*> _HE: (complex) Hermitian indefinite, +*> with partial (Bunch-Kaufman) pivoting +*> _HR: (complex) Hermitian indefinite, +*> with "rook" (bounded Bunch-Kaufman) pivoting +*> _HP: (complex) Hermitian indefinite packed, +*> with partial (Bunch-Kaufman) pivoting *> The first character must be one of S, D, C, or Z (C or Z only *> if complex). *> \endverbatim @@ -58,22 +66,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup aux_lin * * ===================================================================== SUBROUTINE ALADHD( IOUNIT, PATH ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -223,7 +231,9 @@ ELSE IF( LSAMEN( 2, P2, 'SY' ) .OR. LSAMEN( 2, P2, 'SP' ) ) THEN * * SY: Symmetric indefinite full +* with partial (Bunch-Kaufman) pivoting algorithm * SP: Symmetric indefinite packed +* with partial (Bunch-Kaufman) pivoting algorithm * IF( LSAME( C3, 'Y' ) ) THEN WRITE( IOUNIT, FMT = 9992 )PATH, 'Symmetric' @@ -244,19 +254,43 @@ WRITE( IOUNIT, FMT = 9978 )5 WRITE( IOUNIT, FMT = 9976 )6 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) +* + ELSE IF( LSAMEN( 2, P2, 'SR' ) ) THEN +* +* SR: Symmetric indefinite full, +* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* + WRITE( IOUNIT, FMT = 9992 )PATH, 'Symmetric' +* + 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 = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'HE' ) .OR. LSAMEN( 2, P2, 'HP' ) ) THEN * * HE: Hermitian indefinite full +* with partial (Bunch-Kaufman) pivoting algorithm * HP: Hermitian indefinite packed +* with partial (Bunch-Kaufman) pivoting algorithm * 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 @@ -265,6 +299,22 @@ WRITE( IOUNIT, FMT = 9978 )5 WRITE( IOUNIT, FMT = 9976 )6 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) +* + ELSE IF( LSAMEN( 2, P2, 'HR' ) ) THEN +* +* HR: Hermitian indefinite full, +* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* + WRITE( IOUNIT, FMT = 9992 )PATH, 'Hermitian' +* + 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 = '( '' Messages:'' )' ) * ELSE * @@ -286,10 +336,14 @@ $ ' positive definite band matrices' ) 9993 FORMAT( / 1X, A3, ' drivers: ', A9, $ ' positive definite tridiagonal' ) - 9992 FORMAT( / 1X, A3, ' drivers: ', A9, ' indefinite matrices' ) + 9992 FORMAT( / 1X, A3, ' drivers: ', A9, ' indefinite matrices', + $ ', "rook" (bounded Bunch-Kaufman) pivoting' ) 9991 FORMAT( / 1X, A3, ' drivers: ', A9, $ ' indefinite packed matrices', $ ', partial (Bunch-Kaufman) pivoting' ) + 9891 FORMAT( / 1X, A3, ' drivers: ', A9, + $ ' indefinite packed matrices', + $ ', "rook" (bounded Bunch-Kaufman) pivoting' ) 9990 FORMAT( / 1X, A3, ': No header available' ) * * GE matrix types diff --git a/lapack-netlib/TESTING/LIN/alaerh.f b/lapack-netlib/TESTING/LIN/alaerh.f index 9a0f1c55c..2f58e85c8 100644 --- a/lapack-netlib/TESTING/LIN/alaerh.f +++ b/lapack-netlib/TESTING/LIN/alaerh.f @@ -139,7 +139,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup aux_lin * @@ -147,10 +147,10 @@ SUBROUTINE ALAERH( PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, $ N5, IMAT, NFAIL, NERRS, NOUT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -487,9 +487,19 @@ 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 + ELSE IF( LSAMEN( 2, P2, 'SY' ) + $ .OR. LSAMEN( 2, P2, 'SR' ) + $ .OR. LSAMEN( 2, P2, 'HE' ) + $ .OR. LSAMEN( 2, P2, 'HR' ) ) THEN +* +* xSY: symmetric indefinite matrices +* with partial (Bunch-Kaufman) pivoting; +* xSR: symmetric indefinite matrices +* with rook (bounded Bunch-Kaufman) pivoting; +* xHE: Hermitian indefinite matrices +* with partial (Bunch-Kaufman) pivoting. +* xHR: Hermitian indefinite matrices +* with rook (bounded Bunch-Kaufman) pivoting; * UPLO = OPTS( 1: 1 ) IF( LSAMEN( 3, C3, 'TRF' ) ) THEN diff --git a/lapack-netlib/TESTING/LIN/alahd.f b/lapack-netlib/TESTING/LIN/alahd.f index a41d5c98a..c501ac75a 100644 --- a/lapack-netlib/TESTING/LIN/alahd.f +++ b/lapack-netlib/TESTING/LIN/alahd.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ALAHD( IOUNIT, PATH ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER IOUNIT * .. -* +* * *> \par Purpose: * ============= @@ -47,10 +47,18 @@ *> _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 +*> _SY: Symmetric indefinite, +*> with partial (Bunch-Kaufman) pivoting +*> _SR: Symmetric indefinite, +*> with "rook" (bounded Bunch-Kaufman) pivoting +*> _SP: Symmetric indefinite packed, +*> with partial (Bunch-Kaufman) pivoting +*> _HE: (complex) Hermitian indefinite, +*> with partial (Bunch-Kaufman) pivoting +*> _HR: Symmetric indefinite, +*> with "rook" (bounded Bunch-Kaufman) pivoting +*> _HP: (complex) Hermitian indefinite packed, +*> with partial (Bunch-Kaufman) pivoting *> _TR: Triangular *> _TP: Triangular packed *> _TB: Triangular band @@ -73,22 +81,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup aux_lin * * ===================================================================== SUBROUTINE ALAHD( IOUNIT, PATH ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -268,7 +276,8 @@ * ELSE IF( LSAMEN( 2, P2, 'SY' ) ) THEN * -* SY: Symmetric indefinite full +* SY: Symmetric indefinite full, +* with partial (Bunch-Kaufman) pivoting algorithm * IF( LSAME( C3, 'Y' ) ) THEN WRITE( IOUNIT, FMT = 9992 )PATH, 'Symmetric' @@ -292,10 +301,37 @@ WRITE( IOUNIT, FMT = 9957 )8 WRITE( IOUNIT, FMT = 9955 )9 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) +* + ELSE IF( LSAMEN( 2, P2, 'SR' ) ) THEN +* +* SR: Symmetric indefinite full, +* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* + WRITE( IOUNIT, FMT = 9892 )PATH, 'Symmetric' +* + 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 = 9927 )3 + WRITE( IOUNIT, FMT = 9928 ) + WRITE( IOUNIT, FMT = 9926 )4 + WRITE( IOUNIT, FMT = 9928 ) + WRITE( IOUNIT, FMT = 9960 )5 + WRITE( IOUNIT, FMT = 9959 )6 + WRITE( IOUNIT, FMT = 9955 )7 + WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'SP' ) ) THEN * -* SP: Symmetric indefinite packed +* SP: Symmetric indefinite packed, +* with partial (Bunch-Kaufman) pivoting algorithm * IF( LSAME( C3, 'Y' ) ) THEN WRITE( IOUNIT, FMT = 9992 )PATH, 'Symmetric' @@ -321,19 +357,14 @@ * ELSE IF( LSAMEN( 2, P2, 'HE' ) ) THEN * -* HE: Hermitian indefinite full +* HE: Hermitian indefinite full, +* with partial (Bunch-Kaufman) pivoting algorithm +* + WRITE( IOUNIT, FMT = 9992 )PATH, 'Hermitian' * - 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:'' )' ) - IF( SORD ) THEN - WRITE( IOUNIT, FMT = 9972 ) - ELSE - WRITE( IOUNIT, FMT = 9971 ) - END IF + WRITE( IOUNIT, FMT = 9972 ) +* WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9953 )1 WRITE( IOUNIT, FMT = 9961 )2 @@ -345,10 +376,33 @@ WRITE( IOUNIT, FMT = 9957 )8 WRITE( IOUNIT, FMT = 9955 )9 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) +* + ELSE IF( LSAMEN( 2, P2, 'HR' ) ) THEN +* +* HR: Symmetric indefinite full, +* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* + WRITE( IOUNIT, FMT = 9892 )PATH, 'Hermitian' +* + 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 = 9927 )3 + WRITE( IOUNIT, FMT = 9928 ) + WRITE( IOUNIT, FMT = 9926 )4 + WRITE( IOUNIT, FMT = 9928 ) + WRITE( IOUNIT, FMT = 9960 )5 + WRITE( IOUNIT, FMT = 9959 )6 + WRITE( IOUNIT, FMT = 9955 )7 + WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'HP' ) ) THEN * -* HP: Hermitian indefinite packed +* HP: Hermitian indefinite packed, +* with partial (Bunch-Kaufman) pivoting algorithm * IF( LSAME( C3, 'E' ) ) THEN WRITE( IOUNIT, FMT = 9992 )PATH, 'Hermitian' @@ -600,8 +654,14 @@ $ ) 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' ) + 9992 FORMAT( / 1X, A3, ': ', A9, ' indefinite matrices', + $ ', partial (Bunch-Kaufman) pivoting' ) + 9991 FORMAT( / 1X, A3, ': ', A9, ' indefinite packed matrices', + $ ', partial (Bunch-Kaufman) pivoting' ) + 9892 FORMAT( / 1X, A3, ': ', A9, ' indefinite matrices', + $ ', "rook" (bounded Bunch-Kaufman) pivoting' ) + 9891 FORMAT( / 1X, A3, ': ', A9, ' indefinite packed matrices', + $ ', "rook" (bounded Bunch-Kaufman) pivoting' ) 9990 FORMAT( / 1X, A3, ': Triangular matrices' ) 9989 FORMAT( / 1X, A3, ': Triangular packed matrices' ) 9988 FORMAT( / 1X, A3, ': Triangular band matrices' ) @@ -617,7 +677,6 @@ 8000 FORMAT( / 1X, A3, ': QRT factorization for general matrices' ) 8001 FORMAT( / 1X, A3, ': QRT factorization for ', $ 'triangular-pentagonal matrices' ) - * * GE matrix types * @@ -718,7 +777,7 @@ $ '(* - tests error exits from ', A3, $ 'TRF, no test ratios are computed)' ) * -* SSY, SSP, CHE, CHP matrix types +* SSY, SSR, SSP, CHE, CHR, CHP matrix types * 9972 FORMAT( 4X, '1. Diagonal', 24X, $ '6. Last n/2 rows and columns zero', / 4X, @@ -731,7 +790,7 @@ $ '5. Middle row and column zero', 5X, $ '10. Scaled near overflow' ) * -* CSY, CSP matrix types +* CSY, CSR, CSP matrix types * 9971 FORMAT( 4X, '1. Diagonal', 24X, $ '7. Random, CNDNUM = sqrt(0.1/EPS)', / 4X, @@ -894,12 +953,17 @@ 9921 FORMAT( ' Test ratios:', / ' (1-2: ', A1, 'GELS, 3-6: ', A1, $ 'GELSX, 7-10: ', A1, 'GELSY, 11-14: ', A1, 'GELSS, 15-18: ', $ A1, 'GELSD)' ) + 9928 FORMAT( 7X, 'where ALPHA = ( 1 + SQRT( 17 ) ) / 8' ) + 9927 FORMAT( 3X, I2, ': ABS( Largest element in L )', / 12X, + $ ' - ( 1 / ( 1 - ALPHA ) ) + THRESH' ) + 9926 FORMAT( 3X, I2, ': Largest 2-Norm of 2-by-2 pivots', / 12X, + $ ' - ( ( 1 + ALPHA ) / ( 1 - ALPHA ) ) + THRESH' ) 8011 FORMAT(3X,I2,': norm( R - Q''*A ) / ( M * norm(A) * EPS )' ) 8012 FORMAT(3X,I2,': norm( I - Q''*Q ) / ( M * EPS )' ) 8013 FORMAT(3X,I2,': norm( Q*C - Q*C ) / ( M * norm(C) * EPS )' ) 8014 FORMAT(3X,I2,': norm( Q''*C - Q''*C ) / ( M * norm(C) * EPS )') 8015 FORMAT(3X,I2,': norm( C*Q - C*Q ) / ( M * norm(C) * EPS )' ) - 8016 FORMAT(3X,I2,': norm( C*Q'' - C*Q'' ) / ( M * norm(C) * EPS )') + 8016 FORMAT(3X,I2,': norm( C*Q'' - C*Q'' ) / ( M * norm(C) * EPS )') 8017 FORMAT(3X,I2,': norm( R - Q''*A ) / ( (M+N) * norm(A) * EPS )' ) 8018 FORMAT(3X,I2,': norm( I - Q''*Q ) / ( (M+N) * EPS )' ) 8019 FORMAT(3X,I2,': norm( Q*C - Q*C ) / ( (M+N) * norm(C) * EPS )' ) @@ -907,7 +971,7 @@ $ ': norm( Q''*C - Q''*C ) / ( (M+N) * norm(C) * EPS )') 8021 FORMAT(3X,I2,': norm( C*Q - C*Q ) / ( (M+N) * norm(C) * EPS )' ) 8022 FORMAT(3X,I2, - $ ': norm( C*Q'' - C*Q'' ) / ( (M+N) * norm(C) * EPS )') + $ ': norm( C*Q'' - C*Q'' ) / ( (M+N) * norm(C) * EPS )') * RETURN * diff --git a/lapack-netlib/TESTING/LIN/cchkaa.f b/lapack-netlib/TESTING/LIN/cchkaa.f index 8b5a85ed9..c2b5fad15 100644 --- a/lapack-netlib/TESTING/LIN/cchkaa.f +++ b/lapack-netlib/TESTING/LIN/cchkaa.f @@ -50,6 +50,7 @@ *> CPB 8 List types on next line if 0 < NTYPES < 8 *> CPT 12 List types on next line if 0 < NTYPES < 12 *> CHE 10 List types on next line if 0 < NTYPES < 10 +*> CHR 10 List types on next line if 0 < NTYPES < 10 *> CHP 10 List types on next line if 0 < NTYPES < 10 *> CSY 11 List types on next line if 0 < NTYPES < 11 *> CSR 11 List types on next line if 0 < NTYPES < 11 @@ -101,17 +102,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date November 2013 * *> \ingroup complex_lin * * ===================================================================== PROGRAM CCHKAA * -* -- LAPACK test routine (version 3.4.2) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* November 2013 * * ===================================================================== * @@ -158,13 +159,14 @@ * .. * .. External Subroutines .. EXTERNAL ALAREQ, CCHKEQ, CCHKGB, CCHKGE, CCHKGT, CCHKHE, - $ CCHKHP, CCHKLQ, CCHKPB, CCHKPO, CCHKPS, CCHKPP, - $ CCHKPT, CCHKQ3, CCHKQL, CCHKQP, CCHKQR, CCHKRQ, - $ CCHKSP, CCHKSY, CCHKTB, CCHKTP, - $ CCHKTR, CCHKTZ, CDRVGB, CDRVGE, CDRVGT, CDRVHE, - $ CDRVHP, CDRVLS, CDRVPB, CDRVPO, CDRVPP, CDRVPT, - $ CDRVSP, CDRVSY, ILAVER, CCHKQRT, - $ CCHKQRTP + $ CCHKHE_ROOK, CCHKHP, CCHKLQ, CCHKPB, CCHKPO, + $ CCHKPS, CCHKPP, CCHKPT, CCHKQ3, CCHKQL, CCHKQP, + $ CCHKQR, CCHKRQ, CCHKSP, CCHKSY, CCHKSY_ROOK, + $ CCHKTB, CCHKTP, CCHKTR, CCHKTZ, CDRVGB, CDRVGE, + $ CDRVGT, CDRVHE, CDRVHE_ROOK, CDRVHP, CDRVLS, + $ CDRVPB, CDRVPO, CDRVPP, CDRVPT, CDRVSP, CDRVSY, + $ CDRVSY_ROOK, ILAVER, CCHKQRT, CCHKQRTP + * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -615,7 +617,8 @@ * ELSE IF( LSAMEN( 2, C2, 'HE' ) ) THEN * -* HE: Hermitian indefinite matrices +* HE: Hermitian indefinite matrices, +* with partial (Bunch-Kaufman) pivoting algorithm * NTYPES = 10 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) @@ -637,10 +640,37 @@ ELSE WRITE( NOUT, FMT = 9988 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN +* +* HR: Hermitian indefinite matrices, +* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* + NTYPES = 10 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL CCHKHE_ROOK(DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), + $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL CDRVHE_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, + $ RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * -* HP: Hermitian indefinite packed matrices +* HP: Hermitian indefinite packed matrices, +* with partial (Bunch-Kaufman) pivoting algorithm * NTYPES = 10 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) @@ -688,6 +718,32 @@ ELSE WRITE( NOUT, FMT = 9988 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN +* +* SR: symmetric indefinite matrices, +* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* + NTYPES = 11 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL CCHKSY_ROOK(DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), + $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL CDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, + $ RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/cchkhe.f b/lapack-netlib/TESTING/LIN/cchkhe.f index f52f320a0..72dd71f66 100644 --- a/lapack-netlib/TESTING/LIN/cchkhe.f +++ b/lapack-netlib/TESTING/LIN/cchkhe.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCHKHE( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, * XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNB, NNS, NOUT @@ -24,7 +24,7 @@ * COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -135,14 +135,12 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is COMPLEX array, dimension -*> (NMAX*max(3,NSMAX)) +*> WORK is COMPLEX array, dimension (NMAX*max(3,NSMAX)) *> \endverbatim *> *> \param[out] RWORK *> \verbatim -*> RWORK is REAL array, dimension -*> (max(NMAX,2*NSMAX)) +*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX)) *> \endverbatim *> *> \param[out] IWORK @@ -159,12 +157,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex_lin * @@ -173,10 +171,10 @@ $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, $ XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -196,6 +194,8 @@ * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) + COMPLEX CZERO + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) INTEGER NTYPES PARAMETER ( NTYPES = 10 ) INTEGER NTESTS @@ -221,7 +221,7 @@ * .. * .. External Subroutines .. EXTERNAL ALAERH, ALAHD, ALASUM, CERRHE, CGET04, CHECON, - $ CHERFS, CHET01, CHETRF, CHETRI2, CHETRS, + $ CHERFS, CHET01, CHETRF, CHETRI2, CHETRS, $ CLACPY, CLAIPD, CLARHS, CLATB4, CLATMS, CPOT02, $ CPOT03, CPOT05, XLAENV * .. @@ -260,6 +260,11 @@ $ CALL CERRHE( PATH, NOUT ) INFOT = 0 * +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* * Do for each value of N in NVAL * DO 180 IN = 1, NN @@ -271,6 +276,9 @@ $ NIMAT = 1 * IZERO = 0 +* +* Do for each value of matrix type IMAT +* DO 170 IMAT = 1, NIMAT * * Do the tests only if DOTYPE( IMAT ) is true. @@ -289,27 +297,36 @@ DO 160 IUPLO = 1, 2 UPLO = UPLOS( IUPLO ) * -* Set up parameters with CLATB4 and generate a test matrix -* with CLATMS. +* Begin generate test matrix A. +* +* +* Set up parameters with CLATB4 for the matrix generator +* based on the type of matrix to be generated. * CALL CLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, $ CNDNUM, DIST ) +* +* Generate a matrix with CLATMS. * SRNAMT = 'CLATMS' CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, $ INFO ) * -* Check error code from CLATMS. +* Check error code from CLATMS and handle error. * IF( INFO.NE.0 ) THEN CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, -1, $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* GO TO 160 END IF * -* For types 3-6, zero one or more rows and columns of -* the matrix to test that INFO is returned correctly. +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. * IF( ZEROT ) THEN IF( IMAT.EQ.3 ) THEN @@ -327,34 +344,34 @@ IF( IUPLO.EQ.1 ) THEN IOFF = ( IZERO-1 )*LDA DO 20 I = 1, IZERO - 1 - A( IOFF+I ) = ZERO + A( IOFF+I ) = CZERO 20 CONTINUE IOFF = IOFF + IZERO DO 30 I = IZERO, N - A( IOFF ) = ZERO + A( IOFF ) = CZERO IOFF = IOFF + LDA 30 CONTINUE ELSE IOFF = IZERO DO 40 I = 1, IZERO - 1 - A( IOFF ) = ZERO + A( IOFF ) = CZERO IOFF = IOFF + LDA 40 CONTINUE IOFF = IOFF - IZERO DO 50 I = IZERO, N - A( IOFF+I ) = ZERO + A( IOFF+I ) = CZERO 50 CONTINUE END IF ELSE - IOFF = 0 IF( IUPLO.EQ.1 ) THEN * * Set the first IZERO rows and columns to zero. * + IOFF = 0 DO 70 J = 1, N I2 = MIN( J, IZERO ) DO 60 I = 1, I2 - A( IOFF+I ) = ZERO + A( IOFF+I ) = CZERO 60 CONTINUE IOFF = IOFF + LDA 70 CONTINUE @@ -362,10 +379,11 @@ * * Set the last IZERO rows and columns to zero. * + IOFF = 0 DO 90 J = 1, N I1 = MAX( J, IZERO ) DO 80 I = I1, N - A( IOFF+I ) = ZERO + A( IOFF+I ) = CZERO 80 CONTINUE IOFF = IOFF + LDA 90 CONTINUE @@ -379,16 +397,30 @@ * CALL CLAIPD( N, A, LDA+1, 0 ) * +* End generate test matrix A. +* +* * Do for each value of NB in NBVAL * DO 150 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* NB = NBVAL( INB ) CALL XLAENV( 1, NB ) * -* Compute the L*D*L' or U*D*U' factorization of the -* matrix. +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. * CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* LWORK = MAX( 2, NB )*LDA SRNAMT = 'CHETRF' CALL CHETRF( UPLO, N, AFAC, LDA, IWORK, AINV, LWORK, @@ -411,11 +443,14 @@ END IF END IF * -* Check error code from CHETRF. +* Check error code from CHETRF and handle error. * IF( INFO.NE.K ) $ CALL ALAERH( PATH, 'CHETRF', INFO, K, UPLO, N, N, $ -1, -1, NB, IMAT, NFAIL, NERRS, NOUT ) +* +* Set the condition estimate flag if the INFO is not 0. +* IF( INFO.NE.0 ) THEN TRFCON = .TRUE. ELSE @@ -430,7 +465,10 @@ NT = 1 * *+ TEST 2 -* Form the inverse and compute the residual. +* Form the inverse and compute the residual, +* if the factorization was competed without INFO > 0 +* (i.e. there is no zero rows and columns). +* Do it only for the first block size. * IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) @@ -439,12 +477,15 @@ CALL CHETRI2( UPLO, N, AINV, LDA, IWORK, WORK, $ LWORK, INFO ) * -* Check error code from CHETRI. +* Check error code from CHETRI2 and handle error. * IF( INFO.NE.0 ) - $ CALL ALAERH( PATH, 'CHETRI', INFO, -1, UPLO, N, + $ CALL ALAERH( PATH, 'CHETRI2', INFO, -1, UPLO, N, $ N, -1, -1, -1, IMAT, NFAIL, NERRS, $ NOUT ) +* +* Compute the residual for a symmetric matrix times +* its inverse. * CALL CPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, $ RWORK, RCONDC, RESULT( 2 ) ) @@ -477,12 +518,17 @@ RCONDC = ZERO GO TO 140 END IF +* +* Do for each value of NRHS in NSVAL. * DO 130 IRHS = 1, NNS NRHS = NSVAL( IRHS ) * -*+ TEST 3 +*+ TEST 3 (Using TRS) * Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B * SRNAMT = 'CLARHS' CALL CLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, @@ -494,7 +540,7 @@ CALL CHETRS( UPLO, N, NRHS, AFAC, LDA, IWORK, X, $ LDA, INFO ) * -* Check error code from CHETRS. +* Check error code from CHETRS and handle error. * IF( INFO.NE.0 ) $ CALL ALAERH( PATH, 'CHETRS', INFO, 0, UPLO, N, @@ -502,11 +548,17 @@ $ NERRS, NOUT ) * CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* CALL CPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, $ LDA, RWORK, RESULT( 3 ) ) * -*+ TEST 4 +*+ TEST 4 (Using TRS2) * Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B * SRNAMT = 'CLARHS' CALL CLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, @@ -518,7 +570,7 @@ CALL CHETRS2( UPLO, N, NRHS, AFAC, LDA, IWORK, X, $ LDA, WORK, INFO ) * -* Check error code from CHETRS2. +* Check error code from CHETRS2 and handle error. * IF( INFO.NE.0 ) $ CALL ALAERH( PATH, 'CHETRS2', INFO, 0, UPLO, N, @@ -526,6 +578,9 @@ $ NERRS, NOUT ) * CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* CALL CPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, $ LDA, RWORK, RESULT( 4 ) ) * @@ -544,7 +599,7 @@ $ RWORK( NRHS+1 ), WORK, $ RWORK( 2*NRHS+1 ), INFO ) * -* Check error code from CHERFS. +* Check error code from CHERFS and handle error. * IF( INFO.NE.0 ) $ CALL ALAERH( PATH, 'CHERFS', INFO, 0, UPLO, N, @@ -569,7 +624,10 @@ NFAIL = NFAIL + 1 END IF 120 CONTINUE - NRUN = NRUN + 5 + NRUN = NRUN + 6 +* +* End do for each value of NRHS in NSVAL. +* 130 CONTINUE * *+ TEST 9 @@ -581,11 +639,13 @@ CALL CHECON( UPLO, N, AFAC, LDA, IWORK, ANORM, RCOND, $ WORK, INFO ) * -* Check error code from CHECON. +* Check error code from CHECON and handle error. * IF( INFO.NE.0 ) $ CALL ALAERH( PATH, 'CHECON', INFO, 0, UPLO, N, N, $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Compute the test ratio to compare values of RCOND * RESULT( 9 ) = SGET06( RCOND, RCONDC ) * diff --git a/lapack-netlib/TESTING/LIN/cchkhe_rook.f b/lapack-netlib/TESTING/LIN/cchkhe_rook.f new file mode 100644 index 000000000..7d7ab8e98 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cchkhe_rook.f @@ -0,0 +1,844 @@ +*> \brief \b CCHKHE_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCHKHE_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, +* XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* REAL RWORK( * ) +* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CCHKHE_ROOK tests CHETRF_ROOK, -TRI_ROOK, -TRS_ROOK, +*> and -CON_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is 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. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CCHKHE_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, + $ XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NNB, NNS, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + REAL RWORK( * ) + COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL ONEHALF + PARAMETER ( ONEHALF = 0.5E+0 ) + REAL EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) + COMPLEX CZERO + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) + INTEGER NTYPES + PARAMETER ( NTYPES = 10 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) +* .. +* .. Local Scalars .. + LOGICAL TRFCON, ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA, + $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, + $ NRUN, NT + REAL ALPHA, ANORM, CNDNUM, CONST, LAM_MAX, LAM_MIN, + $ RCOND, RCONDC, STEMP +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ), IDUMMY( 1 ) + REAL RESULT( NTESTS ) + COMPLEX CDUMMY( 1 ) +* .. +* .. External Functions .. + REAL CLANGE, CLANHE, SGET06 + EXTERNAL CLANGE, CLANHE, SGET06 +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, CERRHE, CHEEVX, CGET04, + $ CLACPY, CLARHS, CLATB4, CLATMS, CPOT02, + $ CPOT03, CHECON_ROOK, CHET01_ROOK, CHETRF_ROOK, + $ CHETRI_ROOK, CHETRS_ROOK, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Test path +* + PATH( 1: 1 ) = 'Complex precision' + PATH( 2: 3 ) = 'HR' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Complex precision' + MATPATH( 2: 3 ) = 'HE' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL CERRHE( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 270 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 260 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 260 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 260 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 250 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with CLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with CLATMS. +* + SRNAMT = 'CLATMS' + CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from CLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 250 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = CZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = CZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = CZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = CZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* +* Do for each value of NB in NBVAL +* + DO 240 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'CHETRF_ROOK' + CALL CHETRF_ROOK( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from CHETRF_ROOK and handle error. +* + IF( INFO.NE.K) + $ CALL ALAERH( PATH, 'CHETRF_ROOK', INFO, K, + $ UPLO, N, N, -1, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Set the condition estimate flag if the INFO is not 0. +* + IF( INFO.NE.0 ) THEN + TRFCON = .TRUE. + ELSE + TRFCON = .FALSE. + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL CHET01_ROOK( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +*+ TEST 2 +* Form the inverse and compute the residual, +* if the factorization was competed without INFO > 0 +* (i.e. there is no zero rows and columns). +* Do it only for the first block size. +* + IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN + CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + SRNAMT = 'CHETRI_ROOK' + CALL CHETRI_ROOK( UPLO, N, AINV, LDA, IWORK, WORK, + $ INFO ) +* +* Check error code from CHETRI_ROOK and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'CHETRI_ROOK', INFO, -1, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the residual for a Hermitian matrix times +* its inverse. +* + CALL CPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, + $ RWORK, RCONDC, RESULT( 2 ) ) + NT = 2 + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +*+ TEST 3 +* Compute largest element in U or L +* + RESULT( 3 ) = ZERO + STEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) ) / + $ ( ONE-ALPHA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Compute largest element in U +* + K = N + 120 CONTINUE + IF( K.LE.1 ) + $ GO TO 130 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in U +* + STEMP = CLANGE( 'M', K-1, 1, + $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k-1 in U +* + STEMP = CLANGE( 'M', K-2, 2, + $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK ) + K = K - 1 +* + END IF +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = STEMP +* + K = K - 1 +* + GO TO 120 + 130 CONTINUE +* + ELSE +* +* Compute largest element in L +* + K = 1 + 140 CONTINUE + IF( K.GE.N ) + $ GO TO 150 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in L +* + STEMP = CLANGE( 'M', N-K, 1, + $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k+1 in L +* + STEMP = CLANGE( 'M', N-K-1, 2, + $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK ) + K = K + 1 +* + END IF +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = STEMP +* + K = K + 1 +* + GO TO 140 + 150 CONTINUE + END IF +* +* +*+ TEST 4 +* Compute largest 2-Norm of 2-by-2 diag blocks +* + RESULT( 4 ) = ZERO + STEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) )* + $ ( ( ONE + ALPHA ) / ( ONE - ALPHA ) ) + CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Loop backward for UPLO = 'U' +* + K = N + 160 CONTINUE + IF( K.LE.1 ) + $ GO TO 170 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two eigenvalues of a 2-by-2 block, +* store them in WORK array +* + CALL CHEEVX( 'N', 'A', UPLO, 2, + $ AINV( ( K-2 )*LDA+K-1 ), LDA,STEMP, + $ STEMP, ITEMP, ITEMP, ZERO, ITEMP, + $ RWORK, CDUMMY, 1, WORK, 16, + $ RWORK( 3 ), IWORK( N+1 ), IDUMMY, + $ INFO ) +* + LAM_MAX = MAX( ABS( RWORK( 1 ) ), + $ ABS( RWORK( 2 ) ) ) + LAM_MIN = MIN( ABS( RWORK( 1 ) ), + $ ABS( RWORK( 2 ) ) ) +* + STEMP = LAM_MAX / LAM_MIN +* +* STEMP should be bounded by CONST +* + STEMP = ABS( STEMP ) - CONST + THRESH + IF( STEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = STEMP + K = K - 1 +* + END IF +* + K = K - 1 +* + GO TO 160 + 170 CONTINUE +* + ELSE +* +* Loop forward for UPLO = 'L' +* + K = 1 + 180 CONTINUE + IF( K.GE.N ) + $ GO TO 190 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two eigenvalues of a 2-by-2 block, +* store them in WORK array +* + CALL CHEEVX( 'N', 'A', UPLO, 2, + $ AINV( ( K-1 )*LDA+K ), LDA, STEMP, + $ STEMP, ITEMP, ITEMP, ZERO, ITEMP, + $ RWORK, CDUMMY, 1, WORK, 16, + $ RWORK( 3 ), IWORK( N+1 ), IDUMMY, + $ INFO ) +* + LAM_MAX = MAX( ABS( RWORK( 1 ) ), + $ ABS( RWORK( 2 ) ) ) + LAM_MIN = MIN( ABS( RWORK( 1 ) ), + $ ABS( RWORK( 2 ) ) ) +* + STEMP = LAM_MAX / LAM_MIN +* +* STEMP should be bounded by CONST +* + STEMP = ABS( STEMP ) - CONST + THRESH + IF( STEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = STEMP + K = K + 1 +* + END IF +* + K = K + 1 +* + GO TO 180 + 190 CONTINUE + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 200 K = 3, 4 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 200 CONTINUE + NRUN = NRUN + 2 +* +* Skip the other tests if this is not the first block +* size. +* + IF( INB.GT.1 ) + $ GO TO 240 +* +* Do only the condition estimate if INFO is not 0. +* + IF( TRFCON ) THEN + RCONDC = ZERO + GO TO 230 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 220 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +* Begin loop over NRHS values +* +* +*+ TEST 5 ( Using TRS_ROOK) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'CLARHS' + CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'CHETRS_ROOK' + CALL CHETRS_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, INFO ) +* +* Check error code from CHETRS_ROOK and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'CHETRS_ROOK', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) +* + CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL CPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 5 ) ) +* +*+ TEST 6 +* Check solution from generated exact solution. +* + CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 6 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 210 K = 5, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 210 CONTINUE + NRUN = NRUN + 2 +* +* End do for each value of NRHS in NSVAL. +* + 220 CONTINUE +* +*+ TEST 7 +* Get an estimate of RCOND = 1/CNDNUM. +* + 230 CONTINUE + ANORM = CLANHE( '1', UPLO, N, A, LDA, RWORK ) + SRNAMT = 'CHECON_ROOK' + CALL CHECON_ROOK( UPLO, N, AFAC, LDA, IWORK, ANORM, + $ RCOND, WORK, INFO ) +* +* Check error code from CHECON_ROOK and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'CHECON_ROOK', INFO, 0, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the test ratio to compare values of RCOND +* + RESULT( 7 ) = SGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7, + $ RESULT( 7 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 240 CONTINUE +* + 250 CONTINUE + 260 CONTINUE + 270 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of CCHKHE_ROOK +* + END diff --git a/lapack-netlib/TESTING/LIN/cchksy.f b/lapack-netlib/TESTING/LIN/cchksy.f index 02be26a29..d25417f7a 100644 --- a/lapack-netlib/TESTING/LIN/cchksy.f +++ b/lapack-netlib/TESTING/LIN/cchksy.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, * XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNB, NNS, NOUT @@ -24,7 +24,7 @@ * COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -135,14 +135,12 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is COMPLEX array, dimension -*> (NMAX*max(2,NSMAX)) +*> WORK is COMPLEX array, dimension (NMAX*max(2,NSMAX)) *> \endverbatim *> *> \param[out] RWORK *> \verbatim -*> RWORK is REAL array, -*> dimension (NMAX+2*NSMAX) +*> RWORK is REAL array, dimension (NMAX+2*NSMAX) *> \endverbatim *> *> \param[out] IWORK @@ -159,12 +157,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup complex_lin * @@ -173,10 +171,10 @@ $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, $ XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -197,7 +195,7 @@ REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) COMPLEX CZERO - PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) INTEGER NTYPES PARAMETER ( NTYPES = 11 ) INTEGER NTESTS @@ -299,9 +297,9 @@ DO 160 IUPLO = 1, 2 UPLO = UPLOS( IUPLO ) * - IF( IMAT.NE.NTYPES ) THEN +* Begin generate test matrix A. * -* Begin generate the test matrix A. + IF( IMAT.NE.NTYPES ) THEN * * Set up parameters with CLATB4 for the matrix generator * based on the type of matrix to be generated. @@ -321,6 +319,9 @@ IF( INFO.NE.0 ) THEN CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* GO TO 160 END IF * @@ -392,18 +393,20 @@ ELSE IZERO = 0 END IF -* -* End generate the test matrix A. * ELSE * -* Use a special block diagonal matrix to test alternate -* code for the 2 x 2 blocks. +* For matrix kind IMAT = 11, generate special block +* diagonal matrix to test alternate code +* for the 2 x 2 blocks. * CALL CLATSY( UPLO, N, A, LDA, ISEED ) * END IF * +* End generate test matrix A. +* +* * Do for each value of NB in NBVAL * DO 150 INB = 1, NNB @@ -522,6 +525,8 @@ RCONDC = ZERO GO TO 140 END IF +* +* Do for each value of NRHS in NSVAL. * DO 130 IRHS = 1, NNS NRHS = NSVAL( IRHS ) @@ -601,7 +606,7 @@ $ RWORK( NRHS+1 ), WORK, $ RWORK( 2*NRHS+1 ), INFO ) * -* Check error code from CSYRFS. +* Check error code from CSYRFS and handle error. * IF( INFO.NE.0 ) $ CALL ALAERH( PATH, 'CSYRFS', INFO, 0, UPLO, N, @@ -627,6 +632,9 @@ END IF 120 CONTINUE NRUN = NRUN + 6 +* +* End do for each value of NRHS in NSVAL. +* 130 CONTINUE * *+ TEST 9 @@ -644,7 +652,7 @@ $ CALL ALAERH( PATH, 'CSYCON', INFO, 0, UPLO, N, N, $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) * -* Compute the test ratio to compare to values of RCOND +* Compute the test ratio to compare values of RCOND * RESULT( 9 ) = SGET06( RCOND, RCONDC ) * diff --git a/lapack-netlib/TESTING/LIN/cchksy_rook.f b/lapack-netlib/TESTING/LIN/cchksy_rook.f new file mode 100644 index 000000000..cafd4d936 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cchksy_rook.f @@ -0,0 +1,860 @@ +*> \brief \b CCHKSY_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, +* XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* REAL RWORK( * ) +* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CCHKSY_ROOK tests CSYTRF_ROOK, -TRI_ROOK, -TRS_ROOK, +*> and -CON_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is 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. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX)) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, + $ XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NNB, NNS, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + REAL RWORK( * ) + COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL ONEHALF + PARAMETER ( ONEHALF = 0.5E+0 ) + REAL EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) + COMPLEX CZERO + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) + INTEGER NTYPES + PARAMETER ( NTYPES = 11 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) +* .. +* .. Local Scalars .. + LOGICAL TRFCON, ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA, + $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, + $ NRUN, NT + REAL ALPHA, ANORM, CNDNUM, CONST, LAM_MAX, LAM_MIN, + $ RCOND, RCONDC, STEMP +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) + COMPLEX BLOCK( 2, 2 ), CDUMMY( 1 ) +* .. +* .. External Functions .. + REAL CLANGE, CLANSY, SGET06 + EXTERNAL CLANGE, CLANSY, SGET06 +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, CERRSY, CGEEVX, CGET04, + $ CLACPY, CLARHS, CLATB4, CLATMS, CLATSY, CSYT02, + $ CSYT03, CSYCON_ROOK, CSYT01_ROOK, CSYTRF_ROOK, + $ CSYTRI_ROOK, CSYTRS_ROOK, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Test path +* + PATH( 1: 1 ) = 'Complex precision' + PATH( 2: 3 ) = 'SR' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Complex precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL CERRSY( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 270 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 260 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 260 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 260 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 250 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate test matrix A. +* + IF( IMAT.NE.NTYPES ) THEN +* +* Set up parameters with CLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with CLATMS. +* + SRNAMT = 'CLATMS' + CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from CLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 250 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = CZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = CZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = CZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = CZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* + ELSE +* +* For matrix kind IMAT = 11, generate special block +* diagonal matrix to test alternate code +* for the 2 x 2 blocks. +* + CALL CLATSY( UPLO, N, A, LDA, ISEED ) +* + END IF +* +* End generate test matrix A. +* +* +* Do for each value of NB in NBVAL +* + DO 240 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'CSYTRF_ROOK' + CALL CSYTRF_ROOK( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from CSYTRF_ROOK and handle error. +* + IF( INFO.NE.K) + $ CALL ALAERH( PATH, 'CSYTRF_ROOK', INFO, K, + $ UPLO, N, N, -1, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Set the condition estimate flag if the INFO is not 0. +* + IF( INFO.NE.0 ) THEN + TRFCON = .TRUE. + ELSE + TRFCON = .FALSE. + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL CSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +*+ TEST 2 +* Form the inverse and compute the residual, +* if the factorization was competed without INFO > 0 +* (i.e. there is no zero rows and columns). +* Do it only for the first block size. +* + IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN + CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + SRNAMT = 'CSYTRI_ROOK' + CALL CSYTRI_ROOK( UPLO, N, AINV, LDA, IWORK, WORK, + $ INFO ) +* +* Check error code from CSYTRI_ROOK and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'CSYTRI_ROOK', INFO, -1, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the residual for a symmetric matrix times +* its inverse. +* + CALL CSYT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, + $ RWORK, RCONDC, RESULT( 2 ) ) + NT = 2 + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +*+ TEST 3 +* Compute largest element in U or L +* + RESULT( 3 ) = ZERO + STEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) ) / + $ ( ONE-ALPHA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Compute largest element in U +* + K = N + 120 CONTINUE + IF( K.LE.1 ) + $ GO TO 130 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in U +* + STEMP = CLANGE( 'M', K-1, 1, + $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k-1 in U +* + STEMP = CLANGE( 'M', K-2, 2, + $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK ) + K = K - 1 +* + END IF +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = STEMP +* + K = K - 1 +* + GO TO 120 + 130 CONTINUE +* + ELSE +* +* Compute largest element in L +* + K = 1 + 140 CONTINUE + IF( K.GE.N ) + $ GO TO 150 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in L +* + STEMP = CLANGE( 'M', N-K, 1, + $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k+1 in L +* + STEMP = CLANGE( 'M', N-K-1, 2, + $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK ) + K = K + 1 +* + END IF +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = STEMP +* + K = K + 1 +* + GO TO 140 + 150 CONTINUE + END IF +* +* +*+ TEST 4 +* Compute largest 2-Norm of 2-by-2 diag blocks +* + RESULT( 4 ) = ZERO + STEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) )* + $ ( ( ONE + ALPHA ) / ( ONE - ALPHA ) ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Loop backward for UPLO = 'U' +* + K = N + 160 CONTINUE + IF( K.LE.1 ) + $ GO TO 170 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two eigenvalues of a 2-by-2 block, +* store them in WORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 ) + BLOCK( 2, 1 ) = AFAC( ( K-2 )*LDA+K ) + BLOCK( 1, 2 ) = BLOCK( 2, 1 ) + BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K ) +* + CALL CGEEVX( 'N', 'N', 'N', 'N', 2, BLOCK, + $ 2, WORK, CDUMMY, 1, CDUMMY, 1, + $ ITEMP, ITEMP2, RWORK, STEMP, + $ RWORK( 3 ), RWORK( 5 ), WORK( 3 ), + $ 4, RWORK( 7 ), INFO ) +* + LAM_MAX = MAX( ABS( WORK( 1 ) ), + $ ABS( WORK( 2 ) ) ) + LAM_MIN = MIN( ABS( WORK( 1 ) ), + $ ABS( WORK( 2 ) ) ) +* + STEMP = LAM_MAX / LAM_MIN +* +* STEMP should be bounded by CONST +* + STEMP = ABS( STEMP ) - CONST + THRESH + IF( STEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = STEMP + K = K - 1 +* + END IF +* + K = K - 1 +* + GO TO 160 + 170 CONTINUE +* + ELSE +* +* Loop forward for UPLO = 'L' +* + K = 1 + 180 CONTINUE + IF( K.GE.N ) + $ GO TO 190 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two eigenvalues of a 2-by-2 block, +* store them in WORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K ) + BLOCK( 2, 1 ) = AFAC( ( K-1 )*LDA+K+1 ) + BLOCK( 1, 2 ) = BLOCK( 2, 1 ) + BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 ) +* + CALL CGEEVX( 'N', 'N', 'N', 'N', 2, BLOCK, + $ 2, WORK, CDUMMY, 1, CDUMMY, 1, + $ ITEMP, ITEMP2, RWORK, STEMP, + $ RWORK( 3 ), RWORK( 5 ), WORK( 3 ), + $ 4, RWORK( 7 ), INFO ) +* + LAM_MAX = MAX( ABS( WORK( 1 ) ), + $ ABS( WORK( 2 ) ) ) + LAM_MIN = MIN( ABS( WORK( 1 ) ), + $ ABS( WORK( 2 ) ) ) +* + STEMP = LAM_MAX / LAM_MIN +* +* STEMP should be bounded by CONST +* + STEMP = ABS( STEMP ) - CONST + THRESH + IF( STEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = STEMP + K = K + 1 +* + END IF +* + K = K + 1 +* + GO TO 180 + 190 CONTINUE + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 200 K = 3, 4 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 200 CONTINUE + NRUN = NRUN + 2 +* +* Skip the other tests if this is not the first block +* size. +* + IF( INB.GT.1 ) + $ GO TO 240 +* +* Do only the condition estimate if INFO is not 0. +* + IF( TRFCON ) THEN + RCONDC = ZERO + GO TO 230 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 220 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 5 ( Using TRS_ROOK) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'CLARHS' + CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'CSYTRS_ROOK' + CALL CSYTRS_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, INFO ) +* +* Check error code from CSYTRS_ROOK and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'CSYTRS_ROOK', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) +* + CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL CSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 5 ) ) +* +*+ TEST 6 +* Check solution from generated exact solution. +* + CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 6 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 210 K = 5, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 210 CONTINUE + NRUN = NRUN + 2 +* +* End do for each value of NRHS in NSVAL. +* + 220 CONTINUE +* +*+ TEST 7 +* Get an estimate of RCOND = 1/CNDNUM. +* + 230 CONTINUE + ANORM = CLANSY( '1', UPLO, N, A, LDA, RWORK ) + SRNAMT = 'CSYCON_ROOK' + CALL CSYCON_ROOK( UPLO, N, AFAC, LDA, IWORK, ANORM, + $ RCOND, WORK, INFO ) +* +* Check error code from CSYCON_ROOK and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'CSYCON_ROOK', INFO, 0, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the test ratio to compare values of RCOND +* + RESULT( 7 ) = SGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7, + $ RESULT( 7 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 240 CONTINUE +* + 250 CONTINUE + 260 CONTINUE + 270 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test(', I2, ') =', G12.5 ) + 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, + $ ', test(', I2, ') =', G12.5 ) + RETURN +* +* End of CCHKSY_ROOK +* + END diff --git a/lapack-netlib/TESTING/LIN/cdrvhe.f b/lapack-netlib/TESTING/LIN/cdrvhe.f index 8bf5351e4..9d5beb843 100644 --- a/lapack-netlib/TESTING/LIN/cdrvhe.f +++ b/lapack-netlib/TESTING/LIN/cdrvhe.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CDRVHE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,8 +117,7 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is COMPLEX array, dimension -*> (NMAX*max(2,NRHS)) +*> WORK is COMPLEX array, dimension (NMAX*max(2,NRHS)) *> \endverbatim *> *> \param[out] RWORK @@ -140,12 +139,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex_lin * @@ -154,10 +153,10 @@ $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -226,7 +225,7 @@ * * Initialize constants and the random number seed. * - PATH( 1: 1 ) = 'C' + PATH( 1: 1 ) = 'Complex precision' PATH( 2: 3 ) = 'HE' NRUN = 0 NFAIL = 0 diff --git a/lapack-netlib/TESTING/LIN/cdrvhe_rook.f b/lapack-netlib/TESTING/LIN/cdrvhe_rook.f new file mode 100644 index 000000000..6110aadf9 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cdrvhe_rook.f @@ -0,0 +1,527 @@ +*> \brief \b CDRVHE_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CDRVHE_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, +* NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, +* IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* REAL RWORK( * ) +* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CDRVHE_ROOK tests the driver routines CHESV_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is 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. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (NMAX*max(2,NRHS)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CDRVHE_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NOUT, NRHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + REAL RWORK( * ) + COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 MATPATH, PATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + REAL AINVNM, ANORM, CNDNUM, RCONDC +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) + +* .. +* .. External Functions .. + REAL CLANHE + EXTERNAL CLANHE +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, CERRVX, + $ CGET04, CLACPY, CLARHS, CLATB4, CLATMS, + $ CHESV_ROOK, CHET01_ROOK, CPOT02, + $ CHETRF_ROOK, CHETRI_ROOK +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Complex precision' + PATH( 2: 3 ) = 'HR' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Complex precision' + MATPATH( 2: 3 ) = 'HE' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL CERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for which the block +* routine should be used, which will be later returned by ILAENV. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with CLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with CLATMS. +* + SRNAMT = 'CLATMS' + CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from CLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of +* the matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Compute the condition number for comparison with +* the value returned by CHESVX_ROOK. +* + IF( ZEROT ) THEN + IF( IFACT.EQ.1 ) + $ GO TO 150 + RCONDC = ZERO +* + ELSE IF( IFACT.EQ.1 ) THEN +* +* Compute the 1-norm of A. +* + ANORM = CLANHE( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL CHETRF_ROOK( UPLO, N, AFAC, LDA, IWORK, WORK, + $ LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* + CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + LWORK = (N+NB+1)*(NB+3) + CALL CHETRI_ROOK( UPLO, N, AINV, LDA, IWORK, + $ WORK, INFO ) + AINVNM = CLANHE( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'CLARHS' + CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test CHESV_ROOK --- +* + IF( IFACT.EQ.2 ) THEN + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using +* CHESV_ROOK. +* + SRNAMT = 'CHESV_ROOK' + CALL CHESV_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from CHESV_ROOK and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'CHESV_ROOK', INFO, K, UPLO, + $ N, N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +*+ TEST 1 Reconstruct matrix from factors and compute +* residual. +* + CALL CHET01_ROOK( UPLO, N, A, LDA, AFAC, LDA, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +*+ TEST 2 Compute residual of the computed solution. +* + CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL CPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +*+ TEST 3 +* Check solution from generated exact solution. +* + CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 3 ) ) + NT = 3 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'CHESV_ROOK', UPLO, + $ N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of CDRVHE_ROOK +* + END diff --git a/lapack-netlib/TESTING/LIN/cdrvpox.f b/lapack-netlib/TESTING/LIN/cdrvpox.f index 2f14d94ba..b763d6d9b 100644 --- a/lapack-netlib/TESTING/LIN/cdrvpox.f +++ b/lapack-netlib/TESTING/LIN/cdrvpox.f @@ -153,7 +153,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex_lin * @@ -162,10 +162,10 @@ $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -530,11 +530,12 @@ * * Check the error code from CPOSVX. * - IF( INFO.NE.IZERO ) - $ CALL ALAERH( PATH, 'CPOSVX', INFO, IZERO, + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'CPOSVX', INFO, IZERO, $ FACT // UPLO, N, N, -1, -1, NRHS, $ IMAT, NFAIL, NERRS, NOUT ) GO TO 90 + END IF * IF( INFO.EQ.0 ) THEN IF( .NOT.PREFAC ) THEN diff --git a/lapack-netlib/TESTING/LIN/cdrvrfp.f b/lapack-netlib/TESTING/LIN/cdrvrfp.f index 5aa736b56..075242677 100644 --- a/lapack-netlib/TESTING/LIN/cdrvrfp.f +++ b/lapack-netlib/TESTING/LIN/cdrvrfp.f @@ -232,7 +232,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex_lin * @@ -244,10 +244,10 @@ + C_WORK_CPOT03, S_WORK_CLATMS, S_WORK_CLANHE, + S_WORK_CPOT01, S_WORK_CPOT02, S_WORK_CPOT03 ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. INTEGER NN, NNS, NNT, NOUT @@ -345,7 +345,7 @@ * * If N.EQ.0, only consider the first type * - IF( N.EQ.0 .AND. IIT.GT.1 ) GO TO 120 + IF( N.EQ.0 .AND. IIT.GE.1 ) GO TO 120 * * Skip types 3, 4, or 5 if the matrix size is too small. * @@ -452,13 +452,16 @@ * * Compute the 1-norm condition number of A. * - AINVNM = CLANHE( '1', UPLO, N, A, LDA, + IF ( N .NE. 0 ) THEN + AINVNM = CLANHE( '1', UPLO, N, A, LDA, + S_WORK_CLANHE ) - RCONDC = ( ONE / ANORM ) / AINVNM + RCONDC = ( ONE / ANORM ) / AINVNM * -* Restore the matrix A. +* Restore the matrix A. * CALL CLACPY( UPLO, N, N, ASAV, LDA, A, LDA ) + END IF + * END IF * diff --git a/lapack-netlib/TESTING/LIN/cdrvsy.f b/lapack-netlib/TESTING/LIN/cdrvsy.f index e860b740d..475e90200 100644 --- a/lapack-netlib/TESTING/LIN/cdrvsy.f +++ b/lapack-netlib/TESTING/LIN/cdrvsy.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE CDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,8 +117,7 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is COMPLEX array, dimension -*> (NMAX*max(2,NRHS)) +*> WORK is COMPLEX array, dimension (NMAX*max(2,NRHS)) *> \endverbatim *> *> \param[out] RWORK @@ -140,12 +139,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex_lin * @@ -154,10 +153,10 @@ $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/cdrvsy_rook.f b/lapack-netlib/TESTING/LIN/cdrvsy_rook.f new file mode 100644 index 000000000..4dab87576 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cdrvsy_rook.f @@ -0,0 +1,536 @@ +*> \brief \b CDRVSY_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, +* NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, +* IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* REAL RWORK( * ) +* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CDRVSY_ROOK tests the driver routines CSYSV_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is 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. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NOUT, NRHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + REAL RWORK( * ) + COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 11, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 MATPATH, PATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + REAL AINVNM, ANORM, CNDNUM, RCONDC +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) + +* .. +* .. External Functions .. + REAL CLANSY + EXTERNAL CLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, CERRVX, CGET04, + $ CLACPY, CLARHS, CLASET, CLATB4, CLATMS, CLATSY, + $ CPOT05, CSYSV_ROOK, CSYT01_ROOK, CSYT02, + $ CSYTRF_ROOK, CSYTRI_ROOK +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Complex precision' + PATH( 2: 3 ) = 'SR' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Complex precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL CERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for which the block +* routine should be used, which will be later returned by ILAENV. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* + IF( IMAT.NE.NTYPES ) THEN +* +* Begin generate the test matrix A. +* +* Set up parameters with CLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with CLATMS. +* + SRNAMT = 'CLATMS' + CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from CLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of +* the matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* + ELSE +* +* IMAT = NTYPES: Use a special block diagonal matrix to +* test alternate code for the 2-by-2 blocks. +* + CALL CLATSY( UPLO, N, A, LDA, ISEED ) + END IF +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Compute the condition number for comparison with +* the value returned by CSYSVX_ROOK. +* + IF( ZEROT ) THEN + IF( IFACT.EQ.1 ) + $ GO TO 150 + RCONDC = ZERO +* + ELSE IF( IFACT.EQ.1 ) THEN +* +* Compute the 1-norm of A. +* + ANORM = CLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* + + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL CSYTRF_ROOK( UPLO, N, AFAC, LDA, IWORK, WORK, + $ LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* + CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + LWORK = (N+NB+1)*(NB+3) + CALL CSYTRI_ROOK( UPLO, N, AINV, LDA, IWORK, + $ WORK, INFO ) + AINVNM = CLANSY( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'CLARHS' + CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test CSYSV_ROOK --- +* + IF( IFACT.EQ.2 ) THEN + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using +* CSYSV_ROOK. +* + SRNAMT = 'CSYSV_ROOK' + CALL CSYSV_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from CSYSV_ROOK and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'CSYSV_ROOK', INFO, K, UPLO, + $ N, N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +*+ TEST 1 Reconstruct matrix from factors and compute +* residual. +* + CALL CSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDA, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +*+ TEST 2 Compute residual of the computed solution. +* + CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL CSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +*+ TEST 3 +* Check solution from generated exact solution. +* + CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 3 ) ) + NT = 3 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'CSYSV_ROOK', UPLO, + $ N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of CDRVSY_ROOK +* + END diff --git a/lapack-netlib/TESTING/LIN/cerrhe.f b/lapack-netlib/TESTING/LIN/cerrhe.f index 03a285a1c..19a3182f7 100644 --- a/lapack-netlib/TESTING/LIN/cerrhe.f +++ b/lapack-netlib/TESTING/LIN/cerrhe.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRHE( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRHE( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -88,9 +88,10 @@ EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHECON, CHERFS, CHETF2, CHETRF, CHETRI, - $ CHETRI2, CHETRS, CHKXER, CHPCON, CHPRFS, - $ CHPTRF, CHPTRI, CHPTRS + EXTERNAL ALAESM, CHECON, CHECON_ROOK, CHERFS, CHETF2, + $ CHETF2_ROOK, CHETRF, CHETRF_ROOK, CHETRI, + $ CHETRI_ROOK, CHETRI2, CHETRS, CHETRS_ROOK, + $ CHKXER, CHPCON, CHPRFS, CHPTRF, CHPTRI, CHPTRS * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -127,8 +128,9 @@ ANRM = 1.0 OK = .TRUE. * -* Test error exits of the routines that use the diagonal pivoting -* factorization of a Hermitian indefinite matrix. +* Test error exits of the routines that use factorization +* of a Hermitian indefinite matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. * IF( LSAMEN( 2, C2, 'HE' ) ) THEN * @@ -251,8 +253,89 @@ CALL CHECON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'CHECON', INFOT, NOUT, LERR, OK ) * -* Test error exits of the routines that use the diagonal pivoting -* factorization of a Hermitian indefinite packed matrix. +* Test error exits of the routines that use factorization +* of a Hermitian indefinite matrix with "rook" +* (bounded Bunch-Kaufman) diagonal pivoting method. +* + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN +* +* CHETRF_ROOK +* + SRNAMT = 'CHETRF_ROOK' + INFOT = 1 + CALL CHETRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) + CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK ) +* +* CHETF2_ROOK +* + SRNAMT = 'CHETF2_ROOK' + INFOT = 1 + CALL CHETF2_ROOK( '/', 0, A, 1, IP, INFO ) + CALL CHKXER( 'CHETF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETF2_ROOK( 'U', -1, A, 1, IP, INFO ) + CALL CHKXER( 'CHETF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETF2_ROOK( 'U', 2, A, 1, IP, INFO ) + CALL CHKXER( 'CHETF2_ROOK', INFOT, NOUT, LERR, OK ) +* +* CHETRI_ROOK +* + SRNAMT = 'CHETRI_ROOK' + INFOT = 1 + CALL CHETRI_ROOK( '/', 0, A, 1, IP, W, INFO ) + CALL CHKXER( 'CHETRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRI_ROOK( 'U', -1, A, 1, IP, W, INFO ) + CALL CHKXER( 'CHETRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRI_ROOK( 'U', 2, A, 1, IP, W, INFO ) + CALL CHKXER( 'CHETRI_ROOK', INFOT, NOUT, LERR, OK ) +* +* CHETRS_ROOK +* + SRNAMT = 'CHETRS_ROOK' + INFOT = 1 + CALL CHETRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHETRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHETRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO ) + CALL CHKXER( 'CHETRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHETRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_ROOK', INFOT, NOUT, LERR, OK ) +* +* CHECON_ROOK +* + SRNAMT = 'CHECON_ROOK' + INFOT = 1 + CALL CHECON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CHECON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHECON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CHECON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHECON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CHECON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CHECON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CHECON_ROOK', INFOT, NOUT, LERR, OK ) +* +* Test error exits of the routines that use factorization +* of a Hermitian indefinite packed matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. * ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/cerrhex.f b/lapack-netlib/TESTING/LIN/cerrhex.f index cc3d2f029..6fac72787 100644 --- a/lapack-netlib/TESTING/LIN/cerrhex.f +++ b/lapack-netlib/TESTING/LIN/cerrhex.f @@ -51,17 +51,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRHE( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -94,9 +94,11 @@ EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHECON, CHERFS, CHETF2, CHETRF, CHETRI, - $ CHETRI2, CHETRS, CHKXER, CHPCON, CHPRFS, - $ CHPTRF, CHPTRI, CHPTRS, CHERFSX + EXTERNAL ALAESM, CHECON, CHECON_ROOK, CHERFS, CHETF2, + $ CHETF2_ROOK, CHETRF, CHETRF_ROOK, CHETRI, + $ CHETRI_ROOK, CHETRI2, CHETRS, CHETRS_ROOK, + $ CHKXER, CHPCON, CHPRFS, CHPTRF, CHPTRI, CHPTRS, + $ CHERFSX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -134,8 +136,9 @@ ANRM = 1.0 OK = .TRUE. * -* Test error exits of the routines that use the diagonal pivoting -* factorization of a Hermitian indefinite matrix. +* Test error exits of the routines that use factorization +* of a Hermitian indefinite matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. * IF( LSAMEN( 2, C2, 'HE' ) ) THEN * @@ -305,8 +308,89 @@ $ PARAMS, W, R, INFO ) CALL CHKXER( 'CHERFSX', INFOT, NOUT, LERR, OK ) * -* Test error exits of the routines that use the diagonal pivoting -* factorization of a Hermitian indefinite packed matrix. +* Test error exits of the routines that use factorization +* of a Hermitian indefinite matrix with "rook" +* (bounded Bunch-Kaufman) diagonal pivoting method. +* + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN +* +* CHETRF_ROOK +* + SRNAMT = 'CHETRF_ROOK' + INFOT = 1 + CALL CHETRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) + CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK ) +* +* CHETF2_ROOK +* + SRNAMT = 'CHETF2_ROOK' + INFOT = 1 + CALL CHETF2_ROOK( '/', 0, A, 1, IP, INFO ) + CALL CHKXER( 'CHETF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETF2_ROOK( 'U', -1, A, 1, IP, INFO ) + CALL CHKXER( 'CHETF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETF2_ROOK( 'U', 2, A, 1, IP, INFO ) + CALL CHKXER( 'CHETF2_ROOK', INFOT, NOUT, LERR, OK ) +* +* CHETRI_ROOK +* + SRNAMT = 'CHETRI_ROOK' + INFOT = 1 + CALL CHETRI_ROOK( '/', 0, A, 1, IP, W, INFO ) + CALL CHKXER( 'CHETRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRI_ROOK( 'U', -1, A, 1, IP, W, INFO ) + CALL CHKXER( 'CHETRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRI_ROOK( 'U', 2, A, 1, IP, W, INFO ) + CALL CHKXER( 'CHETRI_ROOK', INFOT, NOUT, LERR, OK ) +* +* CHETRS_ROOK +* + SRNAMT = 'CHETRS_ROOK' + INFOT = 1 + CALL CHETRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHETRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHETRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO ) + CALL CHKXER( 'CHETRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHETRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_ROOK', INFOT, NOUT, LERR, OK ) +* +* CHECON_ROOK +* + SRNAMT = 'CHECON_ROOK' + INFOT = 1 + CALL CHECON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CHECON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHECON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CHECON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHECON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CHECON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CHECON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CHECON_ROOK', INFOT, NOUT, LERR, OK ) +* +* Test error exits of the routines that use factorization +* of a Hermitian indefinite packed matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. * ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/cerrsy.f b/lapack-netlib/TESTING/LIN/cerrsy.f index a2e82662c..f3fb81710 100644 --- a/lapack-netlib/TESTING/LIN/cerrsy.f +++ b/lapack-netlib/TESTING/LIN/cerrsy.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -88,8 +88,9 @@ * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, CSPCON, CSPRFS, CSPTRF, CSPTRI, - $ CSPTRS, CSYCON, CSYRFS, CSYTF2, CSYTRF, CSYTRI, - $ CSYTRI2, CSYTRS + $ CSPTRS, CSYCON, CSYCON_ROOK, CSYRFS, CSYTF2, + $ CSYTF2_ROOK, CSYTRF, CSYTRF_ROOK, CSYTRI, + $ CSYTRI_ROOK, CSYTRI2, CSYTRS, CSYTRS_ROOK * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -126,11 +127,11 @@ ANRM = 1.0 OK = .TRUE. * - IF( LSAMEN( 2, C2, 'SY' ) ) THEN +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. * -* Test error exits of the routines that use factorization -* of a symmetric indefinite matrix with patrial -* (Bunch-Kaufman) pivoting. + IF( LSAMEN( 2, C2, 'SY' ) ) THEN * * CSYTRF * @@ -251,11 +252,91 @@ CALL CSYCON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'CSYCON', INFOT, NOUT, LERR, OK ) * - ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with "rook" +* (bounded Bunch-Kaufman) diagonal pivoting method. +* + ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN +* +* CSYTRF_ROOK +* + SRNAMT = 'CSYTRF_ROOK' + INFOT = 1 + CALL CSYTRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) + CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK ) +* +* CSYTF2_ROOK +* + SRNAMT = 'CSYTF2_ROOK' + INFOT = 1 + CALL CSYTF2_ROOK( '/', 0, A, 1, IP, INFO ) + CALL CHKXER( 'CSYTF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTF2_ROOK( 'U', -1, A, 1, IP, INFO ) + CALL CHKXER( 'CSYTF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTF2_ROOK( 'U', 2, A, 1, IP, INFO ) + CALL CHKXER( 'CSYTF2_ROOK', INFOT, NOUT, LERR, OK ) +* +* CSYTRI_ROOK +* + SRNAMT = 'CSYTRI_ROOK' + INFOT = 1 + CALL CSYTRI_ROOK( '/', 0, A, 1, IP, W, INFO ) + CALL CHKXER( 'CSYTRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRI_ROOK( 'U', -1, A, 1, IP, W, INFO ) + CALL CHKXER( 'CSYTRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTRI_ROOK( 'U', 2, A, 1, IP, W, INFO ) + CALL CHKXER( 'CSYTRI_ROOK', INFOT, NOUT, LERR, OK ) +* +* CSYTRS_ROOK +* + SRNAMT = 'CSYTRS_ROOK' + INFOT = 1 + CALL CSYTRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CSYTRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CSYTRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO ) + CALL CHKXER( 'CSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CSYTRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_ROOK', INFOT, NOUT, LERR, OK ) * -* Test error exits of the routines that use factorization -* of a symmetric indefinite packed matrix with patrial -* (Bunch-Kaufman) pivoting. +* CSYCON_ROOK +* + SRNAMT = 'CSYCON_ROOK' + INFOT = 1 + CALL CSYCON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYCON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYCON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CSYCON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CSYCON_ROOK', INFOT, NOUT, LERR, OK ) +* +* Test error exits of the routines that use factorization +* of a symmetric indefinite packed matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. +* + ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * * CSPTRF * diff --git a/lapack-netlib/TESTING/LIN/cerrsyx.f b/lapack-netlib/TESTING/LIN/cerrsyx.f index f904176c4..0551c1517 100644 --- a/lapack-netlib/TESTING/LIN/cerrsyx.f +++ b/lapack-netlib/TESTING/LIN/cerrsyx.f @@ -51,17 +51,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -95,7 +95,9 @@ * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, CSPCON, CSPRFS, CSPTRF, CSPTRI, $ CSPTRS, CSYCON, CSYRFS, CSYTF2, CSYTRF, CSYTRI, - $ CSYTRI2, CSYTRS, CSYRFSX + $ CSYTRI2, CSYTRS, CSYRFSX, CSYCON_ROOK, + $ CSYTF2_ROOK, CSYTRF_ROOK, CSYTRI_ROOK, + $ CSYTRS_ROOK * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -133,8 +135,9 @@ ANRM = 1.0 OK = .TRUE. * -* Test error exits of the routines that use the diagonal pivoting -* factorization of a symmetric indefinite matrix. +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. * IF( LSAMEN( 2, C2, 'SY' ) ) THEN * @@ -304,8 +307,89 @@ CALL CSYCON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'CSYCON', INFOT, NOUT, LERR, OK ) * -* Test error exits of the routines that use the diagonal pivoting -* factorization of a symmetric indefinite packed matrix. +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with "rook" +* (bounded Bunch-Kaufman) diagonal pivoting method. +* + ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN +* +* CSYTRF_ROOK +* + SRNAMT = 'CSYTRF_ROOK' + INFOT = 1 + CALL CSYTRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) + CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK ) +* +* CSYTF2_ROOK +* + SRNAMT = 'CSYTF2_ROOK' + INFOT = 1 + CALL CSYTF2_ROOK( '/', 0, A, 1, IP, INFO ) + CALL CHKXER( 'CSYTF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTF2_ROOK( 'U', -1, A, 1, IP, INFO ) + CALL CHKXER( 'CSYTF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTF2_ROOK( 'U', 2, A, 1, IP, INFO ) + CALL CHKXER( 'CSYTF2_ROOK', INFOT, NOUT, LERR, OK ) +* +* CSYTRI_ROOK +* + SRNAMT = 'CSYTRI_ROOK' + INFOT = 1 + CALL CSYTRI_ROOK( '/', 0, A, 1, IP, W, INFO ) + CALL CHKXER( 'CSYTRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRI_ROOK( 'U', -1, A, 1, IP, W, INFO ) + CALL CHKXER( 'CSYTRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTRI_ROOK( 'U', 2, A, 1, IP, W, INFO ) + CALL CHKXER( 'CSYTRI_ROOK', INFOT, NOUT, LERR, OK ) +* +* CSYTRS_ROOK +* + SRNAMT = 'CSYTRS_ROOK' + INFOT = 1 + CALL CSYTRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CSYTRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CSYTRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO ) + CALL CHKXER( 'CSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CSYTRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_ROOK', INFOT, NOUT, LERR, OK ) +* +* CSYCON_ROOK +* + SRNAMT = 'CSYCON_ROOK' + INFOT = 1 + CALL CSYCON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYCON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYCON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CSYCON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CSYCON_ROOK', INFOT, NOUT, LERR, OK ) +* +* Test error exits of the routines that use factorization +* of a symmetric indefinite packed matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/cerrvx.f b/lapack-netlib/TESTING/LIN/cerrvx.f index a91778385..52ca890d1 100644 --- a/lapack-netlib/TESTING/LIN/cerrvx.f +++ b/lapack-netlib/TESTING/LIN/cerrvx.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CERRVX( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRVX( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -90,10 +90,10 @@ * .. * .. External Subroutines .. EXTERNAL CGBSV, CGBSVX, CGESV, CGESVX, CGTSV, CGTSVX, - $ CHESV, CHESVX, CHKXER, CHPSV, CHPSVX, CPBSV, - $ CPBSVX, CPOSV, CPOSVX, CPPSV, CPPSVX, CPTSV, - $ CPTSVX, CSPSV, CSPSVX, CSYSV, - $ CSYSVX + $ CHESV, CHESV_ROOK, CHESVX, CHKXER, CHPSV, + $ CHPSVX, CPBSV, CPBSVX, CPOSV, CPOSVX, CPPSV, + $ CPPSVX, CPTSV, CPTSVX, CSPSV, CSPSVX, CSYSV, + $ CSYSV_ROOK, CSYSVX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -631,6 +631,24 @@ CALL CHESVX( 'N', 'U', 2, 0, A, 2, AF, 2, IP, B, 2, X, 2, $ RCOND, R1, R2, W, 3, RW, INFO ) CALL CHKXER( 'CHESVX', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN +* +* CHESV_ROOK +* + SRNAMT = 'CHESV_ROOK' + INFOT = 1 + CALL CHESV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHESV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHESV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * @@ -735,6 +753,24 @@ CALL CSYSVX( 'N', 'U', 2, 0, A, 2, AF, 2, IP, B, 2, X, 2, $ RCOND, R1, R2, W, 3, RW, INFO ) CALL CHKXER( 'CSYSVX', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN +* +* CSYSV_ROOK +* + SRNAMT = 'CSYSV_ROOK' + INFOT = 1 + CALL CSYSV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYSV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CSYSV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/cerrvxx.f b/lapack-netlib/TESTING/LIN/cerrvxx.f index 1526604a5..95b8386aa 100644 --- a/lapack-netlib/TESTING/LIN/cerrvxx.f +++ b/lapack-netlib/TESTING/LIN/cerrvxx.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRVX( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -91,10 +91,11 @@ * .. * .. External Subroutines .. EXTERNAL CGBSV, CGBSVX, CGESV, CGESVX, CGTSV, CGTSVX, - $ CHESV, CHESVX, CHKXER, CHPSV, CHPSVX, CPBSV, - $ CPBSVX, CPOSV, CPOSVX, CPPSV, CPPSVX, CPTSV, - $ CPTSVX, CSPSV, CSPSVX, CSYSV, CSYSVX, CGESVXX, - $ CPOSVXX, CSYSVXX, CHESVXX, CGBSVXX + $ CHESV, CHESV_ROOK, CHESVX, CHKXER, CHPSV, + $ CHPSVX, CPBSV, CPBSVX, CPOSV, CPOSVX, CPPSV, + $ CPPSVX, CPTSV, CPTSVX, CSPSV, CSPSVX, CSYSV, + $ CSYSV_ROOK, CSYSVX, CGESVXX, CPOSVXX, CSYSVXX, + $ CHESVXX, CGBSVXX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -899,6 +900,24 @@ $ 1, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_N, $ ERR_BNDS_C, NPARAMS, PARAMS, W, RW, INFO ) CALL CHKXER( 'CHESVXX', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN +* +* CHESV_ROOK +* + SRNAMT = 'CHESV_ROOK' + INFOT = 1 + CALL CHESV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHESV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHESV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * @@ -1053,6 +1072,24 @@ $ 1, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_N, $ ERR_BNDS_C, NPARAMS, PARAMS, W, RW, INFO ) CALL CHKXER( 'CSYSVXX', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN +* +* CSYSV_ROOK +* + SRNAMT = 'CSYSV_ROOK' + INFOT = 1 + CALL CSYSV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYSV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CSYSV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/chet01.f b/lapack-netlib/TESTING/LIN/chet01.f index 9a1f64a74..fe08a49fd 100644 --- a/lapack-netlib/TESTING/LIN/chet01.f +++ b/lapack-netlib/TESTING/LIN/chet01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CHET01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDAFAC, LDC, N @@ -21,7 +21,7 @@ * REAL RWORK( * ) * COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex_lin * @@ -126,10 +126,10 @@ SUBROUTINE CHET01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/chet01_rook.f b/lapack-netlib/TESTING/LIN/chet01_rook.f new file mode 100644 index 000000000..1dddc7dd3 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/chet01_rook.f @@ -0,0 +1,239 @@ +*> \brief \b CHET01_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CHET01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, +* RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* REAL RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL RWORK( * ) +* COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHET01_ROOK reconstructs a complex Hermitian indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix, EPS is the machine epsilon, +*> L' is the transpose of L, and U' is the transpose of U. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> complex Hermitian matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> The original complex Hermitian matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is COMPLEX array, dimension (LDAFAC,N) +*> The factored form of the matrix A. AFAC contains the block +*> diagonal matrix D and the multipliers used to obtain the +*> factor L or U from the block L*D*L' or U*D*U' factorization +*> as computed by CSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from CSYTRF_ROOK. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is COMPLEX array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is REAL +*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) +*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CHET01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + REAL RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL RWORK( * ) + COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + REAL ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + REAL CLANHE, SLAMCH + EXTERNAL LSAME, CLANHE, SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL CLASET, CLAVHE_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC AIMAG, REAL +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* Determine EPS and the norm of A. +* + EPS = SLAMCH( 'Epsilon' ) + ANORM = CLANHE( '1', UPLO, N, A, LDA, RWORK ) +* +* Check the imaginary parts of the diagonal elements and return with +* an error code if any are nonzero. +* + DO 10 J = 1, N + IF( AIMAG( AFAC( J, J ) ).NE.ZERO ) THEN + RESID = ONE / EPS + RETURN + END IF + 10 CONTINUE +* +* Initialize C to the identity matrix. +* + CALL CLASET( 'Full', N, N, CZERO, CONE, C, LDC ) +* +* Call CLAVHE_ROOK to form the product D * U' (or D * L' ). +* + CALL CLAVHE_ROOK( UPLO, 'Conjugate', 'Non-unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* Call CLAVHE_ROOK again to multiply by U (or L ). +* + CALL CLAVHE_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 30 J = 1, N + DO 20 I = 1, J - 1 + C( I, J ) = C( I, J ) - A( I, J ) + 20 CONTINUE + C( J, J ) = C( J, J ) - REAL( A( J, J ) ) + 30 CONTINUE + ELSE + DO 50 J = 1, N + C( J, J ) = C( J, J ) - REAL( A( J, J ) ) + DO 40 I = J + 1, N + C( I, J ) = C( I, J ) - A( I, J ) + 40 CONTINUE + 50 CONTINUE + END IF +* +* Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = CLANHE( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID/REAL( N ) )/ANORM ) / EPS + END IF +* + RETURN +* +* End of CHET01_ROOK +* + END diff --git a/lapack-netlib/TESTING/LIN/clatb4.f b/lapack-netlib/TESTING/LIN/clatb4.f index 3b1b1dd52..f98cf24f9 100644 --- a/lapack-netlib/TESTING/LIN/clatb4.f +++ b/lapack-netlib/TESTING/LIN/clatb4.f @@ -61,7 +61,8 @@ *> TYPE is CHARACTER*1 *> The type of the matrix to be generated: *> = 'S': symmetric matrix -*> = 'P': symmetric positive (semi)definite matrix +*> = 'H': Hermitian matrix +*> = 'P': Hermitian positive (semi)definite matrix *> = 'N': nonsymmetric matrix *> \endverbatim *> @@ -112,7 +113,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex_lin * @@ -120,10 +121,10 @@ SUBROUTINE CLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, $ CNDNUM, DIST ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER DIST, TYPE diff --git a/lapack-netlib/TESTING/LIN/clavhe.f b/lapack-netlib/TESTING/LIN/clavhe.f index d4bd8beca..0a5016778 100644 --- a/lapack-netlib/TESTING/LIN/clavhe.f +++ b/lapack-netlib/TESTING/LIN/clavhe.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLAVHE( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, * LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -19,118 +19,133 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> CLAVHE performs one of the matrix-vector operations -*> x := A*x or x := A^H*x, -*> where x is an N element vector and A is one of the factors -*> from the symmetric factorization computed by CHETRF. -*> CHETRF produces a factorization of the form -*> U * D * U^H or L * D * L^H, -*> where U (or L) is a product of permutation and unit upper (lower) -*> triangular matrices, U^H (or L^H) is the conjugate transpose of -*> U (or L), and D is Hermitian and block diagonal with 1 x 1 and -*> 2 x 2 diagonal blocks. The multipliers for the transformations -*> and the upper or lower triangular parts of the diagonal blocks -*> are stored in the leading upper or lower triangle of the 2-D -*> array A. +*> CLAVHE performs one of the matrix-vector operations +*> x := A*x or x := A^H*x, +*> where x is an N element vector and A is one of the factors +*> from the block U*D*U' or L*D*L' factorization computed by CHETRF. *> -*> If TRANS = 'N' or 'n', CLAVHE multiplies either by U or U * D -*> (or L or L * D). -*> If TRANS = 'C' or 'c', CLAVHE multiplies either by U^H or D * U^H -*> (or L^H or D * L^H ). +*> If TRANS = 'N', multiplies by U or U * D (or L or L * D) +*> If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L') *> \endverbatim * * Arguments: * ========== * +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the factor stored in A is upper or lower +*> triangular. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> Specifies the operation to be performed: +*> = 'N': x := A*x +*> = 'C': x := A^H*x +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> Specifies whether or not the diagonal blocks are unit +*> matrices. If the diagonal blocks are assumed to be unit, +*> then A = U or A = L, otherwise A = U*D or A = L*D. +*> = 'U': Diagonal blocks are assumed to be unit matrices. +*> = 'N': Diagonal blocks are assumed to be non-unit matrices. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS *> \verbatim -*> UPLO - CHARACTER*1 -*> On entry, UPLO specifies whether the triangular matrix -*> stored in A is upper or lower triangular. -*> UPLO = 'U' or 'u' The matrix is upper triangular. -*> UPLO = 'L' or 'l' The matrix is lower triangular. -*> Unchanged on exit. +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of vectors +*> x to be multiplied by A. NRHS >= 0. +*> \endverbatim *> -*> TRANS - CHARACTER*1 -*> On entry, TRANS specifies the operation to be performed as -*> follows: -*> TRANS = 'N' or 'n' x := A*x. -*> TRANS = 'C' or 'c' x := A^H*x. -*> Unchanged on exit. +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by CHETRF_ROOK. +*> Stored as a 2-D triangular matrix. +*> \endverbatim *> -*> DIAG - CHARACTER*1 -*> On entry, DIAG specifies whether the diagonal blocks are -*> assumed to be unit matrices: -*> DIAG = 'U' or 'u' Diagonal blocks are unit matrices. -*> DIAG = 'N' or 'n' Diagonal blocks are non-unit. -*> Unchanged on exit. +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim *> -*> N - INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> Unchanged on exit. +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, +*> as determined by CHETRF. *> -*> NRHS - INTEGER -*> On entry, NRHS specifies the number of right hand sides, -*> i.e., the number of vectors x to be multiplied by A. -*> NRHS must be at least zero. -*> Unchanged on exit. +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> (If IPIV( k ) = k, no interchange was done). *> -*> A - COMPLEX array, dimension( LDA, N ) -*> On entry, A contains a block diagonal matrix and the -*> multipliers of the transformations used to obtain it, -*> stored as a 2-D triangular matrix. -*> Unchanged on exit. +*> If IPIV(k) = IPIV(k-1) < 0, then rows and +*> columns k-1 and -IPIV(k) were interchanged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. *> -*> LDA - INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling ( sub ) program. LDA must be at least -*> max( 1, N ). -*> Unchanged on exit. +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> (If IPIV( k ) = k, no interchange was done). *> -*> IPIV - INTEGER array, dimension( N ) -*> On entry, IPIV contains the vector of pivot indices as -*> determined by CSYTRF or CHETRF. -*> If IPIV( K ) = K, no interchange was done. -*> If IPIV( K ) <> K but IPIV( K ) > 0, then row K was inter- -*> changed with row IPIV( K ) and a 1 x 1 pivot block was used. -*> If IPIV( K ) < 0 and UPLO = 'U', then row K-1 was exchanged -*> with row | IPIV( K ) | and a 2 x 2 pivot block was used. -*> If IPIV( K ) < 0 and UPLO = 'L', then row K+1 was exchanged -*> with row | IPIV( K ) | and a 2 x 2 pivot block was used. +*> If IPIV(k) = IPIV(k+1) < 0, then rows and +*> columns k+1 and -IPIV(k) were interchanged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim *> -*> B - COMPLEX array, dimension( LDB, NRHS ) -*> On entry, B contains NRHS vectors of length N. -*> On exit, B is overwritten with the product A * B. +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension (LDB,NRHS) +*> On entry, B contains NRHS vectors of length N. +*> On exit, B is overwritten with the product A * B. +*> \endverbatim *> -*> LDB - INTEGER -*> On entry, LDB contains the leading dimension of B as -*> declared in the calling program. LDB must be at least -*> max( 1, N ). -*> Unchanged on exit. +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim *> -*> INFO - INTEGER -*> INFO is the error flag. -*> On exit, a value of 0 indicates a successful exit. -*> A negative value, say -K, indicates that the K-th argument -*> has an illegal value. +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex_lin * @@ -138,10 +153,10 @@ SUBROUTINE CLAVHE( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, $ LDB, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/clavhe_rook.f b/lapack-netlib/TESTING/LIN/clavhe_rook.f new file mode 100644 index 000000000..6fca41618 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/clavhe_rook.f @@ -0,0 +1,603 @@ +*> \brief \b CLAVHE_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CLAVHE_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, +* LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, TRANS, UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLAVHE_ROOK performs one of the matrix-vector operations +*> x := A*x or x := A^H*x, +*> where x is an N element vector and A is one of the factors +*> from the block U*D*U' or L*D*L' factorization computed by CHETRF_ROOK. +*> +*> If TRANS = 'N', multiplies by U or U * D (or L or L * D) +*> If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L') +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the factor stored in A is upper or lower +*> triangular. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> Specifies the operation to be performed: +*> = 'N': x := A*x +*> = 'C': x := A^H*x +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> Specifies whether or not the diagonal blocks are unit +*> matrices. If the diagonal blocks are assumed to be unit, +*> then A = U or A = L, otherwise A = U*D or A = L*D. +*> = 'U': Diagonal blocks are assumed to be unit matrices. +*> = 'N': Diagonal blocks are assumed to be non-unit matrices. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of vectors +*> x to be multiplied by A. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by CHETRF_ROOK. +*> Stored as a 2-D triangular matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, +*> as determined by CHETRF_ROOK. +*> If UPLO = 'U': +*> Only the last KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> Only the first KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension (LDB,NRHS) +*> On entry, B contains NRHS vectors of length N. +*> On exit, B is overwritten with the product A * B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CLAVHE_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, + $ B, LDB, INFO ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER DIAG, TRANS, UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX CONE + PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL NOUNIT + INTEGER J, K, KP + COMPLEX D11, D12, D21, D22, T1, T2 +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CGEMV, CGERU, CLACGV, CSCAL, CSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, CONJG, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) + $ THEN + INFO = -2 + ELSE IF( .NOT.LSAME( DIAG, 'U' ) .AND. .NOT.LSAME( DIAG, 'N' ) ) + $ THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CLAVHE_ROOK ', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* + NOUNIT = LSAME( DIAG, 'N' ) +*------------------------------------------ +* +* Compute B := A * B (No transpose) +* +*------------------------------------------ + IF( LSAME( TRANS, 'N' ) ) THEN +* +* Compute B := U*B +* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Loop forward applying the transformations. +* + K = 1 + 10 CONTINUE + IF( K.GT.N ) + $ GO TO 30 + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 pivot block +* +* Multiply by the diagonal element if forming U * D. +* + IF( NOUNIT ) + $ CALL CSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) +* +* Multiply by P(K) * inv(U(K)) if K > 1. +* + IF( K.GT.1 ) THEN +* +* Apply the transformation. +* + CALL CGERU( K-1, NRHS, CONE, A( 1, K ), 1, B( K, 1 ), + $ LDB, B( 1, 1 ), LDB ) +* +* Interchange if P(K) != I. +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + K = K + 1 + ELSE +* +* 2 x 2 pivot block +* +* Multiply by the diagonal block if forming U * D. +* + IF( NOUNIT ) THEN + D11 = A( K, K ) + D22 = A( K+1, K+1 ) + D12 = A( K, K+1 ) + D21 = CONJG( D12 ) + DO 20 J = 1, NRHS + T1 = B( K, J ) + T2 = B( K+1, J ) + B( K, J ) = D11*T1 + D12*T2 + B( K+1, J ) = D21*T1 + D22*T2 + 20 CONTINUE + END IF +* +* Multiply by P(K) * inv(U(K)) if K > 1. +* + IF( K.GT.1 ) THEN +* +* Apply the transformations. +* + CALL CGERU( K-1, NRHS, CONE, A( 1, K ), 1, B( K, 1 ), + $ LDB, B( 1, 1 ), LDB ) + CALL CGERU( K-1, NRHS, CONE, A( 1, K+1 ), 1, + $ B( K+1, 1 ), LDB, B( 1, 1 ), LDB ) +* +* Interchange if a permutation was applied at the +* K-th step of the factorization. +* +* Swap the first of pair with IMAXth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* NOW swap the first of pair with Pth +* + KP = ABS( IPIV( K+1 ) ) + IF( KP.NE.K+1 ) + $ CALL CSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), + $ LDB ) + END IF + K = K + 2 + END IF + GO TO 10 + 30 CONTINUE +* +* Compute B := L*B +* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . +* + ELSE +* +* Loop backward applying the transformations to B. +* + K = N + 40 CONTINUE + IF( K.LT.1 ) + $ GO TO 60 +* +* Test the pivot index. If greater than zero, a 1 x 1 +* pivot was used, otherwise a 2 x 2 pivot was used. +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 pivot block: +* +* Multiply by the diagonal element if forming L * D. +* + IF( NOUNIT ) + $ CALL CSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) +* +* Multiply by P(K) * inv(L(K)) if K < N. +* + IF( K.NE.N ) THEN + KP = IPIV( K ) +* +* Apply the transformation. +* + CALL CGERU( N-K, NRHS, CONE, A( K+1, K ), 1, + $ B( K, 1 ), LDB, B( K+1, 1 ), LDB ) +* +* Interchange if a permutation was applied at the +* K-th step of the factorization. +* + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + K = K - 1 +* + ELSE +* +* 2 x 2 pivot block: +* +* Multiply by the diagonal block if forming L * D. +* + IF( NOUNIT ) THEN + D11 = A( K-1, K-1 ) + D22 = A( K, K ) + D21 = A( K, K-1 ) + D12 = CONJG( D21 ) + DO 50 J = 1, NRHS + T1 = B( K-1, J ) + T2 = B( K, J ) + B( K-1, J ) = D11*T1 + D12*T2 + B( K, J ) = D21*T1 + D22*T2 + 50 CONTINUE + END IF +* +* Multiply by P(K) * inv(L(K)) if K < N. +* + IF( K.NE.N ) THEN +* +* Apply the transformation. +* + CALL CGERU( N-K, NRHS, CONE, A( K+1, K ), 1, + $ B( K, 1 ), LDB, B( K+1, 1 ), LDB ) + CALL CGERU( N-K, NRHS, CONE, A( K+1, K-1 ), 1, + $ B( K-1, 1 ), LDB, B( K+1, 1 ), LDB ) +* +* Interchange if a permutation was applied at the +* K-th step of the factorization. +* +* +* Swap the second of pair with IMAXth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* NOW swap the first of pair with Pth +* + KP = ABS( IPIV( K-1 ) ) + IF( KP.NE.K-1 ) + $ CALL CSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), + $ LDB ) +* + END IF + K = K - 2 + END IF + GO TO 40 + 60 CONTINUE + END IF +*-------------------------------------------------- +* +* Compute B := A^H * B (conjugate transpose) +* +*-------------------------------------------------- + ELSE +* +* Form B := U^H*B +* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) +* and U^H = inv(U^H(1))*P(1)* ... *inv(U^H(m))*P(m) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Loop backward applying the transformations. +* + K = N + 70 IF( K.LT.1 ) + $ GO TO 90 +* +* 1 x 1 pivot block. +* + IF( IPIV( K ).GT.0 ) THEN + IF( K.GT.1 ) THEN +* +* Interchange if P(K) != I. +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Apply the transformation +* y = y - B' conjg(x), +* where x is a column of A and y is a row of B. +* + CALL CLACGV( NRHS, B( K, 1 ), LDB ) + CALL CGEMV( 'Conjugate', K-1, NRHS, CONE, B, LDB, + $ A( 1, K ), 1, CONE, B( K, 1 ), LDB ) + CALL CLACGV( NRHS, B( K, 1 ), LDB ) + END IF + IF( NOUNIT ) + $ CALL CSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) + K = K - 1 +* +* 2 x 2 pivot block. +* + ELSE + IF( K.GT.2 ) THEN +* +* Swap the second of pair with Pth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Now swap the first of pair with IMAX(r)th +* + KP = ABS( IPIV( K-1 ) ) + IF( KP.NE.K-1 ) + $ CALL CSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), + $ LDB ) +* +* Apply the transformations +* y = y - B' conjg(x), +* where x is a block column of A and y is a block +* row of B. +* + CALL CLACGV( NRHS, B( K, 1 ), LDB ) + CALL CGEMV( 'Conjugate', K-2, NRHS, CONE, B, LDB, + $ A( 1, K ), 1, CONE, B( K, 1 ), LDB ) + CALL CLACGV( NRHS, B( K, 1 ), LDB ) +* + CALL CLACGV( NRHS, B( K-1, 1 ), LDB ) + CALL CGEMV( 'Conjugate', K-2, NRHS, CONE, B, LDB, + $ A( 1, K-1 ), 1, CONE, B( K-1, 1 ), LDB ) + CALL CLACGV( NRHS, B( K-1, 1 ), LDB ) + END IF +* +* Multiply by the diagonal block if non-unit. +* + IF( NOUNIT ) THEN + D11 = A( K-1, K-1 ) + D22 = A( K, K ) + D12 = A( K-1, K ) + D21 = CONJG( D12 ) + DO 80 J = 1, NRHS + T1 = B( K-1, J ) + T2 = B( K, J ) + B( K-1, J ) = D11*T1 + D12*T2 + B( K, J ) = D21*T1 + D22*T2 + 80 CONTINUE + END IF + K = K - 2 + END IF + GO TO 70 + 90 CONTINUE +* +* Form B := L^H*B +* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) +* and L^H = inv(L^H(m))*P(m)* ... *inv(L^H(1))*P(1) +* + ELSE +* +* Loop forward applying the L-transformations. +* + K = 1 + 100 CONTINUE + IF( K.GT.N ) + $ GO TO 120 +* +* 1 x 1 pivot block +* + IF( IPIV( K ).GT.0 ) THEN + IF( K.LT.N ) THEN +* +* Interchange if P(K) != I. +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Apply the transformation +* + CALL CLACGV( NRHS, B( K, 1 ), LDB ) + CALL CGEMV( 'Conjugate', N-K, NRHS, CONE, B( K+1, 1 ), + $ LDB, A( K+1, K ), 1, CONE, B( K, 1 ), LDB ) + CALL CLACGV( NRHS, B( K, 1 ), LDB ) + END IF + IF( NOUNIT ) + $ CALL CSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) + K = K + 1 +* +* 2 x 2 pivot block. +* + ELSE + IF( K.LT.N-1 ) THEN +* +* Swap the first of pair with Pth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Now swap the second of pair with IMAX(r)th +* + KP = ABS( IPIV( K+1 ) ) + IF( KP.NE.K+1 ) + $ CALL CSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), + $ LDB ) +* +* Apply the transformation +* + CALL CLACGV( NRHS, B( K+1, 1 ), LDB ) + CALL CGEMV( 'Conjugate', N-K-1, NRHS, CONE, + $ B( K+2, 1 ), LDB, A( K+2, K+1 ), 1, CONE, + $ B( K+1, 1 ), LDB ) + CALL CLACGV( NRHS, B( K+1, 1 ), LDB ) +* + CALL CLACGV( NRHS, B( K, 1 ), LDB ) + CALL CGEMV( 'Conjugate', N-K-1, NRHS, CONE, + $ B( K+2, 1 ), LDB, A( K+2, K ), 1, CONE, + $ B( K, 1 ), LDB ) + CALL CLACGV( NRHS, B( K, 1 ), LDB ) + END IF +* +* Multiply by the diagonal block if non-unit. +* + IF( NOUNIT ) THEN + D11 = A( K, K ) + D22 = A( K+1, K+1 ) + D21 = A( K+1, K ) + D12 = CONJG( D21 ) + DO 110 J = 1, NRHS + T1 = B( K, J ) + T2 = B( K+1, J ) + B( K, J ) = D11*T1 + D12*T2 + B( K+1, J ) = D21*T1 + D22*T2 + 110 CONTINUE + END IF + K = K + 2 + END IF + GO TO 100 + 120 CONTINUE + END IF +* + END IF + RETURN +* +* End of CLAVHE_ROOK +* + END diff --git a/lapack-netlib/TESTING/LIN/clavsy.f b/lapack-netlib/TESTING/LIN/clavsy.f index 5dabb333c..c4d885cc0 100644 --- a/lapack-netlib/TESTING/LIN/clavsy.f +++ b/lapack-netlib/TESTING/LIN/clavsy.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CLAVSY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, * LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -19,14 +19,14 @@ * INTEGER IPIV( * ) * COMPLEX A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> CLAVSY performs one of the matrix-vector operations +*> CLAVSY performs one of the matrix-vector operations *> x := A*x or x := A'*x, *> where x is an N element vector and A is one of the factors *> from the block U*D*U' or L*D*L' factorization computed by CSYTRF. @@ -83,6 +83,7 @@ *> A is COMPLEX array, dimension (LDA,N) *> The block diagonal matrix D and the multipliers used to *> obtain the factor U or L as computed by CSYTRF. +*> Stored as a 2-D triangular matrix. *> \endverbatim *> *> \param[in] LDA @@ -95,7 +96,7 @@ *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D, -*> as determined by CSYTRF or CHETRF. +*> as determined by CSYTRF. *> *> If UPLO = 'U': *> If IPIV(k) > 0, then rows and columns k and IPIV(k) @@ -139,12 +140,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup complex_lin * @@ -152,10 +153,10 @@ SUBROUTINE CLAVSY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, $ LDB, INFO ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/clavsy_rook.f b/lapack-netlib/TESTING/LIN/clavsy_rook.f new file mode 100644 index 000000000..73f6e9acc --- /dev/null +++ b/lapack-netlib/TESTING/LIN/clavsy_rook.f @@ -0,0 +1,580 @@ +*> \brief \b CLAVSY_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CLAVSY_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, +* LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, TRANS, UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLAVSY_ROOK performs one of the matrix-vector operations +*> x := A*x or x := A'*x, +*> where x is an N element vector and A is one of the factors +*> from the block U*D*U' or L*D*L' factorization computed by CSYTRF_ROOK. +*> +*> If TRANS = 'N', multiplies by U or U * D (or L or L * D) +*> If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L') +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the factor stored in A is upper or lower +*> triangular. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> Specifies the operation to be performed: +*> = 'N': x := A*x +*> = 'T': x := A'*x +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> Specifies whether or not the diagonal blocks are unit +*> matrices. If the diagonal blocks are assumed to be unit, +*> then A = U or A = L, otherwise A = U*D or A = L*D. +*> = 'U': Diagonal blocks are assumed to be unit matrices. +*> = 'N': Diagonal blocks are assumed to be non-unit matrices. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of vectors +*> x to be multiplied by A. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by CSYTRF_ROOK. +*> Stored as a 2-D triangular matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, +*> as determined by CSYTRF_ROOK. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> (If IPIV( k ) = k, no interchange was done). +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> (If IPIV( k ) = k, no interchange was done). +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension (LDB,NRHS) +*> On entry, B contains NRHS vectors of length N. +*> On exit, B is overwritten with the product A * B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CLAVSY_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, + $ B, LDB, INFO ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER DIAG, TRANS, UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX CONE + PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL NOUNIT + INTEGER J, K, KP + COMPLEX D11, D12, D21, D22, T1, T2 +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CGEMV, CGERU, CSCAL, CSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) ) + $ THEN + INFO = -2 + ELSE IF( .NOT.LSAME( DIAG, 'U' ) .AND. .NOT.LSAME( DIAG, 'N' ) ) + $ THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CLAVSY_ROOK ', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* + NOUNIT = LSAME( DIAG, 'N' ) +*------------------------------------------ +* +* Compute B := A * B (No transpose) +* +*------------------------------------------ + IF( LSAME( TRANS, 'N' ) ) THEN +* +* Compute B := U*B +* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Loop forward applying the transformations. +* + K = 1 + 10 CONTINUE + IF( K.GT.N ) + $ GO TO 30 + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 pivot block +* +* Multiply by the diagonal element if forming U * D. +* + IF( NOUNIT ) + $ CALL CSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) +* +* Multiply by P(K) * inv(U(K)) if K > 1. +* + IF( K.GT.1 ) THEN +* +* Apply the transformation. +* + CALL CGERU( K-1, NRHS, CONE, A( 1, K ), 1, B( K, 1 ), + $ LDB, B( 1, 1 ), LDB ) +* +* Interchange if P(K) != I. +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + K = K + 1 + ELSE +* +* 2 x 2 pivot block +* +* Multiply by the diagonal block if forming U * D. +* + IF( NOUNIT ) THEN + D11 = A( K, K ) + D22 = A( K+1, K+1 ) + D12 = A( K, K+1 ) + D21 = D12 + DO 20 J = 1, NRHS + T1 = B( K, J ) + T2 = B( K+1, J ) + B( K, J ) = D11*T1 + D12*T2 + B( K+1, J ) = D21*T1 + D22*T2 + 20 CONTINUE + END IF +* +* Multiply by P(K) * inv(U(K)) if K > 1. +* + IF( K.GT.1 ) THEN +* +* Apply the transformations. +* + CALL CGERU( K-1, NRHS, CONE, A( 1, K ), 1, B( K, 1 ), + $ LDB, B( 1, 1 ), LDB ) + CALL CGERU( K-1, NRHS, CONE, A( 1, K+1 ), 1, + $ B( K+1, 1 ), LDB, B( 1, 1 ), LDB ) +* +* Interchange if a permutation was applied at the +* K-th step of the factorization. +* +* Swap the first of pair with IMAXth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* NOW swap the first of pair with Pth +* + KP = ABS( IPIV( K+1 ) ) + IF( KP.NE.K+1 ) + $ CALL CSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), + $ LDB ) + END IF + K = K + 2 + END IF + GO TO 10 + 30 CONTINUE +* +* Compute B := L*B +* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . +* + ELSE +* +* Loop backward applying the transformations to B. +* + K = N + 40 CONTINUE + IF( K.LT.1 ) + $ GO TO 60 +* +* Test the pivot index. If greater than zero, a 1 x 1 +* pivot was used, otherwise a 2 x 2 pivot was used. +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 pivot block: +* +* Multiply by the diagonal element if forming L * D. +* + IF( NOUNIT ) + $ CALL CSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) +* +* Multiply by P(K) * inv(L(K)) if K < N. +* + IF( K.NE.N ) THEN + KP = IPIV( K ) +* +* Apply the transformation. +* + CALL CGERU( N-K, NRHS, CONE, A( K+1, K ), 1, + $ B( K, 1 ), LDB, B( K+1, 1 ), LDB ) +* +* Interchange if a permutation was applied at the +* K-th step of the factorization. +* + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + K = K - 1 +* + ELSE +* +* 2 x 2 pivot block: +* +* Multiply by the diagonal block if forming L * D. +* + IF( NOUNIT ) THEN + D11 = A( K-1, K-1 ) + D22 = A( K, K ) + D21 = A( K, K-1 ) + D12 = D21 + DO 50 J = 1, NRHS + T1 = B( K-1, J ) + T2 = B( K, J ) + B( K-1, J ) = D11*T1 + D12*T2 + B( K, J ) = D21*T1 + D22*T2 + 50 CONTINUE + END IF +* +* Multiply by P(K) * inv(L(K)) if K < N. +* + IF( K.NE.N ) THEN +* +* Apply the transformation. +* + CALL CGERU( N-K, NRHS, CONE, A( K+1, K ), 1, + $ B( K, 1 ), LDB, B( K+1, 1 ), LDB ) + CALL CGERU( N-K, NRHS, CONE, A( K+1, K-1 ), 1, + $ B( K-1, 1 ), LDB, B( K+1, 1 ), LDB ) +* +* Interchange if a permutation was applied at the +* K-th step of the factorization. +* +* Swap the second of pair with IMAXth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* NOW swap the first of pair with Pth +* + KP = ABS( IPIV( K-1 ) ) + IF( KP.NE.K-1 ) + $ CALL CSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), + $ LDB ) + END IF + K = K - 2 + END IF + GO TO 40 + 60 CONTINUE + END IF +*---------------------------------------- +* +* Compute B := A' * B (transpose) +* +*---------------------------------------- + ELSE IF( LSAME( TRANS, 'T' ) ) THEN +* +* Form B := U'*B +* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) +* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Loop backward applying the transformations. +* + K = N + 70 IF( K.LT.1 ) + $ GO TO 90 +* +* 1 x 1 pivot block. +* + IF( IPIV( K ).GT.0 ) THEN + IF( K.GT.1 ) THEN +* +* Interchange if P(K) != I. +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Apply the transformation +* + CALL CGEMV( 'Transpose', K-1, NRHS, CONE, B, LDB, + $ A( 1, K ), 1, CONE, B( K, 1 ), LDB ) + END IF + IF( NOUNIT ) + $ CALL CSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) + K = K - 1 +* +* 2 x 2 pivot block. +* + ELSE + IF( K.GT.2 ) THEN +* +* Swap the second of pair with Pth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Now swap the first of pair with IMAX(r)th +* + KP = ABS( IPIV( K-1 ) ) + IF( KP.NE.K-1 ) + $ CALL CSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), + $ LDB ) +* +* Apply the transformations +* + CALL CGEMV( 'Transpose', K-2, NRHS, CONE, B, LDB, + $ A( 1, K ), 1, CONE, B( K, 1 ), LDB ) + CALL CGEMV( 'Transpose', K-2, NRHS, CONE, B, LDB, + $ A( 1, K-1 ), 1, CONE, B( K-1, 1 ), LDB ) + END IF +* +* Multiply by the diagonal block if non-unit. +* + IF( NOUNIT ) THEN + D11 = A( K-1, K-1 ) + D22 = A( K, K ) + D12 = A( K-1, K ) + D21 = D12 + DO 80 J = 1, NRHS + T1 = B( K-1, J ) + T2 = B( K, J ) + B( K-1, J ) = D11*T1 + D12*T2 + B( K, J ) = D21*T1 + D22*T2 + 80 CONTINUE + END IF + K = K - 2 + END IF + GO TO 70 + 90 CONTINUE +* +* Form B := L'*B +* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) +* and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1) +* + ELSE +* +* Loop forward applying the L-transformations. +* + K = 1 + 100 CONTINUE + IF( K.GT.N ) + $ GO TO 120 +* +* 1 x 1 pivot block +* + IF( IPIV( K ).GT.0 ) THEN + IF( K.LT.N ) THEN +* +* Interchange if P(K) != I. +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Apply the transformation +* + CALL CGEMV( 'Transpose', N-K, NRHS, CONE, B( K+1, 1 ), + $ LDB, A( K+1, K ), 1, CONE, B( K, 1 ), LDB ) + END IF + IF( NOUNIT ) + $ CALL CSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) + K = K + 1 +* +* 2 x 2 pivot block. +* + ELSE + IF( K.LT.N-1 ) THEN +* +* Swap the first of pair with Pth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Now swap the second of pair with IMAX(r)th +* + KP = ABS( IPIV( K+1 ) ) + IF( KP.NE.K+1 ) + $ CALL CSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), + $ LDB ) +* +* Apply the transformation +* + CALL CGEMV( 'Transpose', N-K-1, NRHS, CONE, + $ B( K+2, 1 ), LDB, A( K+2, K+1 ), 1, CONE, + $ B( K+1, 1 ), LDB ) + CALL CGEMV( 'Transpose', N-K-1, NRHS, CONE, + $ B( K+2, 1 ), LDB, A( K+2, K ), 1, CONE, + $ B( K, 1 ), LDB ) + END IF +* +* Multiply by the diagonal block if non-unit. +* + IF( NOUNIT ) THEN + D11 = A( K, K ) + D22 = A( K+1, K+1 ) + D21 = A( K+1, K ) + D12 = D21 + DO 110 J = 1, NRHS + T1 = B( K, J ) + T2 = B( K+1, J ) + B( K, J ) = D11*T1 + D12*T2 + B( K+1, J ) = D21*T1 + D22*T2 + 110 CONTINUE + END IF + K = K + 2 + END IF + GO TO 100 + 120 CONTINUE + END IF + END IF + RETURN +* +* End of CLAVSY_ROOK +* + END diff --git a/lapack-netlib/TESTING/LIN/csyt01.f b/lapack-netlib/TESTING/LIN/csyt01.f index 31acf4687..ff068b2d1 100644 --- a/lapack-netlib/TESTING/LIN/csyt01.f +++ b/lapack-netlib/TESTING/LIN/csyt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE CSYT01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDAFAC, LDC, N @@ -21,7 +21,7 @@ * REAL RWORK( * ) * COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup complex_lin * @@ -125,10 +125,10 @@ SUBROUTINE CSYT01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/csyt01_rook.f b/lapack-netlib/TESTING/LIN/csyt01_rook.f new file mode 100644 index 000000000..cea6f5e8b --- /dev/null +++ b/lapack-netlib/TESTING/LIN/csyt01_rook.f @@ -0,0 +1,227 @@ +*> \brief \b CSYT01_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, +* RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* REAL RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL RWORK( * ) +* COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSYT01_ROOK reconstructs a complex symmetric indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix, EPS is the machine epsilon, +*> L' is the transpose of L, and U' is the transpose of U. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> complex symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> The original complex symmetric matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is COMPLEX array, dimension (LDAFAC,N) +*> The factored form of the matrix A. AFAC contains the block +*> diagonal matrix D and the multipliers used to obtain the +*> factor L or U from the block L*D*L' or U*D*U' factorization +*> as computed by CSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from CSYTRF_ROOK. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is COMPLEX array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is REAL +*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) +*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + REAL RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL RWORK( * ) + COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + REAL ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + REAL CLANSY, SLAMCH + EXTERNAL LSAME, CLANSY, SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL CLASET, CLAVSY_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* Determine EPS and the norm of A. +* + EPS = SLAMCH( 'Epsilon' ) + ANORM = CLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Initialize C to the identity matrix. +* + CALL CLASET( 'Full', N, N, CZERO, CONE, C, LDC ) +* +* Call CLAVSY_ROOK to form the product D * U' (or D * L' ). +* + CALL CLAVSY_ROOK( UPLO, 'Transpose', 'Non-unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* Call CLAVSY_ROOK again to multiply by U (or L ). +* + CALL CLAVSY_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF +* +* Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = CLANSY( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID/REAL( N ) )/ANORM ) / EPS + END IF +* + RETURN +* +* End of CSYT01_ROOK +* + END diff --git a/lapack-netlib/TESTING/LIN/dchkaa.f b/lapack-netlib/TESTING/LIN/dchkaa.f index e90897d50..e256d84f9 100644 --- a/lapack-netlib/TESTING/LIN/dchkaa.f +++ b/lapack-netlib/TESTING/LIN/dchkaa.f @@ -158,9 +158,9 @@ EXTERNAL ALAREQ, DCHKEQ, DCHKGB, DCHKGE, DCHKGT, DCHKLQ, $ DCHKPB, DCHKPO, DCHKPS, DCHKPP, DCHKPT, DCHKQ3, $ DCHKQL, DCHKQP, DCHKQR, DCHKRQ, DCHKSP, DCHKSY, - $ DCHKTB, DCHKTP, DCHKTR, DCHKTZ, + $ DCHKSY_ROOK, DCHKTB, DCHKTP, DCHKTR, DCHKTZ, $ DDRVGB, DDRVGE, DDRVGT, DDRVLS, DDRVPB, DDRVPO, - $ DDRVPP, DDRVPT, DDRVSP, DDRVSY, + $ DDRVPP, DDRVPT, DDRVSP, DDRVSY, DDRVSY_ROOK, $ ILAVER, DCHKQRT, DCHKQRTP * .. * .. Scalars in Common .. @@ -637,6 +637,32 @@ ELSE WRITE( NOUT, FMT = 9988 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN +* +* SR: symmetric indefinite matrices with Rook pivoting, +* with rook (bounded Bunch-Kaufman) pivoting algorithm +* + NTYPES = 10 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL DCHKSY_ROOK(DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), + $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL DDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/dchksy.f b/lapack-netlib/TESTING/LIN/dchksy.f index 3295f1357..d8981f735 100644 --- a/lapack-netlib/TESTING/LIN/dchksy.f +++ b/lapack-netlib/TESTING/LIN/dchksy.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, * XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNB, NNS, NOUT @@ -23,7 +23,7 @@ * DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), * $ RWORK( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -134,14 +134,12 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is DOUBLE PRECISION array, dimension -*> (NMAX*max(3,NSMAX)) +*> WORK is DOUBLE PRECISION array, dimension (NMAX*max(3,NSMAX)) *> \endverbatim *> *> \param[out] RWORK *> \verbatim -*> RWORK is DOUBLE PRECISION array, dimension -*> (max(NMAX,2*NSMAX)) +*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX)) *> \endverbatim *> *> \param[out] IWORK @@ -158,12 +156,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup double_lin * @@ -172,10 +170,10 @@ $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, $ XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -220,7 +218,7 @@ * .. External Subroutines .. EXTERNAL ALAERH, ALAHD, ALASUM, DERRSY, DGET04, DLACPY, $ DLARHS, DLATB4, DLATMS, DPOT02, DPOT03, DPOT05, - $ DSYCON, DSYRFS, DSYT01, DSYTRF, + $ DSYCON, DSYRFS, DSYT01, DSYTRF, $ DSYTRI2, DSYTRS, DSYTRS2, XLAENV * .. * .. Intrinsic Functions .. @@ -297,6 +295,7 @@ * * Begin generate the test matrix A. * +* * Set up parameters with DLATB4 for the matrix generator * based on the type of matrix to be generated. * @@ -315,6 +314,9 @@ IF( INFO.NE.0 ) THEN CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1, $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* GO TO 160 END IF * @@ -357,11 +359,11 @@ 50 CONTINUE END IF ELSE - IOFF = 0 IF( IUPLO.EQ.1 ) THEN * * Set the first IZERO rows and columns to zero. * + IOFF = 0 DO 70 J = 1, N I2 = MIN( J, IZERO ) DO 60 I = 1, I2 @@ -373,6 +375,7 @@ * * Set the last IZERO rows and columns to zero. * + IOFF = 0 DO 90 J = 1, N I1 = MAX( J, IZERO ) DO 80 I = I1, N @@ -506,6 +509,8 @@ RCONDC = ZERO GO TO 140 END IF +* +* Do for each value of NRHS in NSVAL. * DO 130 IRHS = 1, NNS NRHS = NSVAL( IRHS ) @@ -586,7 +591,7 @@ $ RWORK( NRHS+1 ), WORK, IWORK( N+1 ), $ INFO ) * -* Check error code from DSYRFS. +* Check error code from DSYRFS and handle error. * IF( INFO.NE.0 ) $ CALL ALAERH( PATH, 'DSYRFS', INFO, 0, UPLO, N, @@ -612,6 +617,9 @@ END IF 120 CONTINUE NRUN = NRUN + 6 +* +* End do for each value of NRHS in NSVAL. +* 130 CONTINUE * *+ TEST 9 @@ -629,7 +637,7 @@ $ CALL ALAERH( PATH, 'DSYCON', INFO, 0, UPLO, N, N, $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) * -* Compute the test ratio to compare to values of RCOND +* Compute the test ratio to compare values of RCOND * RESULT( 9 ) = DGET06( RCOND, RCONDC ) * diff --git a/lapack-netlib/TESTING/LIN/dchksy_rook.f b/lapack-netlib/TESTING/LIN/dchksy_rook.f new file mode 100644 index 000000000..e7cea27f7 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/dchksy_rook.f @@ -0,0 +1,830 @@ +*> \brief \b DCHKSY_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, +* XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), +* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DCHKSY_ROOK tests DSYTRF_ROOK, -TRI_ROOK, -TRS_ROOK, +*> and -CON_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is 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. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is DOUBLE PRECISION array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX)) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, + $ XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NNB, NNS, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), + $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 10 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) +* .. +* .. Local Scalars .. + LOGICAL TRFCON, ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ ITEMP, IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, + $ MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, + $ NT + DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, DTEMP, LAM_MAX, + $ LAM_MIN, RCOND, RCONDC +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER IDUMMY( 1 ), ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION DDUMMY( 1 ), RESULT( NTESTS ) +* .. +* .. External Functions .. + DOUBLE PRECISION DGET06, DLANGE, DLANSY + EXTERNAL DGET06, DLANGE, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, DERRSY, DGET04, DLACPY, + $ DLARHS, DLATB4, DLATMS, DPOT02, DPOT03, DSYEVX, + $ DSYCON_ROOK, DSYT01_ROOK, DSYTRF_ROOK, + $ DSYTRI_ROOK, DSYTRS_ROOK, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Test path +* + PATH( 1: 1 ) = 'Double precision' + PATH( 2: 3 ) = 'SR' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Double precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL DERRSY( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 270 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 260 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 260 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 260 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 250 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with DLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL DLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with DLATMS. +* + SRNAMT = 'DLATMS' + CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from DLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 250 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* +* Do for each value of NB in NBVAL +* + DO 240 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'DSYTRF_ROOK' + CALL DSYTRF_ROOK( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from DSYTRF_ROOK and handle error. +* + IF( INFO.NE.K) + $ CALL ALAERH( PATH, 'DSYTRF_ROOK', INFO, K, + $ UPLO, N, N, -1, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Set the condition estimate flag if the INFO is not 0. +* + IF( INFO.NE.0 ) THEN + TRFCON = .TRUE. + ELSE + TRFCON = .FALSE. + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL DSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +*+ TEST 2 +* Form the inverse and compute the residual, +* if the factorization was competed without INFO > 0 +* (i.e. there is no zero rows and columns). +* Do it only for the first block size. +* + IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN + CALL DLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + SRNAMT = 'DSYTRI_ROOK' + CALL DSYTRI_ROOK( UPLO, N, AINV, LDA, IWORK, WORK, + $ INFO ) +* +* Check error code from DSYTRI_ROOK and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'DSYTRI_ROOK', INFO, -1, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the residual for a symmetric matrix times +* its inverse. +* + CALL DPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, + $ RWORK, RCONDC, RESULT( 2 ) ) + NT = 2 + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +*+ TEST 3 +* Compute largest element in U or L +* + RESULT( 3 ) = ZERO + DTEMP = ZERO +* + CONST = ONE / ( ONE-ALPHA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Compute largest element in U +* + K = N + 120 CONTINUE + IF( K.LE.1 ) + $ GO TO 130 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in U +* + DTEMP = DLANGE( 'M', K-1, 1, + $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k-1 in U +* + DTEMP = DLANGE( 'M', K-2, 2, + $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK ) + K = K - 1 +* + END IF +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = DTEMP +* + K = K - 1 +* + GO TO 120 + 130 CONTINUE +* + ELSE +* +* Compute largest element in L +* + K = 1 + 140 CONTINUE + IF( K.GE.N ) + $ GO TO 150 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in L +* + DTEMP = DLANGE( 'M', N-K, 1, + $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k+1 in L +* + DTEMP = DLANGE( 'M', N-K-1, 2, + $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK ) + K = K + 1 +* + END IF +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = DTEMP +* + K = K + 1 +* + GO TO 140 + 150 CONTINUE + END IF +* +* +*+ TEST 4 +* Compute largest 2-Norm of 2-by-2 diag blocks +* + RESULT( 4 ) = ZERO + DTEMP = ZERO +* + CONST = ( ONE+ALPHA ) / ( ONE-ALPHA ) + CALL DLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Loop backward for UPLO = 'U' +* + K = N + 160 CONTINUE + IF( K.LE.1 ) + $ GO TO 170 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two eigenvalues of a 2-by-2 block, +* store them in RWORK array +* + CALL DSYEVX( 'N', 'A', UPLO, 2, + $ AINV( ( K-2 )*LDA+K-1 ), LDA, DTEMP, + $ DTEMP, ITEMP, ITEMP, ZERO, ITEMP, + $ RWORK, DDUMMY, 1, WORK, 16, + $ IWORK( N+1 ), IDUMMY, INFO ) +* + LAM_MAX = MAX( ABS( RWORK( 1 ) ), + $ ABS( RWORK( 2 ) ) ) + LAM_MIN = MIN( ABS( RWORK( 1 ) ), + $ ABS( RWORK( 2 ) ) ) +* + DTEMP = LAM_MAX / LAM_MIN +* +* DTEMP should be bounded by CONST +* + DTEMP = ABS( DTEMP ) - CONST + THRESH + IF( DTEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = DTEMP + K = K - 1 +* + END IF +* + K = K - 1 +* + GO TO 160 + 170 CONTINUE +* + ELSE +* +* Loop forward for UPLO = 'L' +* + K = 1 + 180 CONTINUE + IF( K.GE.N ) + $ GO TO 190 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two eigenvalues of a 2-by-2 block, +* store them in RWORK array +* + CALL DSYEVX( 'N', 'A', UPLO, 2, + $ AINV( ( K-1 )*LDA+K ), LDA, DTEMP, + $ DTEMP, ITEMP, ITEMP, ZERO, ITEMP, + $ RWORK, DDUMMY, 1, WORK, 16, + $ IWORK( N+1 ), IDUMMY, INFO ) +* + LAM_MAX = MAX( ABS( RWORK( 1 ) ), + $ ABS( RWORK( 2 ) ) ) + LAM_MIN = MIN( ABS( RWORK( 1 ) ), + $ ABS( RWORK( 2 ) ) ) +* + DTEMP = LAM_MAX / LAM_MIN +* +* DTEMP should be bounded by CONST +* + DTEMP = ABS( DTEMP ) - CONST + THRESH + IF( DTEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = DTEMP + K = K + 1 +* + END IF +* + K = K + 1 +* + GO TO 180 + 190 CONTINUE + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 200 K = 3, 4 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 200 CONTINUE + NRUN = NRUN + 2 +* +* Skip the other tests if this is not the first block +* size. +* + IF( INB.GT.1 ) + $ GO TO 240 +* +* Do only the condition estimate if INFO is not 0. +* + IF( TRFCON ) THEN + RCONDC = ZERO + GO TO 230 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 220 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 5 ( Using TRS_ROOK) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'DLARHS' + CALL DLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'DSYTRS_ROOK' + CALL DSYTRS_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, INFO ) +* +* Check error code from DSYTRS_ROOK and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'DSYTRS_ROOK', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) +* + CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL DPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 5 ) ) +* +*+ TEST 6 +* Check solution from generated exact solution. +* + CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 6 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 210 K = 5, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 210 CONTINUE + NRUN = NRUN + 2 +* +* End do for each value of NRHS in NSVAL. +* + 220 CONTINUE +* +*+ TEST 7 +* Get an estimate of RCOND = 1/CNDNUM. +* + 230 CONTINUE + ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK ) + SRNAMT = 'DSYCON_ROOK' + CALL DSYCON_ROOK( UPLO, N, AFAC, LDA, IWORK, ANORM, + $ RCOND, WORK, IWORK( N+1 ), INFO ) +* +* Check error code from DSYCON_ROOK and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'DSYCON_ROOK', INFO, 0, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the test ratio to compare to values of RCOND +* + RESULT( 7 ) = DGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7, + $ RESULT( 7 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 240 CONTINUE +* + 250 CONTINUE + 260 CONTINUE + 270 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test(', I2, ') =', G12.5 ) + 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, + $ ', test(', I2, ') =', G12.5 ) + RETURN +* +* End of DCHKSY_ROOK +* + END diff --git a/lapack-netlib/TESTING/LIN/ddrvpox.f b/lapack-netlib/TESTING/LIN/ddrvpox.f index 5f1370ed7..a3ab10483 100644 --- a/lapack-netlib/TESTING/LIN/ddrvpox.f +++ b/lapack-netlib/TESTING/LIN/ddrvpox.f @@ -158,7 +158,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup double_lin * @@ -167,10 +167,10 @@ $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -529,11 +529,12 @@ * * Check the error code from DPOSVX. * - IF( INFO.NE.IZERO ) - $ CALL ALAERH( PATH, 'DPOSVX', INFO, IZERO, + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'DPOSVX', INFO, IZERO, $ FACT // UPLO, N, N, -1, -1, NRHS, $ IMAT, NFAIL, NERRS, NOUT ) GO TO 90 + END IF * IF( INFO.EQ.0 ) THEN IF( .NOT.PREFAC ) THEN diff --git a/lapack-netlib/TESTING/LIN/ddrvrfp.f b/lapack-netlib/TESTING/LIN/ddrvrfp.f index 033c033ba..5f44006b9 100644 --- a/lapack-netlib/TESTING/LIN/ddrvrfp.f +++ b/lapack-netlib/TESTING/LIN/ddrvrfp.f @@ -231,7 +231,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup double_lin * @@ -243,10 +243,10 @@ + D_TEMP_DPOT03, D_WORK_DLANSY, + D_WORK_DPOT02, D_WORK_DPOT03 ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. INTEGER NN, NNS, NNT, NOUT @@ -342,7 +342,7 @@ * * If N.EQ.0, only consider the first type * - IF( N.EQ.0 .AND. IIT.GT.1 ) GO TO 120 + IF( N.EQ.0 .AND. IIT.GE.1 ) GO TO 120 * * Skip types 3, 4, or 5 if the matrix size is too small. * @@ -442,16 +442,20 @@ * Form the inverse of A. * CALL DPOTRI( UPLO, N, A, LDA, INFO ) + + IF ( N .NE. 0 ) THEN + * -* Compute the 1-norm condition number of A. +* Compute the 1-norm condition number of A. * - AINVNM = DLANSY( '1', UPLO, N, A, LDA, + AINVNM = DLANSY( '1', UPLO, N, A, LDA, + D_WORK_DLANSY ) - RCONDC = ( ONE / ANORM ) / AINVNM + RCONDC = ( ONE / ANORM ) / AINVNM * -* Restore the matrix A. +* Restore the matrix A. * - CALL DLACPY( UPLO, N, N, ASAV, LDA, A, LDA ) + CALL DLACPY( UPLO, N, N, ASAV, LDA, A, LDA ) + END IF * END IF * diff --git a/lapack-netlib/TESTING/LIN/ddrvsy.f b/lapack-netlib/TESTING/LIN/ddrvsy.f index 7978ea0cc..ec94c4710 100644 --- a/lapack-netlib/TESTING/LIN/ddrvsy.f +++ b/lapack-netlib/TESTING/LIN/ddrvsy.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE DDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -23,7 +23,7 @@ * DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), * $ RWORK( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,8 +116,7 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is DOUBLE PRECISION array, dimension -*> (NMAX*max(2,NRHS)) +*> WORK is DOUBLE PRECISION array, dimension (NMAX*max(2,NRHS)) *> \endverbatim *> *> \param[out] RWORK @@ -139,12 +138,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup double_lin * @@ -153,10 +152,10 @@ $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/ddrvsy_rook.f b/lapack-netlib/TESTING/LIN/ddrvsy_rook.f new file mode 100644 index 000000000..670fc8cff --- /dev/null +++ b/lapack-netlib/TESTING/LIN/ddrvsy_rook.f @@ -0,0 +1,526 @@ +*> \brief \b DDRVSY_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, +* $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, +* $ RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), +* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DDRVSY_ROOK tests the driver routines DSYSV_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is 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. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is DOUBLE PRECISION array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (NMAX*max(2,NRHS)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NOUT, NRHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), + $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCONDC +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLANSY + EXTERNAL DLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, DGET04, DLACPY, + $ DLARHS, DLASET, DLATB4, DLATMS, DPOT02, DPOT05, + $ DSYSV_ROOK, DSYT01_ROOK, DSYTRF_ROOK, + $ DSYTRI_ROOK, + $ XLAENV +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Double precision' + PATH( 2: 3 ) = 'SR' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Double precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL DERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for which the block +* routine should be used, which will be later returned by ILAENV. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with DLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL DLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with DLATMS. +* + SRNAMT = 'DLATMS' + CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from DLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of the +* matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IOFF = 0 + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Compute the condition number for comparison with +* the value returned by DSYSVX_ROOK. +* + IF( ZEROT ) THEN + IF( IFACT.EQ.1 ) + $ GO TO 150 + RCONDC = ZERO +* + ELSE IF( IFACT.EQ.1 ) THEN +* +* Compute the 1-norm of A. +* + ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* + CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL DSYTRF_ROOK( UPLO, N, AFAC, LDA, IWORK, WORK, + $ LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* + CALL DLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + LWORK = (N+NB+1)*(NB+3) + CALL DSYTRI_ROOK( UPLO, N, AINV, LDA, IWORK, + $ WORK, INFO ) + AINVNM = DLANSY( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'DLARHS' + CALL DLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test DSYSV_ROOK --- +* + IF( IFACT.EQ.2 ) THEN + CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using +* DSYSV_ROOK. +* + SRNAMT = 'DSYSV_ROOK' + CALL DSYSV_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from DSYSV_ROOK and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'DSYSV_ROOK', INFO, K, UPLO, + $ N, N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +*+ TEST 1 Reconstruct matrix from factors and compute +* residual. +* + CALL DSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDA, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +*+ TEST 2 Compute residual of the computed solution. +* + CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL DPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +*+ TEST 3 +* Check solution from generated exact solution. +* + CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 3 ) ) + NT = 3 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'DSYSV_ROOK', UPLO, + $ N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of DDRVSY_ROOK +* + END diff --git a/lapack-netlib/TESTING/LIN/derrsy.f b/lapack-netlib/TESTING/LIN/derrsy.f index aa60e1bbc..48a17a717 100644 --- a/lapack-netlib/TESTING/LIN/derrsy.f +++ b/lapack-netlib/TESTING/LIN/derrsy.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -87,8 +87,9 @@ * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, DSPCON, DSPRFS, DSPTRF, DSPTRI, - $ DSPTRS, DSYCON, DSYRFS, DSYTF2, DSYTRF, DSYTRI, - $ DSYTRI2, DSYTRS + $ DSPTRS, DSYCON, DSYCON_ROOK, DSYRFS, DSYTF2, + $ DSYTF2_ROOK, DSYTRF, DSYTRF_ROOK, DSYTRI, + $ DSYTRI_ROOK, DSYTRI2, DSYTRS, DSYTRS_ROOK * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -251,6 +252,86 @@ INFOT = 6 CALL DSYCON( 'U', 1, A, 1, IP, -1.0D0, RCOND, W, IW, INFO ) CALL CHKXER( 'DSYCON', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting. +* +* DSYTRF_ROOK +* + SRNAMT = 'DSYTRF_ROOK' + INFOT = 1 + CALL DSYTRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) + CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK ) +* +* DSYTF2_ROOK +* + SRNAMT = 'DSYTF2_ROOK' + INFOT = 1 + CALL DSYTF2_ROOK( '/', 0, A, 1, IP, INFO ) + CALL CHKXER( 'DSYTF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTF2_ROOK( 'U', -1, A, 1, IP, INFO ) + CALL CHKXER( 'DSYTF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTF2_ROOK( 'U', 2, A, 1, IP, INFO ) + CALL CHKXER( 'DSYTF2_ROOK', INFOT, NOUT, LERR, OK ) +* +* DSYTRI_ROOK +* + SRNAMT = 'DSYTRI_ROOK' + INFOT = 1 + CALL DSYTRI_ROOK( '/', 0, A, 1, IP, W, INFO ) + CALL CHKXER( 'DSYTRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRI_ROOK( 'U', -1, A, 1, IP, W, INFO ) + CALL CHKXER( 'DSYTRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRI_ROOK( 'U', 2, A, 1, IP, W, INFO ) + CALL CHKXER( 'DSYTRI_ROOK', INFOT, NOUT, LERR, OK ) +* +* DSYTRS_ROOK +* + SRNAMT = 'DSYTRS_ROOK' + INFOT = 1 + CALL DSYTRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYTRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYTRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO ) + CALL CHKXER( 'DSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYTRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_ROOK', INFOT, NOUT, LERR, OK ) +* +* DSYCON_ROOK +* + SRNAMT = 'DSYCON_ROOK' + INFOT = 1 + CALL DSYCON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'DSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYCON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'DSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYCON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'DSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DSYCON_ROOK( 'U', 1, A, 1, IP, -1.0D0, RCOND, W, IW, INFO) + CALL CHKXER( 'DSYCON_ROOK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/derrsyx.f b/lapack-netlib/TESTING/LIN/derrsyx.f index d94c02fb8..b6d300bf0 100644 --- a/lapack-netlib/TESTING/LIN/derrsyx.f +++ b/lapack-netlib/TESTING/LIN/derrsyx.f @@ -51,17 +51,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -92,9 +92,11 @@ EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHKXER, DSPCON, DSPRFS, DSPTRF, DSPTRI, - $ DSPTRS, DSYCON, DSYRFS, DSYTF2, DSYTRF, DSYTRI, - $ DSYTRI2, DSYTRS, DSYRFSX + EXTERNAL ALAESM, CHKXER, DSPCON, DSYCON_ROOK, DSPRFS, + $ DSPTRF, DSPTRI, DSPTRS, DSYCON, DSYRFS, DSYTF2, + $ DSYTF2_ROOK, DSYTRF, DSYTRF_ROOK, DSYTRI, + $ DSYTRI_ROOK, DSYTRI2, DSYTRS, DSYTRS_ROOK, + $ DSYRFSX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -136,8 +138,9 @@ * IF( LSAMEN( 2, C2, 'SY' ) ) THEN * -* Test error exits of the routines that use the Bunch-Kaufman -* factorization of a symmetric indefinite matrix. +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with patrial +* (Bunch-Kaufman) pivoting. * * DSYTRF * @@ -304,11 +307,92 @@ INFOT = 6 CALL DSYCON( 'U', 1, A, 1, IP, -1.0D0, RCOND, W, IW, INFO ) CALL CHKXER( 'DSYCON', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting. +* +* DSYTRF_ROOK +* + SRNAMT = 'DSYTRF_ROOK' + INFOT = 1 + CALL DSYTRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) + CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK ) +* +* DSYTF2_ROOK +* + SRNAMT = 'DSYTF2_ROOK' + INFOT = 1 + CALL DSYTF2_ROOK( '/', 0, A, 1, IP, INFO ) + CALL CHKXER( 'DSYTF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTF2_ROOK( 'U', -1, A, 1, IP, INFO ) + CALL CHKXER( 'DSYTF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTF2_ROOK( 'U', 2, A, 1, IP, INFO ) + CALL CHKXER( 'DSYTF2_ROOK', INFOT, NOUT, LERR, OK ) +* +* DSYTRI_ROOK +* + SRNAMT = 'DSYTRI_ROOK' + INFOT = 1 + CALL DSYTRI_ROOK( '/', 0, A, 1, IP, W, INFO ) + CALL CHKXER( 'DSYTRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRI_ROOK( 'U', -1, A, 1, IP, W, INFO ) + CALL CHKXER( 'DSYTRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRI_ROOK( 'U', 2, A, 1, IP, W, INFO ) + CALL CHKXER( 'DSYTRI_ROOK', INFOT, NOUT, LERR, OK ) +* +* DSYTRS_ROOK +* + SRNAMT = 'DSYTRS_ROOK' + INFOT = 1 + CALL DSYTRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYTRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYTRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO ) + CALL CHKXER( 'DSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYTRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_ROOK', INFOT, NOUT, LERR, OK ) +* +* DSYCON_ROOK +* + SRNAMT = 'DSYCON_ROOK' + INFOT = 1 + CALL DSYCON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'DSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYCON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'DSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYCON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'DSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DSYCON_ROOK( 'U', 1, A, 1, IP, -1.0D0, RCOND, W, IW, INFO) + CALL CHKXER( 'DSYCON_ROOK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * -* Test error exits of the routines that use the Bunch-Kaufman -* factorization of a symmetric indefinite packed matrix. +* Test error exits of the routines that use factorization +* of a symmetric indefinite packed matrix with patrial +* (Bunch-Kaufman) pivoting. * * DSPTRF * diff --git a/lapack-netlib/TESTING/LIN/derrvx.f b/lapack-netlib/TESTING/LIN/derrvx.f index b8a16bfec..ea9a7d0d5 100644 --- a/lapack-netlib/TESTING/LIN/derrvx.f +++ b/lapack-netlib/TESTING/LIN/derrvx.f @@ -91,7 +91,7 @@ EXTERNAL CHKXER, DGBSV, DGBSVX, DGESV, DGESVX, DGTSV, $ DGTSVX, DPBSV, DPBSVX, DPOSV, DPOSVX, DPPSV, $ DPPSVX, DPTSV, DPTSVX, DSPSV, DSPSVX, DSYSV, - $ DSYSVX + $ DSYSV_ROOK, DSYSVX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -626,6 +626,24 @@ CALL DSYSVX( 'N', 'U', 2, 0, A, 2, AF, 2, IP, B, 2, X, 2, $ RCOND, R1, R2, W, 3, IW, INFO ) CALL CHKXER( 'DSYSVX', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN +* +* DSYSV_ROOK +* + SRNAMT = 'DSYSV_ROOK' + INFOT = 1 + CALL DSYSV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYSV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYSV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/derrvxx.f b/lapack-netlib/TESTING/LIN/derrvxx.f index 35dd2c804..db32956a4 100644 --- a/lapack-netlib/TESTING/LIN/derrvxx.f +++ b/lapack-netlib/TESTING/LIN/derrvxx.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRVX( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER*3 PATH diff --git a/lapack-netlib/TESTING/LIN/dlavsy.f b/lapack-netlib/TESTING/LIN/dlavsy.f index e869ac0a8..b512ff0ff 100644 --- a/lapack-netlib/TESTING/LIN/dlavsy.f +++ b/lapack-netlib/TESTING/LIN/dlavsy.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DLAVSY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, * LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -19,7 +19,7 @@ * INTEGER IPIV( * ) * DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -85,6 +85,7 @@ *> A is DOUBLE PRECISION array, dimension (LDA,N) *> The block diagonal matrix D and the multipliers used to *> obtain the factor U or L as computed by DSYTRF. +*> Stored as a 2-D triangular matrix. *> \endverbatim *> *> \param[in] LDA @@ -141,12 +142,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup double_lin * @@ -154,10 +155,10 @@ SUBROUTINE DLAVSY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, $ LDB, INFO ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/dlavsy_rook.f b/lapack-netlib/TESTING/LIN/dlavsy_rook.f new file mode 100644 index 000000000..7b0c2c152 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/dlavsy_rook.f @@ -0,0 +1,584 @@ +*> \brief \b DLAVSY_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DLAVSY_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, +* LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, TRANS, UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAVSY_ROOK performs one of the matrix-vector operations +*> x := A*x or x := A'*x, +*> where x is an N element vector and A is one of the factors +*> from the block U*D*U' or L*D*L' factorization computed by DSYTRF_ROOK. +*> +*> If TRANS = 'N', multiplies by U or U * D (or L or L * D) +*> If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L') +*> If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L') +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the factor stored in A is upper or lower +*> triangular. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> Specifies the operation to be performed: +*> = 'N': x := A*x +*> = 'T': x := A'*x +*> = 'C': x := A'*x +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> Specifies whether or not the diagonal blocks are unit +*> matrices. If the diagonal blocks are assumed to be unit, +*> then A = U or A = L, otherwise A = U*D or A = L*D. +*> = 'U': Diagonal blocks are assumed to be unit matrices. +*> = 'N': Diagonal blocks are assumed to be non-unit matrices. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of vectors +*> x to be multiplied by A. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by DSYTRF_ROOK. +*> Stored as a 2-D triangular matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, +*> as determined by DSYTRF_ROOK. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> (If IPIV( k ) = k, no interchange was done). +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> (If IPIV( k ) = k, no interchange was done). +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, B contains NRHS vectors of length N. +*> On exit, B is overwritten with the product A * B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DLAVSY_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, + $ B, LDB, INFO ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER DIAG, TRANS, UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOUNIT + INTEGER J, K, KP + DOUBLE PRECISION D11, D12, D21, D22, T1, T2 +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DGER, DSCAL, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT. + $ LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LSAME( DIAG, 'U' ) .AND. .NOT.LSAME( DIAG, 'N' ) ) + $ THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAVSY_ROOK ', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* + NOUNIT = LSAME( DIAG, 'N' ) +*------------------------------------------ +* +* Compute B := A * B (No transpose) +* +*------------------------------------------ + IF( LSAME( TRANS, 'N' ) ) THEN +* +* Compute B := U*B +* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Loop forward applying the transformations. +* + K = 1 + 10 CONTINUE + IF( K.GT.N ) + $ GO TO 30 + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 pivot block +* +* Multiply by the diagonal element if forming U * D. +* + IF( NOUNIT ) + $ CALL DSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) +* +* Multiply by P(K) * inv(U(K)) if K > 1. +* + IF( K.GT.1 ) THEN +* +* Apply the transformation. +* + CALL DGER( K-1, NRHS, ONE, A( 1, K ), 1, B( K, 1 ), + $ LDB, B( 1, 1 ), LDB ) +* +* Interchange if P(K) .ne. I. +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + K = K + 1 + ELSE +* +* 2 x 2 pivot block +* +* Multiply by the diagonal block if forming U * D. +* + IF( NOUNIT ) THEN + D11 = A( K, K ) + D22 = A( K+1, K+1 ) + D12 = A( K, K+1 ) + D21 = D12 + DO 20 J = 1, NRHS + T1 = B( K, J ) + T2 = B( K+1, J ) + B( K, J ) = D11*T1 + D12*T2 + B( K+1, J ) = D21*T1 + D22*T2 + 20 CONTINUE + END IF +* +* Multiply by P(K) * inv(U(K)) if K > 1. +* + IF( K.GT.1 ) THEN +* +* Apply the transformations. +* + CALL DGER( K-1, NRHS, ONE, A( 1, K ), 1, B( K, 1 ), + $ LDB, B( 1, 1 ), LDB ) + CALL DGER( K-1, NRHS, ONE, A( 1, K+1 ), 1, + $ B( K+1, 1 ), LDB, B( 1, 1 ), LDB ) +* +* Interchange if a permutation was applied at the +* K-th step of the factorization. +* +* Swap the first of pair with IMAXth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* NOW swap the first of pair with Pth +* + KP = ABS( IPIV( K+1 ) ) + IF( KP.NE.K+1 ) + $ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), + $ LDB ) + END IF + K = K + 2 + END IF + GO TO 10 + 30 CONTINUE +* +* Compute B := L*B +* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . +* + ELSE +* +* Loop backward applying the transformations to B. +* + K = N + 40 CONTINUE + IF( K.LT.1 ) + $ GO TO 60 +* +* Test the pivot index. If greater than zero, a 1 x 1 +* pivot was used, otherwise a 2 x 2 pivot was used. +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 pivot block: +* +* Multiply by the diagonal element if forming L * D. +* + IF( NOUNIT ) + $ CALL DSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) +* +* Multiply by P(K) * inv(L(K)) if K < N. +* + IF( K.NE.N ) THEN + KP = IPIV( K ) +* +* Apply the transformation. +* + CALL DGER( N-K, NRHS, ONE, A( K+1, K ), 1, B( K, 1 ), + $ LDB, B( K+1, 1 ), LDB ) +* +* Interchange if a permutation was applied at the +* K-th step of the factorization. +* + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + K = K - 1 +* + ELSE +* +* 2 x 2 pivot block: +* +* Multiply by the diagonal block if forming L * D. +* + IF( NOUNIT ) THEN + D11 = A( K-1, K-1 ) + D22 = A( K, K ) + D21 = A( K, K-1 ) + D12 = D21 + DO 50 J = 1, NRHS + T1 = B( K-1, J ) + T2 = B( K, J ) + B( K-1, J ) = D11*T1 + D12*T2 + B( K, J ) = D21*T1 + D22*T2 + 50 CONTINUE + END IF +* +* Multiply by P(K) * inv(L(K)) if K < N. +* + IF( K.NE.N ) THEN +* +* Apply the transformation. +* + CALL DGER( N-K, NRHS, ONE, A( K+1, K ), 1, B( K, 1 ), + $ LDB, B( K+1, 1 ), LDB ) + CALL DGER( N-K, NRHS, ONE, A( K+1, K-1 ), 1, + $ B( K-1, 1 ), LDB, B( K+1, 1 ), LDB ) +* +* Interchange if a permutation was applied at the +* K-th step of the factorization. +* +* Swap the second of pair with IMAXth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* NOW swap the first of pair with Pth +* + KP = ABS( IPIV( K-1 ) ) + IF( KP.NE.K-1 ) + $ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), + $ LDB ) + END IF + K = K - 2 + END IF + GO TO 40 + 60 CONTINUE + END IF +*---------------------------------------- +* +* Compute B := A' * B (transpose) +* +*---------------------------------------- + ELSE +* +* Form B := U'*B +* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) +* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Loop backward applying the transformations. +* + K = N + 70 CONTINUE + IF( K.LT.1 ) + $ GO TO 90 +* +* 1 x 1 pivot block. +* + IF( IPIV( K ).GT.0 ) THEN + IF( K.GT.1 ) THEN +* +* Interchange if P(K) .ne. I. +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Apply the transformation +* + CALL DGEMV( 'Transpose', K-1, NRHS, ONE, B, LDB, + $ A( 1, K ), 1, ONE, B( K, 1 ), LDB ) + END IF + IF( NOUNIT ) + $ CALL DSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) + K = K - 1 +* +* 2 x 2 pivot block. +* + ELSE + IF( K.GT.2 ) THEN +* +* Swap the second of pair with Pth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Now swap the first of pair with IMAX(r)th +* + KP = ABS( IPIV( K-1 ) ) + IF( KP.NE.K-1 ) + $ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), + $ LDB ) +* +* Apply the transformations +* + CALL DGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB, + $ A( 1, K ), 1, ONE, B( K, 1 ), LDB ) + CALL DGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB, + $ A( 1, K-1 ), 1, ONE, B( K-1, 1 ), LDB ) + END IF +* +* Multiply by the diagonal block if non-unit. +* + IF( NOUNIT ) THEN + D11 = A( K-1, K-1 ) + D22 = A( K, K ) + D12 = A( K-1, K ) + D21 = D12 + DO 80 J = 1, NRHS + T1 = B( K-1, J ) + T2 = B( K, J ) + B( K-1, J ) = D11*T1 + D12*T2 + B( K, J ) = D21*T1 + D22*T2 + 80 CONTINUE + END IF + K = K - 2 + END IF + GO TO 70 + 90 CONTINUE +* +* Form B := L'*B +* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) +* and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1) +* + ELSE +* +* Loop forward applying the L-transformations. +* + K = 1 + 100 CONTINUE + IF( K.GT.N ) + $ GO TO 120 +* +* 1 x 1 pivot block +* + IF( IPIV( K ).GT.0 ) THEN + IF( K.LT.N ) THEN +* +* Interchange if P(K) .ne. I. +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Apply the transformation +* + CALL DGEMV( 'Transpose', N-K, NRHS, ONE, B( K+1, 1 ), + $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) + END IF + IF( NOUNIT ) + $ CALL DSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) + K = K + 1 +* +* 2 x 2 pivot block. +* + ELSE + IF( K.LT.N-1 ) THEN +* +* Swap the first of pair with Pth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Now swap the second of pair with IMAX(r)th +* + KP = ABS( IPIV( K+1 ) ) + IF( KP.NE.K+1 ) + $ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), + $ LDB ) +* +* Apply the transformation +* + CALL DGEMV( 'Transpose', N-K-1, NRHS, ONE, + $ B( K+2, 1 ), LDB, A( K+2, K+1 ), 1, ONE, + $ B( K+1, 1 ), LDB ) + CALL DGEMV( 'Transpose', N-K-1, NRHS, ONE, + $ B( K+2, 1 ), LDB, A( K+2, K ), 1, ONE, + $ B( K, 1 ), LDB ) + END IF +* +* Multiply by the diagonal block if non-unit. +* + IF( NOUNIT ) THEN + D11 = A( K, K ) + D22 = A( K+1, K+1 ) + D21 = A( K+1, K ) + D12 = D21 + DO 110 J = 1, NRHS + T1 = B( K, J ) + T2 = B( K+1, J ) + B( K, J ) = D11*T1 + D12*T2 + B( K+1, J ) = D21*T1 + D22*T2 + 110 CONTINUE + END IF + K = K + 2 + END IF + GO TO 100 + 120 CONTINUE + END IF +* + END IF + RETURN +* +* End of DLAVSY_ROOK +* + END diff --git a/lapack-netlib/TESTING/LIN/dsyt01.f b/lapack-netlib/TESTING/LIN/dsyt01.f index 4d07aafb8..f61b9113c 100644 --- a/lapack-netlib/TESTING/LIN/dsyt01.f +++ b/lapack-netlib/TESTING/LIN/dsyt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE DSYT01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDAFAC, LDC, N @@ -21,7 +21,7 @@ * DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), * $ RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,12 +111,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup double_lin * @@ -124,10 +124,10 @@ SUBROUTINE DSYT01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/dsyt01_rook.f b/lapack-netlib/TESTING/LIN/dsyt01_rook.f new file mode 100644 index 000000000..cb6668b18 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/dsyt01_rook.f @@ -0,0 +1,223 @@ +*> \brief \b DSYT01_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, +* RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), +* $ RWORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYT01_ROOK reconstructs a symmetric indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix and EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The original symmetric matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is DOUBLE PRECISION array, dimension (LDAFAC,N) +*> The factored form of the matrix A. AFAC contains the block +*> diagonal matrix D and the multipliers used to obtain the +*> factor L or U from the block L*D*L' or U*D*U' factorization +*> as computed by DSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from DSYTRF_ROOK. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is DOUBLE PRECISION +*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) +*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), + $ RWORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + DOUBLE PRECISION ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL LSAME, DLAMCH, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL DLASET, DLAVSY_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* Determine EPS and the norm of A. +* + EPS = DLAMCH( 'Epsilon' ) + ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Initialize C to the identity matrix. +* + CALL DLASET( 'Full', N, N, ZERO, ONE, C, LDC ) +* +* Call DLAVSY_ROOK to form the product D * U' (or D * L' ). +* + CALL DLAVSY_ROOK( UPLO, 'Transpose', 'Non-unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* Call DLAVSY_ROOK again to multiply by U (or L ). +* + CALL DLAVSY_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF +* +* Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = DLANSY( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS + END IF +* + RETURN +* +* End of DSYT01_ROOK +* + END diff --git a/lapack-netlib/TESTING/LIN/schkaa.f b/lapack-netlib/TESTING/LIN/schkaa.f index 0a471d25f..cbf16e610 100644 --- a/lapack-netlib/TESTING/LIN/schkaa.f +++ b/lapack-netlib/TESTING/LIN/schkaa.f @@ -158,9 +158,9 @@ EXTERNAL ALAREQ, SCHKEQ, SCHKGB, SCHKGE, SCHKGT, SCHKLQ, $ SCHKPB, SCHKPO, SCHKPS, SCHKPP, SCHKPT, SCHKQ3, $ SCHKQL, SCHKQP, SCHKQR, SCHKRQ, SCHKSP, SCHKSY, - $ SCHKTB, SCHKTP, SCHKTR, SCHKTZ, + $ SCHKSY_ROOK, SCHKTB, SCHKTP, SCHKTR, SCHKTZ, $ SDRVGB, SDRVGE, SDRVGT, SDRVLS, SDRVPB, SDRVPO, - $ SDRVPP, SDRVPT, SDRVSP, SDRVSY, + $ SDRVPP, SDRVPT, SDRVSP, SDRVSY, SDRVSY_ROOK, $ ILAVER, SCHKQRT, SCHKQRTP * .. * .. Scalars in Common .. @@ -637,6 +637,32 @@ ELSE WRITE( NOUT, FMT = 9988 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN +* +* SR: symmetric indefinite matrices with Rook pivoting, +* with rook (bounded Bunch-Kaufman) pivoting algorithm +* + NTYPES = 10 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL SCHKSY_ROOK(DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), + $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL SDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/schksy.f b/lapack-netlib/TESTING/LIN/schksy.f index 5c698e5a4..aee800a69 100644 --- a/lapack-netlib/TESTING/LIN/schksy.f +++ b/lapack-netlib/TESTING/LIN/schksy.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, * XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNB, NNS, NOUT @@ -23,7 +23,7 @@ * REAL A( * ), AFAC( * ), AINV( * ), B( * ), * $ RWORK( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -134,14 +134,12 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is REAL array, dimension -*> (NMAX*max(3,NSMAX)) +*> WORK is REAL array, dimension (NMAX*max(3,NSMAX)) *> \endverbatim *> *> \param[out] RWORK *> \verbatim -*> RWORK is REAL array, dimension -*> (max(NMAX,2*NSMAX)) +*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX)) *> \endverbatim *> *> \param[out] IWORK @@ -158,12 +156,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup single_lin * @@ -172,10 +170,10 @@ $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, $ XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -315,6 +313,9 @@ IF( INFO.NE.0 ) THEN CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1, $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* GO TO 160 END IF * @@ -357,11 +358,11 @@ 50 CONTINUE END IF ELSE - IOFF = 0 IF( IUPLO.EQ.1 ) THEN * * Set the first IZERO rows and columns to zero. * + IOFF = 0 DO 70 J = 1, N I2 = MIN( J, IZERO ) DO 60 I = 1, I2 @@ -373,6 +374,7 @@ * * Set the last IZERO rows and columns to zero. * + IOFF = 0 DO 90 J = 1, N I1 = MAX( J, IZERO ) DO 80 I = I1, N @@ -388,6 +390,7 @@ * * End generate the test matrix A. * +* * Do for each value of NB in NBVAL * DO 150 INB = 1, NNB @@ -506,6 +509,8 @@ RCONDC = ZERO GO TO 140 END IF +* +* Do for each value of NRHS in NSVAL. * DO 130 IRHS = 1, NNS NRHS = NSVAL( IRHS ) @@ -585,7 +590,7 @@ $ RWORK( NRHS+1 ), WORK, IWORK( N+1 ), $ INFO ) * -* Check error code from SSYRFS. +* Check error code from SSYRFS and handle error. * IF( INFO.NE.0 ) $ CALL ALAERH( PATH, 'SSYRFS', INFO, 0, UPLO, N, @@ -611,6 +616,9 @@ END IF 120 CONTINUE NRUN = NRUN + 6 +* +* End do for each value of NRHS in NSVAL. +* 130 CONTINUE * *+ TEST 9 diff --git a/lapack-netlib/TESTING/LIN/schksy_rook.f b/lapack-netlib/TESTING/LIN/schksy_rook.f new file mode 100644 index 000000000..23a84cd1c --- /dev/null +++ b/lapack-netlib/TESTING/LIN/schksy_rook.f @@ -0,0 +1,830 @@ +*> \brief \b SCHKSY_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, +* XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* REAL A( * ), AFAC( * ), AINV( * ), B( * ), +* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SCHKSY_ROOK tests SSYTRF_ROOK, -TRI_ROOK, -TRS_ROOK, +*> and -CON_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is 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. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is REAL array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is REAL array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is REAL array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX)) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup single_lin +* +* ===================================================================== + SUBROUTINE SCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, + $ XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NNB, NNS, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + REAL A( * ), AFAC( * ), AINV( * ), B( * ), + $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + REAL EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 10 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) +* .. +* .. Local Scalars .. + LOGICAL TRFCON, ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ ITEMP, IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, + $ MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, + $ NT + REAL ALPHA, ANORM, CNDNUM, CONST, LAM_MAX, LAM_MIN, + $ RCOND, RCONDC, STEMP +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER IDUMMY( 1 ), ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ), SDUMMY( 1 ) +* .. +* .. External Functions .. + REAL SGET06, SLANGE, SLANSY + EXTERNAL SGET06, SLANGE, SLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, SERRSY, SGET04, SLACPY, + $ SLARHS, SLATB4, SLATMS, SPOT02, SPOT03, SSYEVX, + $ SSYCON_ROOK, SSYT01_ROOK, SSYTRF_ROOK, + $ SSYTRI_ROOK, SSYTRS_ROOK, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Test path +* + PATH( 1: 1 ) = 'Single precision' + PATH( 2: 3 ) = 'SR' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Single precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL SERRSY( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 270 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 260 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 260 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 260 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 250 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with SLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL SLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with SLATMS. +* + SRNAMT = 'SLATMS' + CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from SLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 250 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* +* Do for each value of NB in NBVAL +* + DO 240 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'SSYTRF_ROOK' + CALL SSYTRF_ROOK( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from SSYTRF_ROOK and handle error. +* + IF( INFO.NE.K) + $ CALL ALAERH( PATH, 'SSYTRF_ROOK', INFO, K, + $ UPLO, N, N, -1, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Set the condition estimate flag if the INFO is not 0. +* + IF( INFO.NE.0 ) THEN + TRFCON = .TRUE. + ELSE + TRFCON = .FALSE. + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL SSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +*+ TEST 2 +* Form the inverse and compute the residual, +* if the factorization was competed without INFO > 0 +* (i.e. there is no zero rows and columns). +* Do it only for the first block size. +* + IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN + CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + SRNAMT = 'SSYTRI_ROOK' + CALL SSYTRI_ROOK( UPLO, N, AINV, LDA, IWORK, WORK, + $ INFO ) +* +* Check error code from SSYTRI_ROOK and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'SSYTRI_ROOK', INFO, -1, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the residual for a symmetric matrix times +* its inverse. +* + CALL SPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, + $ RWORK, RCONDC, RESULT( 2 ) ) + NT = 2 + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +*+ TEST 3 +* Compute largest element in U or L +* + RESULT( 3 ) = ZERO + STEMP = ZERO +* + CONST = ONE / ( ONE-ALPHA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Compute largest element in U +* + K = N + 120 CONTINUE + IF( K.LE.1 ) + $ GO TO 130 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in U +* + STEMP = SLANGE( 'M', K-1, 1, + $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k-1 in U +* + STEMP = SLANGE( 'M', K-2, 2, + $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK ) + K = K - 1 +* + END IF +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = STEMP +* + K = K - 1 +* + GO TO 120 + 130 CONTINUE +* + ELSE +* +* Compute largest element in L +* + K = 1 + 140 CONTINUE + IF( K.GE.N ) + $ GO TO 150 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in L +* + STEMP = SLANGE( 'M', N-K, 1, + $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k+1 in L +* + STEMP = SLANGE( 'M', N-K-1, 2, + $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK ) + K = K + 1 +* + END IF +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = STEMP +* + K = K + 1 +* + GO TO 140 + 150 CONTINUE + END IF +* +* +*+ TEST 4 +* Compute largest 2-Norm of 2-by-2 diag blocks +* + RESULT( 4 ) = ZERO + STEMP = ZERO +* + CONST = ( ONE+ALPHA ) / ( ONE-ALPHA ) + CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Loop backward for UPLO = 'U' +* + K = N + 160 CONTINUE + IF( K.LE.1 ) + $ GO TO 170 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two eigenvalues of a 2-by-2 block, +* store them in RWORK array +* + CALL SSYEVX( 'N', 'A', UPLO, 2, + $ AINV( ( K-2 )*LDA+K-1 ), LDA, STEMP, + $ STEMP, ITEMP, ITEMP, ZERO, ITEMP, + $ RWORK, SDUMMY, 1, WORK, 16, + $ IWORK( N+1 ), IDUMMY, INFO ) +* + LAM_MAX = MAX( ABS( RWORK( 1 ) ), + $ ABS( RWORK( 2 ) ) ) + LAM_MIN = MIN( ABS( RWORK( 1 ) ), + $ ABS( RWORK( 2 ) ) ) +* + STEMP = LAM_MAX / LAM_MIN +* +* STEMP should be bounded by CONST +* + STEMP = ABS( STEMP ) - CONST + THRESH + IF( STEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = STEMP + K = K - 1 +* + END IF +* + K = K - 1 +* + GO TO 160 + 170 CONTINUE +* + ELSE +* +* Loop forward for UPLO = 'L' +* + K = 1 + 180 CONTINUE + IF( K.GE.N ) + $ GO TO 190 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two eigenvalues of a 2-by-2 block, +* store them in RWORK array +* + CALL SSYEVX( 'N', 'A', UPLO, 2, + $ AINV( ( K-1 )*LDA+K ), LDA, STEMP, + $ STEMP, ITEMP, ITEMP, ZERO, ITEMP, + $ RWORK, SDUMMY, 1, WORK, 16, + $ IWORK( N+1 ), IDUMMY, INFO ) +* + LAM_MAX = MAX( ABS( RWORK( 1 ) ), + $ ABS( RWORK( 2 ) ) ) + LAM_MIN = MIN( ABS( RWORK( 1 ) ), + $ ABS( RWORK( 2 ) ) ) +* + STEMP = LAM_MAX / LAM_MIN +* +* STEMP should be bounded by CONST +* + STEMP = ABS( STEMP ) - CONST + THRESH + IF( STEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = STEMP + K = K + 1 +* + END IF +* + K = K + 1 +* + GO TO 180 + 190 CONTINUE + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 200 K = 3, 4 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 200 CONTINUE + NRUN = NRUN + 2 +* +* Skip the other tests if this is not the first block +* size. +* + IF( INB.GT.1 ) + $ GO TO 240 +* +* Do only the condition estimate if INFO is not 0. +* + IF( TRFCON ) THEN + RCONDC = ZERO + GO TO 230 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 220 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 5 ( Using TRS_ROOK) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'SLARHS' + CALL SLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'SSYTRS_ROOK' + CALL SSYTRS_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, INFO ) +* +* Check error code from SSYTRS_ROOK and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'SSYTRS_ROOK', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) +* + CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 5 ) ) +* +*+ TEST 6 +* Check solution from generated exact solution. +* + CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 6 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 210 K = 5, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 210 CONTINUE + NRUN = NRUN + 2 +* +* End do for each value of NRHS in NSVAL. +* + 220 CONTINUE +* +*+ TEST 7 +* Get an estimate of RCOND = 1/CNDNUM. +* + 230 CONTINUE + ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK ) + SRNAMT = 'SSYCON_ROOK' + CALL SSYCON_ROOK( UPLO, N, AFAC, LDA, IWORK, ANORM, + $ RCOND, WORK, IWORK( N+1 ), INFO ) +* +* Check error code from SSYCON_ROOK and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'SSYCON_ROOK', INFO, 0, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the test ratio to compare values of RCOND +* + RESULT( 7 ) = SGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7, + $ RESULT( 7 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 240 CONTINUE +* + 250 CONTINUE + 260 CONTINUE + 270 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test(', I2, ') =', G12.5 ) + 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, + $ ', test(', I2, ') =', G12.5 ) + RETURN +* +* End of SCHKSY_ROOK +* + END diff --git a/lapack-netlib/TESTING/LIN/sdrvpox.f b/lapack-netlib/TESTING/LIN/sdrvpox.f index 8f4d2caa2..565b6c382 100644 --- a/lapack-netlib/TESTING/LIN/sdrvpox.f +++ b/lapack-netlib/TESTING/LIN/sdrvpox.f @@ -158,7 +158,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup single_lin * @@ -167,10 +167,10 @@ $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -529,11 +529,12 @@ * * Check the error code from SPOSVX. * - IF( INFO.NE.IZERO ) - $ CALL ALAERH( PATH, 'SPOSVX', INFO, IZERO, + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'SPOSVX', INFO, IZERO, $ FACT // UPLO, N, N, -1, -1, NRHS, $ IMAT, NFAIL, NERRS, NOUT ) GO TO 90 + END IF * IF( INFO.EQ.0 ) THEN IF( .NOT.PREFAC ) THEN diff --git a/lapack-netlib/TESTING/LIN/sdrvrfp.f b/lapack-netlib/TESTING/LIN/sdrvrfp.f index df81d7cc4..c79b5a2c0 100644 --- a/lapack-netlib/TESTING/LIN/sdrvrfp.f +++ b/lapack-netlib/TESTING/LIN/sdrvrfp.f @@ -231,7 +231,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup single_lin * @@ -243,10 +243,10 @@ + S_TEMP_SPOT03, S_WORK_SLANSY, + S_WORK_SPOT02, S_WORK_SPOT03 ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. INTEGER NN, NNS, NNT, NOUT @@ -342,7 +342,7 @@ * * If N.EQ.0, only consider the first type * - IF( N.EQ.0 .AND. IIT.GT.1 ) GO TO 120 + IF( N.EQ.0 .AND. IIT.GE.1 ) GO TO 120 * * Skip types 3, 4, or 5 if the matrix size is too small. * @@ -442,16 +442,19 @@ * Form the inverse of A. * CALL SPOTRI( UPLO, N, A, LDA, INFO ) + + IF ( N .NE. 0 ) THEN * -* Compute the 1-norm condition number of A. +* Compute the 1-norm condition number of A. * - AINVNM = SLANSY( '1', UPLO, N, A, LDA, + AINVNM = SLANSY( '1', UPLO, N, A, LDA, + S_WORK_SLANSY ) - RCONDC = ( ONE / ANORM ) / AINVNM + RCONDC = ( ONE / ANORM ) / AINVNM * -* Restore the matrix A. +* Restore the matrix A. * - CALL SLACPY( UPLO, N, N, ASAV, LDA, A, LDA ) + CALL SLACPY( UPLO, N, N, ASAV, LDA, A, LDA ) + END IF * END IF * diff --git a/lapack-netlib/TESTING/LIN/sdrvsy.f b/lapack-netlib/TESTING/LIN/sdrvsy.f index 95fc002ce..1e3abeda1 100644 --- a/lapack-netlib/TESTING/LIN/sdrvsy.f +++ b/lapack-netlib/TESTING/LIN/sdrvsy.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE SDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -23,7 +23,7 @@ * REAL A( * ), AFAC( * ), AINV( * ), B( * ), * $ RWORK( * ), WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -116,8 +116,7 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is REAL array, dimension -*> (NMAX*max(2,NRHS)) +*> WORK is REAL array, dimension (NMAX*max(2,NRHS)) *> \endverbatim *> *> \param[out] RWORK @@ -139,12 +138,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup single_lin * @@ -153,10 +152,10 @@ $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/sdrvsy_rook.f b/lapack-netlib/TESTING/LIN/sdrvsy_rook.f new file mode 100644 index 000000000..e729dc51e --- /dev/null +++ b/lapack-netlib/TESTING/LIN/sdrvsy_rook.f @@ -0,0 +1,527 @@ +*> \brief \b SDRVSY_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, +* $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, +* $ RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* REAL A( * ), AFAC( * ), AINV( * ), B( * ), +* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SDRVSY_ROOK tests the driver routines SSYSV_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is 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. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is REAL array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is REAL array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is REAL array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension +*> (NMAX*max(2,NRHS)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE SDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NOUT, NRHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + REAL A( * ), AFAC( * ), AINV( * ), B( * ), + $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + REAL AINVNM, ANORM, CNDNUM, RCONDC +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) +* .. +* .. External Functions .. + REAL SLANSY + EXTERNAL SLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, SERRVX, SGET04, SLACPY, + $ SLARHS, SLASET, SLATB4, SLATMS, SPOT02, SPOT05, + $ SSYSV_ROOK, SSYT01_ROOK, SSYTRF_ROOK, + $ SSYTRI_ROOK, + $ XLAENV +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Single precision' + PATH( 2: 3 ) = 'SR' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Single precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL SERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for which the block +* routine should be used, which will be later returned by ILAENV. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with SLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL SLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with SLATMS. +* + SRNAMT = 'SLATMS' + CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from SLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of the +* matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IOFF = 0 + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Compute the condition number for comparison with +* the value returned by DSYSVX_ROOK. +* + IF( ZEROT ) THEN + IF( IFACT.EQ.1 ) + $ GO TO 150 + RCONDC = ZERO +* + ELSE IF( IFACT.EQ.1 ) THEN +* +* Compute the 1-norm of A. +* + ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* + CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL SSYTRF_ROOK( UPLO, N, AFAC, LDA, IWORK, WORK, + $ LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* + CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + LWORK = (N+NB+1)*(NB+3) + CALL SSYTRI_ROOK( UPLO, N, AINV, LDA, IWORK, + $ WORK, INFO ) + AINVNM = SLANSY( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'SLARHS' + CALL SLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test SSYSV_ROOK --- +* + IF( IFACT.EQ.2 ) THEN + CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using +* SSYSV_ROOK. +* + SRNAMT = 'SSYSV_ROOK' + CALL SSYSV_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from SSYSV_ROOK and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'SSYSV_ROOK', INFO, K, UPLO, + $ N, N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +*+ TEST 1 Reconstruct matrix from factors and compute +* residual. +* + CALL SSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDA, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +*+ TEST 2 Compute residual of the computed solution. +* + CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +*+ TEST 3 +* Check solution from generated exact solution. +* + CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 3 ) ) + NT = 3 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'SSYSV_ROOK', UPLO, + $ N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of SDRVSY_ROOK +* + END diff --git a/lapack-netlib/TESTING/LIN/serrsy.f b/lapack-netlib/TESTING/LIN/serrsy.f index 11fdc4eab..18fda1997 100644 --- a/lapack-netlib/TESTING/LIN/serrsy.f +++ b/lapack-netlib/TESTING/LIN/serrsy.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -86,9 +86,10 @@ EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHKXER, SSPCON, SSPRFS, SSPTRF, SSPTRI, - $ SSPTRS, SSYCON, SSYRFS, SSYTF2, SSYTRF, SSYTRI, - $ SSYTRI2, SSYTRS + EXTERNAL ALAESM, CHKXER, SSPCON, SSYCON_ROOK, SSPRFS, + $ SSPTRF, SSPTRI, SSPTRS, SSYCON, SSYRFS, SSYTF2, + $ SSYTF2_ROOK, SSYTRF, SSYTRF_ROOK, SSYTRI, + $ SSYTRI_ROOK, SSYTRI2, SSYTRS, SSYTRS_ROOK * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -252,11 +253,91 @@ CALL SSYCON( 'U', 1, A, 1, IP, -1.0, RCOND, W, IW, INFO ) CALL CHKXER( 'SSYCON', INFOT, NOUT, LERR, OK ) * - ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN + ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting. +* +* SSYTRF_ROOK +* + SRNAMT = 'SSYTRF_ROOK' + INFOT = 1 + CALL SSYTRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) + CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK ) +* +* SSYTF2_ROOK +* + SRNAMT = 'SSYTF2_ROOK' + INFOT = 1 + CALL SSYTF2_ROOK( '/', 0, A, 1, IP, INFO ) + CALL CHKXER( 'SSYTF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTF2_ROOK( 'U', -1, A, 1, IP, INFO ) + CALL CHKXER( 'SSYTF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTF2_ROOK( 'U', 2, A, 1, IP, INFO ) + CALL CHKXER( 'SSYTF2_ROOK', INFOT, NOUT, LERR, OK ) +* +* SSYTRI_ROOK +* + SRNAMT = 'SSYTRI_ROOK' + INFOT = 1 + CALL SSYTRI_ROOK( '/', 0, A, 1, IP, W, INFO ) + CALL CHKXER( 'SSYTRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRI_ROOK( 'U', -1, A, 1, IP, W, INFO ) + CALL CHKXER( 'SSYTRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRI_ROOK( 'U', 2, A, 1, IP, W, INFO ) + CALL CHKXER( 'SSYTRI_ROOK', INFOT, NOUT, LERR, OK ) +* +* SSYTRS_ROOK +* + SRNAMT = 'SSYTRS_ROOK' + INFOT = 1 + CALL SSYTRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYTRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSYTRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO ) + CALL CHKXER( 'SSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYTRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_ROOK', INFOT, NOUT, LERR, OK ) +* +* SSYCON_ROOK +* + SRNAMT = 'SSYCON_ROOK' + INFOT = 1 + CALL SSYCON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'SSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYCON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'SSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYCON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'SSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SSYCON_ROOK( 'U', 1, A, 1, IP, -1.0, RCOND, W, IW, INFO ) + CALL CHKXER( 'SSYCON_ROOK', INFOT, NOUT, LERR, OK ) * * Test error exits of the routines that use factorization * of a symmetric indefinite packed matrix with patrial * (Bunch-Kaufman) pivoting. +* + ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * * SSPTRF * diff --git a/lapack-netlib/TESTING/LIN/serrsyx.f b/lapack-netlib/TESTING/LIN/serrsyx.f index 48513d9dc..45ebc34d6 100644 --- a/lapack-netlib/TESTING/LIN/serrsyx.f +++ b/lapack-netlib/TESTING/LIN/serrsyx.f @@ -51,17 +51,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -93,8 +93,10 @@ * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, SSPCON, SSPRFS, SSPTRF, SSPTRI, - $ SSPTRS, SSYCON, SSYRFS, SSYTF2, SSYTRF, SSYTRI, - $ SSYTRI2, SSYTRS, SSYRFSX + $ SSPTRS, SSYCON, SSYCON_ROOK,SSYRFS, SSYTF2, + $ SSYTF2_ROOK, SSYTRF, SSYTRF_ROOK, SSYTRI, + $ SSYTRI_ROOK, SSYTRI2, SSYTRS, SSYTRS_ROOK, + $ SSYRFSX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -136,8 +138,9 @@ * IF( LSAMEN( 2, C2, 'SY' ) ) THEN * -* Test error exits of the routines that use the Bunch-Kaufman -* factorization of a symmetric indefinite matrix. +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with patrial +* (Bunch-Kaufman) pivoting. * * SSYTRF * @@ -305,10 +308,91 @@ CALL SSYCON( 'U', 1, A, 1, IP, -1.0, RCOND, W, IW, INFO ) CALL CHKXER( 'SSYCON', INFOT, NOUT, LERR, OK ) * - ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN + ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting. +* +* SSYTRF_ROOK +* + SRNAMT = 'SSYTRF_ROOK' + INFOT = 1 + CALL SSYTRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) + CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK ) +* +* SSYTF2_ROOK +* + SRNAMT = 'SSYTF2_ROOK' + INFOT = 1 + CALL SSYTF2_ROOK( '/', 0, A, 1, IP, INFO ) + CALL CHKXER( 'SSYTF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTF2_ROOK( 'U', -1, A, 1, IP, INFO ) + CALL CHKXER( 'SSYTF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTF2_ROOK( 'U', 2, A, 1, IP, INFO ) + CALL CHKXER( 'SSYTF2_ROOK', INFOT, NOUT, LERR, OK ) +* +* SSYTRI_ROOK +* + SRNAMT = 'SSYTRI_ROOK' + INFOT = 1 + CALL SSYTRI_ROOK( '/', 0, A, 1, IP, W, INFO ) + CALL CHKXER( 'SSYTRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRI_ROOK( 'U', -1, A, 1, IP, W, INFO ) + CALL CHKXER( 'SSYTRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRI_ROOK( 'U', 2, A, 1, IP, W, INFO ) + CALL CHKXER( 'SSYTRI_ROOK', INFOT, NOUT, LERR, OK ) +* +* SSYTRS_ROOK +* + SRNAMT = 'SSYTRS_ROOK' + INFOT = 1 + CALL SSYTRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYTRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSYTRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO ) + CALL CHKXER( 'SSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYTRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_ROOK', INFOT, NOUT, LERR, OK ) * -* Test error exits of the routines that use the Bunch-Kaufman -* factorization of a symmetric indefinite packed matrix. +* SSYCON_ROOK +* + SRNAMT = 'SSYCON_ROOK' + INFOT = 1 + CALL SSYCON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'SSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYCON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'SSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYCON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'SSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SSYCON_ROOK( 'U', 1, A, 1, IP, -1.0, RCOND, W, IW, INFO ) + CALL CHKXER( 'SSYCON_ROOK', INFOT, NOUT, LERR, OK ) +* +* Test error exits of the routines that use factorization +* of a symmetric indefinite packed matrix with patrial +* (Bunch-Kaufman) pivoting. +* + ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * * SSPTRF * diff --git a/lapack-netlib/TESTING/LIN/serrvx.f b/lapack-netlib/TESTING/LIN/serrvx.f index 8445fa61a..c09ca3998 100644 --- a/lapack-netlib/TESTING/LIN/serrvx.f +++ b/lapack-netlib/TESTING/LIN/serrvx.f @@ -91,7 +91,7 @@ EXTERNAL CHKXER, SGBSV, SGBSVX, SGESV, SGESVX, SGTSV, $ SGTSVX, SPBSV, SPBSVX, SPOSV, SPOSVX, SPPSV, $ SPPSVX, SPTSV, SPTSVX, SSPSV, SSPSVX, SSYSV, - $ SSYSVX + $ SSYSV_ROOK, SSYSVX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -626,6 +626,24 @@ CALL SSYSVX( 'N', 'U', 2, 0, A, 2, AF, 2, IP, B, 2, X, 2, $ RCOND, R1, R2, W, 3, IW, INFO ) CALL CHKXER( 'SSYSVX', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN +* +* SSYSV_ROOK +* + SRNAMT = 'SSYSV_ROOK' + INFOT = 1 + CALL SSYSV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYSV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYSV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/serrvxx.f b/lapack-netlib/TESTING/LIN/serrvxx.f index c5849e415..147e5ff13 100644 --- a/lapack-netlib/TESTING/LIN/serrvxx.f +++ b/lapack-netlib/TESTING/LIN/serrvxx.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRVX( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -92,7 +92,8 @@ EXTERNAL CHKXER, SGBSV, SGBSVX, SGESV, SGESVX, SGTSV, $ SGTSVX, SPBSV, SPBSVX, SPOSV, SPOSVX, SPPSV, $ SPPSVX, SPTSV, SPTSVX, SSPSV, SSPSVX, SSYSV, - $ SSYSVX, SGESVXX, SSYSVXX, SPOSVXX, SGBSVXX + $ SSYSV_ROOK, SSYSVX, SGESVXX, SSYSVXX, SPOSVXX, + $ SGBSVXX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -886,6 +887,22 @@ $ 1, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_N, $ ERR_BNDS_C, NPARAMS, PARAMS, W, IW, INFO ) CALL CHKXER( 'SSYSVXX', INFOT, NOUT, LERR, OK ) +* +* SSYSV_ROOK +* + SRNAMT = 'SSYSV_ROOK' + INFOT = 1 + CALL SSYSV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYSV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYSV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/slavsy.f b/lapack-netlib/TESTING/LIN/slavsy.f index 5f78afb82..3c575e2d7 100644 --- a/lapack-netlib/TESTING/LIN/slavsy.f +++ b/lapack-netlib/TESTING/LIN/slavsy.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SLAVSY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, * LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -19,7 +19,7 @@ * INTEGER IPIV( * ) * REAL A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= @@ -85,6 +85,7 @@ *> A is REAL array, dimension (LDA,N) *> The block diagonal matrix D and the multipliers used to *> obtain the factor U or L as computed by SSYTRF. +*> Stored as a 2-D triangular matrix. *> \endverbatim *> *> \param[in] LDA @@ -141,12 +142,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup single_lin * @@ -154,10 +155,10 @@ SUBROUTINE SLAVSY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, $ LDB, INFO ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/slavsy_rook.f b/lapack-netlib/TESTING/LIN/slavsy_rook.f new file mode 100644 index 000000000..55477bd96 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/slavsy_rook.f @@ -0,0 +1,584 @@ +*> \brief \b SLAVSY_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SLAVSY_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, +* LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, TRANS, UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLAVSY_ROOK performs one of the matrix-vector operations +*> x := A*x or x := A'*x, +*> where x is an N element vector and A is one of the factors +*> from the block U*D*U' or L*D*L' factorization computed by SSYTRF_ROOK. +*> +*> If TRANS = 'N', multiplies by U or U * D (or L or L * D) +*> If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L') +*> If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L') +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the factor stored in A is upper or lower +*> triangular. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> Specifies the operation to be performed: +*> = 'N': x := A*x +*> = 'T': x := A'*x +*> = 'C': x := A'*x +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> Specifies whether or not the diagonal blocks are unit +*> matrices. If the diagonal blocks are assumed to be unit, +*> then A = U or A = L, otherwise A = U*D or A = L*D. +*> = 'U': Diagonal blocks are assumed to be unit matrices. +*> = 'N': Diagonal blocks are assumed to be non-unit matrices. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of vectors +*> x to be multiplied by A. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by SSYTRF_ROOK. +*> Stored as a 2-D triangular matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, +*> as determined by SSYTRF_ROOK. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> (If IPIV( k ) = k, no interchange was done). +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> (If IPIV( k ) = k, no interchange was done). +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB,NRHS) +*> On entry, B contains NRHS vectors of length N. +*> On exit, B is overwritten with the product A * B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup single_lin +* +* ===================================================================== + SUBROUTINE SLAVSY_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, + $ B, LDB, INFO ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER DIAG, TRANS, UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOUNIT + INTEGER J, K, KP + REAL D11, D12, D21, D22, T1, T2 +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SGEMV, SGER, SSCAL, SSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT. + $ LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LSAME( DIAG, 'U' ) .AND. .NOT.LSAME( DIAG, 'N' ) ) + $ THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SLAVSY_ROOK ', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* + NOUNIT = LSAME( DIAG, 'N' ) +*------------------------------------------ +* +* Compute B := A * B (No transpose) +* +*------------------------------------------ + IF( LSAME( TRANS, 'N' ) ) THEN +* +* Compute B := U*B +* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Loop forward applying the transformations. +* + K = 1 + 10 CONTINUE + IF( K.GT.N ) + $ GO TO 30 + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 pivot block +* +* Multiply by the diagonal element if forming U * D. +* + IF( NOUNIT ) + $ CALL SSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) +* +* Multiply by P(K) * inv(U(K)) if K > 1. +* + IF( K.GT.1 ) THEN +* +* Apply the transformation. +* + CALL SGER( K-1, NRHS, ONE, A( 1, K ), 1, B( K, 1 ), + $ LDB, B( 1, 1 ), LDB ) +* +* Interchange if P(K) .ne. I. +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + K = K + 1 + ELSE +* +* 2 x 2 pivot block +* +* Multiply by the diagonal block if forming U * D. +* + IF( NOUNIT ) THEN + D11 = A( K, K ) + D22 = A( K+1, K+1 ) + D12 = A( K, K+1 ) + D21 = D12 + DO 20 J = 1, NRHS + T1 = B( K, J ) + T2 = B( K+1, J ) + B( K, J ) = D11*T1 + D12*T2 + B( K+1, J ) = D21*T1 + D22*T2 + 20 CONTINUE + END IF +* +* Multiply by P(K) * inv(U(K)) if K > 1. +* + IF( K.GT.1 ) THEN +* +* Apply the transformations. +* + CALL SGER( K-1, NRHS, ONE, A( 1, K ), 1, B( K, 1 ), + $ LDB, B( 1, 1 ), LDB ) + CALL SGER( K-1, NRHS, ONE, A( 1, K+1 ), 1, + $ B( K+1, 1 ), LDB, B( 1, 1 ), LDB ) +* +* Interchange if a permutation was applied at the +* K-th step of the factorization. +* +* Swap the first of pair with IMAXth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* NOW swap the first of pair with Pth +* + KP = ABS( IPIV( K+1 ) ) + IF( KP.NE.K+1 ) + $ CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), + $ LDB ) + END IF + K = K + 2 + END IF + GO TO 10 + 30 CONTINUE +* +* Compute B := L*B +* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . +* + ELSE +* +* Loop backward applying the transformations to B. +* + K = N + 40 CONTINUE + IF( K.LT.1 ) + $ GO TO 60 +* +* Test the pivot index. If greater than zero, a 1 x 1 +* pivot was used, otherwise a 2 x 2 pivot was used. +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 pivot block: +* +* Multiply by the diagonal element if forming L * D. +* + IF( NOUNIT ) + $ CALL SSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) +* +* Multiply by P(K) * inv(L(K)) if K < N. +* + IF( K.NE.N ) THEN + KP = IPIV( K ) +* +* Apply the transformation. +* + CALL SGER( N-K, NRHS, ONE, A( K+1, K ), 1, B( K, 1 ), + $ LDB, B( K+1, 1 ), LDB ) +* +* Interchange if a permutation was applied at the +* K-th step of the factorization. +* + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + K = K - 1 +* + ELSE +* +* 2 x 2 pivot block: +* +* Multiply by the diagonal block if forming L * D. +* + IF( NOUNIT ) THEN + D11 = A( K-1, K-1 ) + D22 = A( K, K ) + D21 = A( K, K-1 ) + D12 = D21 + DO 50 J = 1, NRHS + T1 = B( K-1, J ) + T2 = B( K, J ) + B( K-1, J ) = D11*T1 + D12*T2 + B( K, J ) = D21*T1 + D22*T2 + 50 CONTINUE + END IF +* +* Multiply by P(K) * inv(L(K)) if K < N. +* + IF( K.NE.N ) THEN +* +* Apply the transformation. +* + CALL SGER( N-K, NRHS, ONE, A( K+1, K ), 1, B( K, 1 ), + $ LDB, B( K+1, 1 ), LDB ) + CALL SGER( N-K, NRHS, ONE, A( K+1, K-1 ), 1, + $ B( K-1, 1 ), LDB, B( K+1, 1 ), LDB ) +* +* Interchange if a permutation was applied at the +* K-th step of the factorization. +* +* Swap the second of pair with IMAXth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* NOW swap the first of pair with Pth +* + KP = ABS( IPIV( K-1 ) ) + IF( KP.NE.K-1 ) + $ CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), + $ LDB ) + END IF + K = K - 2 + END IF + GO TO 40 + 60 CONTINUE + END IF +*---------------------------------------- +* +* Compute B := A' * B (transpose) +* +*---------------------------------------- + ELSE +* +* Form B := U'*B +* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) +* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Loop backward applying the transformations. +* + K = N + 70 CONTINUE + IF( K.LT.1 ) + $ GO TO 90 +* +* 1 x 1 pivot block. +* + IF( IPIV( K ).GT.0 ) THEN + IF( K.GT.1 ) THEN +* +* Interchange if P(K) .ne. I. +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Apply the transformation +* + CALL SGEMV( 'Transpose', K-1, NRHS, ONE, B, LDB, + $ A( 1, K ), 1, ONE, B( K, 1 ), LDB ) + END IF + IF( NOUNIT ) + $ CALL SSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) + K = K - 1 +* +* 2 x 2 pivot block. +* + ELSE + IF( K.GT.2 ) THEN +* +* Swap the second of pair with Pth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Now swap the first of pair with IMAX(r)th +* + KP = ABS( IPIV( K-1 ) ) + IF( KP.NE.K-1 ) + $ CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), + $ LDB ) +* +* Apply the transformations +* + CALL SGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB, + $ A( 1, K ), 1, ONE, B( K, 1 ), LDB ) + CALL SGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB, + $ A( 1, K-1 ), 1, ONE, B( K-1, 1 ), LDB ) + END IF +* +* Multiply by the diagonal block if non-unit. +* + IF( NOUNIT ) THEN + D11 = A( K-1, K-1 ) + D22 = A( K, K ) + D12 = A( K-1, K ) + D21 = D12 + DO 80 J = 1, NRHS + T1 = B( K-1, J ) + T2 = B( K, J ) + B( K-1, J ) = D11*T1 + D12*T2 + B( K, J ) = D21*T1 + D22*T2 + 80 CONTINUE + END IF + K = K - 2 + END IF + GO TO 70 + 90 CONTINUE +* +* Form B := L'*B +* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) +* and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1) +* + ELSE +* +* Loop forward applying the L-transformations. +* + K = 1 + 100 CONTINUE + IF( K.GT.N ) + $ GO TO 120 +* +* 1 x 1 pivot block +* + IF( IPIV( K ).GT.0 ) THEN + IF( K.LT.N ) THEN +* +* Interchange if P(K) .ne. I. +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Apply the transformation +* + CALL SGEMV( 'Transpose', N-K, NRHS, ONE, B( K+1, 1 ), + $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) + END IF + IF( NOUNIT ) + $ CALL SSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) + K = K + 1 +* +* 2 x 2 pivot block. +* + ELSE + IF( K.LT.N-1 ) THEN +* +* Swap the first of pair with Pth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Now swap the second of pair with IMAX(r)th +* + KP = ABS( IPIV( K+1 ) ) + IF( KP.NE.K+1 ) + $ CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), + $ LDB ) +* +* Apply the transformation +* + CALL SGEMV( 'Transpose', N-K-1, NRHS, ONE, + $ B( K+2, 1 ), LDB, A( K+2, K+1 ), 1, ONE, + $ B( K+1, 1 ), LDB ) + CALL SGEMV( 'Transpose', N-K-1, NRHS, ONE, + $ B( K+2, 1 ), LDB, A( K+2, K ), 1, ONE, + $ B( K, 1 ), LDB ) + END IF +* +* Multiply by the diagonal block if non-unit. +* + IF( NOUNIT ) THEN + D11 = A( K, K ) + D22 = A( K+1, K+1 ) + D21 = A( K+1, K ) + D12 = D21 + DO 110 J = 1, NRHS + T1 = B( K, J ) + T2 = B( K+1, J ) + B( K, J ) = D11*T1 + D12*T2 + B( K+1, J ) = D21*T1 + D22*T2 + 110 CONTINUE + END IF + K = K + 2 + END IF + GO TO 100 + 120 CONTINUE + END IF +* + END IF + RETURN +* +* End of SLAVSY_ROOK +* + END diff --git a/lapack-netlib/TESTING/LIN/ssyt01.f b/lapack-netlib/TESTING/LIN/ssyt01.f index 134189e0b..f1fb0b9c3 100644 --- a/lapack-netlib/TESTING/LIN/ssyt01.f +++ b/lapack-netlib/TESTING/LIN/ssyt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE SSYT01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDAFAC, LDC, N @@ -21,7 +21,7 @@ * REAL A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), * $ RWORK( * ) * .. -* +* * *> \par Purpose: * ============= @@ -111,12 +111,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup single_lin * @@ -124,10 +124,10 @@ SUBROUTINE SSYT01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/ssyt01_rook.f b/lapack-netlib/TESTING/LIN/ssyt01_rook.f new file mode 100644 index 000000000..129e9dafe --- /dev/null +++ b/lapack-netlib/TESTING/LIN/ssyt01_rook.f @@ -0,0 +1,223 @@ +*> \brief \b SSYT01_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, +* RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* REAL RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), +* $ RWORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYT01_ROOK reconstructs a symmetric indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix and EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> The original symmetric matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is REAL array, dimension (LDAFAC,N) +*> The factored form of the matrix A. AFAC contains the block +*> diagonal matrix D and the multipliers used to obtain the +*> factor L or U from the block L*D*L' or U*D*U' factorization +*> as computed by SSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from SSYTRF_ROOK. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is REAL array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is REAL +*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) +*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup single_lin +* +* ===================================================================== + SUBROUTINE SSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + REAL RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), + $ RWORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + REAL ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SLAMCH, SLANSY + EXTERNAL LSAME, SLAMCH, SLANSY +* .. +* .. External Subroutines .. + EXTERNAL SLASET, SLAVSY_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* Determine EPS and the norm of A. +* + EPS = SLAMCH( 'Epsilon' ) + ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Initialize C to the identity matrix. +* + CALL SLASET( 'Full', N, N, ZERO, ONE, C, LDC ) +* +* Call SLAVSY_ROOK to form the product D * U' (or D * L' ). +* + CALL SLAVSY_ROOK( UPLO, 'Transpose', 'Non-unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* Call SLAVSY_ROOK again to multiply by U (or L ). +* + CALL SLAVSY_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF +* +* Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = SLANSY( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID / REAL( N ) ) / ANORM ) / EPS + END IF +* + RETURN +* +* End of SSYT01_ROOK +* + END diff --git a/lapack-netlib/TESTING/LIN/zchkaa.f b/lapack-netlib/TESTING/LIN/zchkaa.f index 6537762c2..1c8c6ca71 100644 --- a/lapack-netlib/TESTING/LIN/zchkaa.f +++ b/lapack-netlib/TESTING/LIN/zchkaa.f @@ -50,6 +50,7 @@ *> ZPB 8 List types on next line if 0 < NTYPES < 8 *> ZPT 12 List types on next line if 0 < NTYPES < 12 *> ZHE 10 List types on next line if 0 < NTYPES < 10 +*> ZHR 10 List types on next line if 0 < NTYPES < 10 *> ZHP 10 List types on next line if 0 < NTYPES < 10 *> ZSY 11 List types on next line if 0 < NTYPES < 11 *> ZSR 11 List types on next line if 0 < NTYPES < 11 @@ -101,17 +102,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup complex16_lin * * ===================================================================== PROGRAM ZCHKAA * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * ===================================================================== * @@ -158,13 +159,13 @@ * .. * .. External Subroutines .. EXTERNAL ALAREQ, ZCHKEQ, ZCHKGB, ZCHKGE, ZCHKGT, ZCHKHE, - $ ZCHKHP, ZCHKLQ, ZCHKPB, ZCHKPO, ZCHKPS, ZCHKPP, - $ ZCHKPT, ZCHKQ3, ZCHKQL, ZCHKQP, ZCHKQR, ZCHKRQ, - $ ZCHKSP, ZCHKSY, ZCHKTB, ZCHKTP, - $ ZCHKTR, ZCHKTZ, ZDRVGB, ZDRVGE, ZDRVGT, ZDRVHE, - $ ZDRVHP, ZDRVLS, ZDRVPB, ZDRVPO, ZDRVPP, ZDRVPT, - $ ZDRVSP, ZDRVSY, ILAVER, ZCHKQRT, - $ ZCHKQRTP + $ ZCHKHE_ROOK, ZCHKHP, ZCHKLQ, ZCHKPB, ZCHKPO, + $ ZCHKPS, ZCHKPP, ZCHKPT, ZCHKQ3, ZCHKQL, ZCHKQP, + $ ZCHKQR, ZCHKRQ, ZCHKSP, ZCHKSY, ZCHKSY_ROOK, + $ ZCHKTB, ZCHKTP, ZCHKTR, ZCHKTZ, ZDRVGB, ZDRVGE, + $ ZDRVGT, ZDRVHE, ZDRVHE_ROOK, ZDRVHP, ZDRVLS, + $ ZDRVPB, ZDRVPO, ZDRVPP, ZDRVPT, ZDRVSP, ZDRVSY, + $ ZDRVSY_ROOK, ILAVER, ZCHKQRT, ZCHKQRTP * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -637,6 +638,32 @@ ELSE WRITE( NOUT, FMT = 9988 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN +* +* HR: Hermitian indefinite matrices, +* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* + NTYPES = 10 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL ZCHKHE_ROOK(DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), + $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL ZDRVHE_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, + $ RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * @@ -688,6 +715,32 @@ ELSE WRITE( NOUT, FMT = 9988 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN +* +* SR: symmetric indefinite matrices, +* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* + NTYPES = 11 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL ZCHKSY_ROOK(DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), + $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL ZDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, + $ RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/zchkhe.f b/lapack-netlib/TESTING/LIN/zchkhe.f index ab4d0c394..0b5a1a1aa 100644 --- a/lapack-netlib/TESTING/LIN/zchkhe.f +++ b/lapack-netlib/TESTING/LIN/zchkhe.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCHKHE( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, * XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNB, NNS, NOUT @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -135,14 +135,12 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is COMPLEX*16 array, dimension -*> (NMAX*max(3,NSMAX)) +*> WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX)) *> \endverbatim *> *> \param[out] RWORK *> \verbatim -*> RWORK is DOUBLE PRECISION array, dimension -*> (max(NMAX,2*NSMAX)) +*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX)) *> \endverbatim *> *> \param[out] IWORK @@ -159,12 +157,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex16_lin * @@ -173,10 +171,10 @@ $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, $ XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -196,6 +194,8 @@ * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) INTEGER NTYPES PARAMETER ( NTYPES = 10 ) INTEGER NTESTS @@ -260,6 +260,11 @@ $ CALL ZERRHE( PATH, NOUT ) INFOT = 0 * +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* * Do for each value of N in NVAL * DO 180 IN = 1, NN @@ -289,22 +294,27 @@ DO 160 IUPLO = 1, 2 UPLO = UPLOS( IUPLO ) * -* Set up parameters with ZLATB4 and generate a test matrix -* with ZLATMS. +* Set up parameters with ZLATB4 for the matrix generator +* based on the type of matrix to be generated. * CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, $ CNDNUM, DIST ) +* +* Generate a matrix with ZLATMS. * SRNAMT = 'ZLATMS' CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, $ INFO ) * -* Check error code from ZLATMS. +* Check error code from ZLATMS and handle error. * IF( INFO.NE.0 ) THEN CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, -1, $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* GO TO 160 END IF * @@ -327,34 +337,34 @@ IF( IUPLO.EQ.1 ) THEN IOFF = ( IZERO-1 )*LDA DO 20 I = 1, IZERO - 1 - A( IOFF+I ) = ZERO + A( IOFF+I ) = CZERO 20 CONTINUE IOFF = IOFF + IZERO DO 30 I = IZERO, N - A( IOFF ) = ZERO + A( IOFF ) = CZERO IOFF = IOFF + LDA 30 CONTINUE ELSE IOFF = IZERO DO 40 I = 1, IZERO - 1 - A( IOFF ) = ZERO + A( IOFF ) = CZERO IOFF = IOFF + LDA 40 CONTINUE IOFF = IOFF - IZERO DO 50 I = IZERO, N - A( IOFF+I ) = ZERO + A( IOFF+I ) = CZERO 50 CONTINUE END IF ELSE - IOFF = 0 IF( IUPLO.EQ.1 ) THEN * * Set the first IZERO rows and columns to zero. * + IOFF = 0 DO 70 J = 1, N I2 = MIN( J, IZERO ) DO 60 I = 1, I2 - A( IOFF+I ) = ZERO + A( IOFF+I ) = CZERO 60 CONTINUE IOFF = IOFF + LDA 70 CONTINUE @@ -362,10 +372,11 @@ * * Set the last IZERO rows and columns to zero. * + IOFF = 0 DO 90 J = 1, N I1 = MAX( J, IZERO ) DO 80 I = I1, N - A( IOFF+I ) = ZERO + A( IOFF+I ) = CZERO 80 CONTINUE IOFF = IOFF + LDA 90 CONTINUE @@ -375,6 +386,9 @@ IZERO = 0 END IF * +* End generate test matrix A. +* +* * Set the imaginary part of the diagonals. * CALL ZLAIPD( N, A, LDA+1, 0 ) @@ -382,13 +396,24 @@ * Do for each value of NB in NBVAL * DO 150 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* NB = NBVAL( INB ) CALL XLAENV( 1, NB ) * -* Compute the L*D*L' or U*D*U' factorization of the -* matrix. +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. * CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* LWORK = MAX( 2, NB )*LDA SRNAMT = 'ZHETRF' CALL ZHETRF( UPLO, N, AFAC, LDA, IWORK, AINV, LWORK, @@ -411,11 +436,14 @@ END IF END IF * -* Check error code from ZHETRF. +* Check error code from ZHETRF and handle error. * IF( INFO.NE.K ) $ CALL ALAERH( PATH, 'ZHETRF', INFO, K, UPLO, N, N, $ -1, -1, NB, IMAT, NFAIL, NERRS, NOUT ) +* +* Set the condition estimate flag if the INFO is not 0. +* IF( INFO.NE.0 ) THEN TRFCON = .TRUE. ELSE @@ -439,12 +467,15 @@ CALL ZHETRI2( UPLO, N, AINV, LDA, IWORK, WORK, $ LWORK, INFO ) * -* Check error code from ZHETRI. +* Check error code from ZHETRI and handle error. * IF( INFO.NE.0 ) $ CALL ALAERH( PATH, 'ZHETRI', INFO, -1, UPLO, N, $ N, -1, -1, -1, IMAT, NFAIL, NERRS, $ NOUT ) +* +* Compute the residual for a symmetric matrix times +* its inverse. * CALL ZPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, $ RWORK, RCONDC, RESULT( 2 ) ) @@ -477,12 +508,17 @@ RCONDC = ZERO GO TO 140 END IF +* +* Do for each value of NRHS in NSVAL. * DO 130 IRHS = 1, NNS NRHS = NSVAL( IRHS ) * -*+ TEST 3 +*+ TEST 3 (Using TRS) * Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B * SRNAMT = 'ZLARHS' CALL ZLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, @@ -494,7 +530,7 @@ CALL ZHETRS( UPLO, N, NRHS, AFAC, LDA, IWORK, X, $ LDA, INFO ) * -* Check error code from ZHETRS. +* Check error code from ZHETRS and handle error. * IF( INFO.NE.0 ) $ CALL ALAERH( PATH, 'ZHETRS', INFO, 0, UPLO, N, @@ -502,11 +538,17 @@ $ NERRS, NOUT ) * CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, $ LDA, RWORK, RESULT( 3 ) ) * -*+ TEST 4 +*+ TEST 4 (Using TRS2) * Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B * SRNAMT = 'ZLARHS' CALL ZLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, @@ -518,7 +560,7 @@ CALL ZHETRS2( UPLO, N, NRHS, AFAC, LDA, IWORK, X, $ LDA, WORK, INFO ) * -* Check error code from ZSYTRS2. +* Check error code from ZHETRS2 and handle error. * IF( INFO.NE.0 ) $ CALL ALAERH( PATH, 'ZHETRS2', INFO, 0, UPLO, N, @@ -526,6 +568,9 @@ $ NERRS, NOUT ) * CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, $ LDA, RWORK, RESULT( 4 ) ) * @@ -544,7 +589,7 @@ $ RWORK( NRHS+1 ), WORK, $ RWORK( 2*NRHS+1 ), INFO ) * -* Check error code from ZHERFS. +* Check error code from ZHERFS. * IF( INFO.NE.0 ) $ CALL ALAERH( PATH, 'ZHERFS', INFO, 0, UPLO, N, @@ -569,7 +614,10 @@ NFAIL = NFAIL + 1 END IF 120 CONTINUE - NRUN = NRUN + 5 + NRUN = NRUN + 6 +* +* End do for each value of NRHS in NSVAL. +* 130 CONTINUE * *+ TEST 9 @@ -581,7 +629,7 @@ CALL ZHECON( UPLO, N, AFAC, LDA, IWORK, ANORM, RCOND, $ WORK, INFO ) * -* Check error code from ZHECON. +* Check error code from ZHECON and handle error. * IF( INFO.NE.0 ) $ CALL ALAERH( PATH, 'ZHECON', INFO, 0, UPLO, N, N, diff --git a/lapack-netlib/TESTING/LIN/zchkhe_rook.f b/lapack-netlib/TESTING/LIN/zchkhe_rook.f new file mode 100644 index 000000000..0ec8def28 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zchkhe_rook.f @@ -0,0 +1,844 @@ +*> \brief \b ZCHKHE_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCHKHE_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, +* XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZCHKHE_ROOK tests ZHETRF_ROOK, -TRI_ROOK, -TRS_ROOK, +*> and -CON_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is 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. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is CCOMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is CCOMPLEX*16 array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZCHKHE_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, + $ XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NNB, NNS, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION ONEHALF + PARAMETER ( ONEHALF = 0.5D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) + INTEGER NTYPES + PARAMETER ( NTYPES = 10 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) +* .. +* .. Local Scalars .. + LOGICAL TRFCON, ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA, + $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, + $ NRUN, NT + DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, LAM_MAX, LAM_MIN, + $ RCOND, RCONDC, DTEMP +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ), IDUMMY( 1 ) + DOUBLE PRECISION RESULT( NTESTS ) + COMPLEX*16 CDUMMY( 1 ) +* .. +* .. External Functions .. + DOUBLE PRECISION ZLANGE, ZLANHE, DGET06 + EXTERNAL ZLANGE, ZLANHE, DGET06 +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, ZERRHE, ZHEEVX, ZGET04, + $ ZLACPY, ZLARHS, ZLATB4, ZLATMS, ZPOT02, + $ ZPOT03, ZHECON_ROOK, ZHET01_ROOK, ZHETRF_ROOK, + $ ZHETRI_ROOK, ZHETRS_ROOK, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Test path +* + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'HR' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Zomplex precision' + MATPATH( 2: 3 ) = 'HE' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL ZERRHE( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 270 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 260 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 260 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 260 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 250 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with ZLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with ZLATMS. +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from ZLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 250 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = CZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = CZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = CZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = CZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* +* Do for each value of NB in NBVAL +* + DO 240 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'ZHETRF_ROOK' + CALL ZHETRF_ROOK( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from ZHETRF_ROOK and handle error. +* + IF( INFO.NE.K) + $ CALL ALAERH( PATH, 'ZHETRF_ROOK', INFO, K, + $ UPLO, N, N, -1, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Set the condition estimate flag if the INFO is not 0. +* + IF( INFO.NE.0 ) THEN + TRFCON = .TRUE. + ELSE + TRFCON = .FALSE. + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL ZHET01_ROOK( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +*+ TEST 2 +* Form the inverse and compute the residual, +* if the factorization was competed without INFO > 0 +* (i.e. there is no zero rows and columns). +* Do it only for the first block size. +* + IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN + CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + SRNAMT = 'ZHETRI_ROOK' + CALL ZHETRI_ROOK( UPLO, N, AINV, LDA, IWORK, WORK, + $ INFO ) +* +* Check error code from ZHETRI_ROOK and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'ZHETRI_ROOK', INFO, -1, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the residual for a Hermitian matrix times +* its inverse. +* + CALL ZPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, + $ RWORK, RCONDC, RESULT( 2 ) ) + NT = 2 + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +*+ TEST 3 +* Compute largest element in U or L +* + RESULT( 3 ) = ZERO + DTEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) ) / + $ ( ONE-ALPHA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Compute largest element in U +* + K = N + 120 CONTINUE + IF( K.LE.1 ) + $ GO TO 130 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in U +* + DTEMP = ZLANGE( 'M', K-1, 1, + $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k-1 in U +* + DTEMP = ZLANGE( 'M', K-2, 2, + $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK ) + K = K - 1 +* + END IF +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = DTEMP +* + K = K - 1 +* + GO TO 120 + 130 CONTINUE +* + ELSE +* +* Compute largest element in L +* + K = 1 + 140 CONTINUE + IF( K.GE.N ) + $ GO TO 150 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in L +* + DTEMP = ZLANGE( 'M', N-K, 1, + $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k+1 in L +* + DTEMP = ZLANGE( 'M', N-K-1, 2, + $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK ) + K = K + 1 +* + END IF +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = DTEMP +* + K = K + 1 +* + GO TO 140 + 150 CONTINUE + END IF +* +* +*+ TEST 4 +* Compute largest 2-Norm of 2-by-2 diag blocks +* + RESULT( 4 ) = ZERO + DTEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) )* + $ ( ( ONE + ALPHA ) / ( ONE - ALPHA ) ) + CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Loop backward for UPLO = 'U' +* + K = N + 160 CONTINUE + IF( K.LE.1 ) + $ GO TO 170 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two eigenvalues of a 2-by-2 block, +* store them in WORK array +* + CALL ZHEEVX( 'N', 'A', UPLO, 2, + $ AINV( ( K-2 )*LDA+K-1 ), LDA,DTEMP, + $ DTEMP, ITEMP, ITEMP, ZERO, ITEMP, + $ RWORK, CDUMMY, 1, WORK, 16, + $ RWORK( 3 ), IWORK( N+1 ), IDUMMY, + $ INFO ) +* + LAM_MAX = MAX( ABS( RWORK( 1 ) ), + $ ABS( RWORK( 2 ) ) ) + LAM_MIN = MIN( ABS( RWORK( 1 ) ), + $ ABS( RWORK( 2 ) ) ) +* + DTEMP = LAM_MAX / LAM_MIN +* +* DTEMP should be bounded by CONST +* + DTEMP = ABS( DTEMP ) - CONST + THRESH + IF( DTEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = DTEMP + K = K - 1 +* + END IF +* + K = K - 1 +* + GO TO 160 + 170 CONTINUE +* + ELSE +* +* Loop forward for UPLO = 'L' +* + K = 1 + 180 CONTINUE + IF( K.GE.N ) + $ GO TO 190 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two eigenvalues of a 2-by-2 block, +* store them in WORK array +* + CALL ZHEEVX( 'N', 'A', UPLO, 2, + $ AINV( ( K-1 )*LDA+K ), LDA, DTEMP, + $ DTEMP, ITEMP, ITEMP, ZERO, ITEMP, + $ RWORK, CDUMMY, 1, WORK, 16, + $ RWORK( 3 ), IWORK( N+1 ), IDUMMY, + $ INFO ) +* + LAM_MAX = MAX( ABS( RWORK( 1 ) ), + $ ABS( RWORK( 2 ) ) ) + LAM_MIN = MIN( ABS( RWORK( 1 ) ), + $ ABS( RWORK( 2 ) ) ) +* + DTEMP = LAM_MAX / LAM_MIN +* +* DTEMP should be bounded by CONST +* + DTEMP = ABS( DTEMP ) - CONST + THRESH + IF( DTEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = DTEMP + K = K + 1 +* + END IF +* + K = K + 1 +* + GO TO 180 + 190 CONTINUE + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 200 K = 3, 4 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 200 CONTINUE + NRUN = NRUN + 2 +* +* Skip the other tests if this is not the first block +* size. +* + IF( INB.GT.1 ) + $ GO TO 240 +* +* Do only the condition estimate if INFO is not 0. +* + IF( TRFCON ) THEN + RCONDC = ZERO + GO TO 230 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 220 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +* Begin loop over NRHS values +* +* +*+ TEST 5 ( Using TRS_ROOK) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'ZLARHS' + CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'ZHETRS_ROOK' + CALL ZHETRS_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, INFO ) +* +* Check error code from ZHETRS_ROOK and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'ZHETRS_ROOK', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) +* + CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 5 ) ) +* +*+ TEST 6 +* Check solution from generated exact solution. +* + CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 6 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 210 K = 5, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 210 CONTINUE + NRUN = NRUN + 2 +* +* End do for each value of NRHS in NSVAL. +* + 220 CONTINUE +* +*+ TEST 7 +* Get an estimate of RCOND = 1/CNDNUM. +* + 230 CONTINUE + ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK ) + SRNAMT = 'ZHECON_ROOK' + CALL ZHECON_ROOK( UPLO, N, AFAC, LDA, IWORK, ANORM, + $ RCOND, WORK, INFO ) +* +* Check error code from ZHECON_ROOK and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'ZHECON_ROOK', INFO, 0, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the test ratio to compare values of RCOND +* + RESULT( 7 ) = DGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7, + $ RESULT( 7 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 240 CONTINUE +* + 250 CONTINUE + 260 CONTINUE + 270 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of ZCHKHE_ROOK +* + END diff --git a/lapack-netlib/TESTING/LIN/zchksy.f b/lapack-netlib/TESTING/LIN/zchksy.f index df4c6d38c..d656ee221 100644 --- a/lapack-netlib/TESTING/LIN/zchksy.f +++ b/lapack-netlib/TESTING/LIN/zchksy.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, * THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, * XACT, WORK, RWORK, IWORK, NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NNB, NNS, NOUT @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -135,14 +135,12 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is COMPLEX*16 array, dimension -*> (NMAX*max(2,NSMAX)) +*> WORK is COMPLEX*16 array, dimension (NMAX*max(2,NSMAX)) *> \endverbatim *> *> \param[out] RWORK *> \verbatim -*> RWORK is DOUBLE PRECISION array, -*> dimension (NMAX+2*NSMAX) +*> RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NSMAX) *> \endverbatim *> *> \param[out] IWORK @@ -159,12 +157,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup complex16_lin * @@ -173,10 +171,10 @@ $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, $ XACT, WORK, RWORK, IWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -197,7 +195,7 @@ DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) COMPLEX*16 CZERO - PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) INTEGER NTYPES PARAMETER ( NTYPES = 11 ) INTEGER NTESTS @@ -298,11 +296,13 @@ * DO 160 IUPLO = 1, 2 UPLO = UPLOS( IUPLO ) +* +* Begin generate test matrix A. * IF( IMAT.NE.NTYPES ) THEN * -* Set up parameters with ZLATB4 and generate a test -* matrix with ZLATMS. +* Set up parameters with ZLATB4 for the matrix generator +* based on the type of matrix to be generated. * CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, $ MODE, CNDNUM, DIST ) @@ -319,6 +319,9 @@ IF( INFO.NE.0 ) THEN CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* GO TO 160 END IF * @@ -390,18 +393,20 @@ ELSE IZERO = 0 END IF -* -* End generate the test matrix A. * ELSE * -* Use a special block diagonal matrix to test alternate -* code for the 2 x 2 blocks. +* For matrix kind IMAT = 11, generate special block +* diagonal matrix to test alternate code +* for the 2 x 2 blocks. * CALL ZLATSY( UPLO, N, A, LDA, ISEED ) * END IF * +* End generate test matrix A. +* +* * Do for each value of NB in NBVAL * DO 150 INB = 1, NNB @@ -520,6 +525,8 @@ RCONDC = ZERO GO TO 140 END IF +* +* Do for each value of NRHS in NSVAL. * DO 130 IRHS = 1, NNS NRHS = NSVAL( IRHS ) @@ -626,6 +633,9 @@ END IF 120 CONTINUE NRUN = NRUN + 6 +* +* End do for each value of NRHS in NSVAL. +* 130 CONTINUE * *+ TEST 9 @@ -643,7 +653,7 @@ $ CALL ALAERH( PATH, 'ZSYCON', INFO, 0, UPLO, N, N, $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) * -* Compute the test ratio to compare to values of RCOND +* Compute the test ratio to compare values of RCOND * RESULT( 9 ) = DGET06( RCOND, RCONDC ) * diff --git a/lapack-netlib/TESTING/LIN/zchksy_rook.f b/lapack-netlib/TESTING/LIN/zchksy_rook.f new file mode 100644 index 000000000..3b93b6fe6 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zchksy_rook.f @@ -0,0 +1,860 @@ +*> \brief \b ZCHKSY_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, +* XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZCHKSY_ROOK tests ZSYTRF_ROOK, -TRI_ROOK, -TRS_ROOK, +*> and -CON_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is 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. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX)) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, + $ XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NNB, NNS, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION ONEHALF + PARAMETER ( ONEHALF = 0.5D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) + INTEGER NTYPES + PARAMETER ( NTYPES = 11 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) +* .. +* .. Local Scalars .. + LOGICAL TRFCON, ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA, + $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, + $ NRUN, NT + DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, DTEMP, LAM_MAX, + $ LAM_MIN, RCOND, RCONDC +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) + COMPLEX*16 BLOCK( 2, 2 ), ZDUMMY( 1 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DGET06, ZLANGE, ZLANSY + EXTERNAL DGET06, ZLANGE, ZLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, ZERRSY, ZGEEVX, ZGET04, + $ ZLACPY, ZLARHS, ZLATB4, ZLATMS, ZLATSY,ZSYT02, + $ ZSYT03, ZSYCON_ROOK, ZSYT01_ROOK, ZSYTRF_ROOK, + $ ZSYTRI_ROOK, ZSYTRS_ROOK, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Test path +* + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'SR' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Zomplex precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL ZERRSY( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 270 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 260 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 260 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 260 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 250 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate test matrix A. +* + IF( IMAT.NE.NTYPES ) THEN +* +* Set up parameters with ZLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with ZLATMS. +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from ZLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 250 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = CZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = CZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = CZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = CZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* + ELSE +* +* For matrix kind IMAT = 11, generate special block +* diagonal matrix to test alternate code +* for the 2 x 2 blocks. +* + CALL ZLATSY( UPLO, N, A, LDA, ISEED ) +* + END IF +* +* End generate test matrix A. +* +* +* Do for each value of NB in NBVAL +* + DO 240 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'ZSYTRF_ROOK' + CALL ZSYTRF_ROOK( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from ZSYTRF_ROOK and handle error. +* + IF( INFO.NE.K) + $ CALL ALAERH( PATH, 'ZSYTRF_ROOK', INFO, K, + $ UPLO, N, N, -1, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Set the condition estimate flag if the INFO is not 0. +* + IF( INFO.NE.0 ) THEN + TRFCON = .TRUE. + ELSE + TRFCON = .FALSE. + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL ZSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +*+ TEST 2 +* Form the inverse and compute the residual, +* if the factorization was competed without INFO > 0 +* (i.e. there is no zero rows and columns). +* Do it only for the first block size. +* + IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN + CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + SRNAMT = 'ZSYTRI_ROOK' + CALL ZSYTRI_ROOK( UPLO, N, AINV, LDA, IWORK, WORK, + $ INFO ) +* +* Check error code from ZSYTRI_ROOK and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'ZSYTRI_ROOK', INFO, -1, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the residual for a symmetric matrix times +* its inverse. +* + CALL ZSYT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, + $ RWORK, RCONDC, RESULT( 2 ) ) + NT = 2 + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +*+ TEST 3 +* Compute largest element in U or L +* + RESULT( 3 ) = ZERO + DTEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) ) / + $ ( ONE-ALPHA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Compute largest element in U +* + K = N + 120 CONTINUE + IF( K.LE.1 ) + $ GO TO 130 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in U +* + DTEMP = ZLANGE( 'M', K-1, 1, + $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k-1 in U +* + DTEMP = ZLANGE( 'M', K-2, 2, + $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK ) + K = K - 1 +* + END IF +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = DTEMP +* + K = K - 1 +* + GO TO 120 + 130 CONTINUE +* + ELSE +* +* Compute largest element in L +* + K = 1 + 140 CONTINUE + IF( K.GE.N ) + $ GO TO 150 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in L +* + DTEMP = ZLANGE( 'M', N-K, 1, + $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k+1 in L +* + DTEMP = ZLANGE( 'M', N-K-1, 2, + $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK ) + K = K + 1 +* + END IF +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = DTEMP +* + K = K + 1 +* + GO TO 140 + 150 CONTINUE + END IF +* +* +*+ TEST 4 +* Compute largest 2-Norm of 2-by-2 diag blocks +* + RESULT( 4 ) = ZERO + DTEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) )* + $ ( ( ONE + ALPHA ) / ( ONE - ALPHA ) ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Loop backward for UPLO = 'U' +* + K = N + 160 CONTINUE + IF( K.LE.1 ) + $ GO TO 170 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two eigenvalues of a 2-by-2 block, +* store them in WORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 ) + BLOCK( 2, 1 ) = AFAC( ( K-2 )*LDA+K ) + BLOCK( 1, 2 ) = BLOCK( 2, 1 ) + BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K ) +* + CALL ZGEEVX( 'N', 'N', 'N', 'N', 2, BLOCK, + $ 2, WORK, ZDUMMY, 1, ZDUMMY, 1, + $ ITEMP, ITEMP2, RWORK, DTEMP, + $ RWORK( 3 ), RWORK( 5 ), WORK( 3 ), + $ 4, RWORK( 7 ), INFO ) +* + LAM_MAX = MAX( ABS( WORK( 1 ) ), + $ ABS( WORK( 2 ) ) ) + LAM_MIN = MIN( ABS( WORK( 1 ) ), + $ ABS( WORK( 2 ) ) ) +* + DTEMP = LAM_MAX / LAM_MIN +* +* DTEMP should be bounded by CONST +* + DTEMP = ABS( DTEMP ) - CONST + THRESH + IF( DTEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = DTEMP + K = K - 1 +* + END IF +* + K = K - 1 +* + GO TO 160 + 170 CONTINUE +* + ELSE +* +* Loop forward for UPLO = 'L' +* + K = 1 + 180 CONTINUE + IF( K.GE.N ) + $ GO TO 190 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two eigenvalues of a 2-by-2 block, +* store them in WORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K ) + BLOCK( 2, 1 ) = AFAC( ( K-1 )*LDA+K+1 ) + BLOCK( 1, 2 ) = BLOCK( 2, 1 ) + BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 ) +* + CALL ZGEEVX( 'N', 'N', 'N', 'N', 2, BLOCK, + $ 2, WORK, ZDUMMY, 1, ZDUMMY, 1, + $ ITEMP, ITEMP2, RWORK, DTEMP, + $ RWORK( 3 ), RWORK( 5 ), WORK( 3 ), + $ 4, RWORK( 7 ), INFO ) +* + LAM_MAX = MAX( ABS( WORK( 1 ) ), + $ ABS( WORK( 2 ) ) ) + LAM_MIN = MIN( ABS( WORK( 1 ) ), + $ ABS( WORK( 2 ) ) ) +* + DTEMP = LAM_MAX / LAM_MIN +* +* DTEMP should be bounded by CONST +* + DTEMP = ABS( DTEMP ) - CONST + THRESH + IF( DTEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = DTEMP + K = K + 1 +* + END IF +* + K = K + 1 +* + GO TO 180 + 190 CONTINUE + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 200 K = 3, 4 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 200 CONTINUE + NRUN = NRUN + 2 +* +* Skip the other tests if this is not the first block +* size. +* + IF( INB.GT.1 ) + $ GO TO 240 +* +* Do only the condition estimate if INFO is not 0. +* + IF( TRFCON ) THEN + RCONDC = ZERO + GO TO 230 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 220 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 5 ( Using TRS_ROOK) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'ZLARHS' + CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'ZSYTRS_ROOK' + CALL ZSYTRS_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, INFO ) +* +* Check error code from ZSYTRS_ROOK and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'ZSYTRS_ROOK', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) +* + CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL ZSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 5 ) ) +* +*+ TEST 6 +* Check solution from generated exact solution. +* + CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 6 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 210 K = 5, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 210 CONTINUE + NRUN = NRUN + 2 +* +* End do for each value of NRHS in NSVAL. +* + 220 CONTINUE +* +*+ TEST 7 +* Get an estimate of RCOND = 1/CNDNUM. +* + 230 CONTINUE + ANORM = ZLANSY( '1', UPLO, N, A, LDA, RWORK ) + SRNAMT = 'ZSYCON_ROOK' + CALL ZSYCON_ROOK( UPLO, N, AFAC, LDA, IWORK, ANORM, + $ RCOND, WORK, INFO ) +* +* Check error code from ZSYCON_ROOK and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'ZSYCON_ROOK', INFO, 0, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the test ratio to compare values of RCOND +* + RESULT( 7 ) = DGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7, + $ RESULT( 7 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 240 CONTINUE +* + 250 CONTINUE + 260 CONTINUE + 270 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test(', I2, ') =', G12.5 ) + 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, + $ ', test(', I2, ') =', G12.5 ) + RETURN +* +* End of ZCHKSY_ROOK +* + END diff --git a/lapack-netlib/TESTING/LIN/zdrvhe.f b/lapack-netlib/TESTING/LIN/zdrvhe.f index 7c9fd7c7e..ba8f28fa9 100644 --- a/lapack-netlib/TESTING/LIN/zdrvhe.f +++ b/lapack-netlib/TESTING/LIN/zdrvhe.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZDRVHE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,8 +117,7 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is COMPLEX*16 array, dimension -*> (NMAX*max(2,NRHS)) +*> WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS)) *> \endverbatim *> *> \param[out] RWORK @@ -140,12 +139,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex16_lin * @@ -154,10 +153,10 @@ $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -226,7 +225,7 @@ * * Initialize constants and the random number seed. * - PATH( 1: 1 ) = 'Z' + PATH( 1: 1 ) = 'Zomplex precision' PATH( 2: 3 ) = 'HE' NRUN = 0 NFAIL = 0 diff --git a/lapack-netlib/TESTING/LIN/zdrvhe_rook.f b/lapack-netlib/TESTING/LIN/zdrvhe_rook.f new file mode 100644 index 000000000..70fed11dd --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zdrvhe_rook.f @@ -0,0 +1,528 @@ +*> \brief \b ZDRVHE_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZDRVHE_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, +* NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, +* IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDRVHE_ROOK tests the driver routines ZHESV_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is 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. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZDRVHE_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NOUT, NRHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 MATPATH, PATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCONDC +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) + +* .. +* .. External Functions .. + DOUBLE PRECISION ZLANHE + EXTERNAL ZLANHE +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, ZERRVX, + $ ZGET04, ZLACPY, ZLARHS, ZLATB4, ZLATMS, + $ ZHESV_ROOK, ZHET01_ROOK, ZPOT02, + $ ZHETRF_ROOK, ZHETRI_ROOK +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'HR' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Zomplex precision' + MATPATH( 2: 3 ) = 'HE' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL ZERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for which the block +* routine should be used, which will be later returned by ILAENV. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with ZLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with ZLATMS. +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from ZLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of +* the matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Compute the condition number for comparison with +* the value returned by ZHESVX_ROOK. +* + IF( ZEROT ) THEN + IF( IFACT.EQ.1 ) + $ GO TO 150 + RCONDC = ZERO +* + ELSE IF( IFACT.EQ.1 ) THEN +* +* Compute the 1-norm of A. +* + ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* + + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL ZHETRF_ROOK( UPLO, N, AFAC, LDA, IWORK, WORK, + $ LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* + CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + LWORK = (N+NB+1)*(NB+3) + CALL ZHETRI_ROOK( UPLO, N, AINV, LDA, IWORK, + $ WORK, INFO ) + AINVNM = ZLANHE( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'ZLARHS' + CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test ZHESV_ROOK --- +* + IF( IFACT.EQ.2 ) THEN + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using +* ZHESV_ROOK. +* + SRNAMT = 'ZHESV_ROOK' + CALL ZHESV_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from ZHESV_ROOK and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'ZHESV_ROOK', INFO, K, UPLO, + $ N, N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +*+ TEST 1 Reconstruct matrix from factors and compute +* residual. +* + CALL ZHET01_ROOK( UPLO, N, A, LDA, AFAC, LDA, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +*+ TEST 2 Compute residual of the computed solution. +* + CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +*+ TEST 3 +* Check solution from generated exact solution. +* + CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 3 ) ) + NT = 3 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'ZHESV_ROOK', UPLO, + $ N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of ZDRVHE_ROOK +* + END diff --git a/lapack-netlib/TESTING/LIN/zdrvpox.f b/lapack-netlib/TESTING/LIN/zdrvpox.f index 7613117a5..3242f08eb 100644 --- a/lapack-netlib/TESTING/LIN/zdrvpox.f +++ b/lapack-netlib/TESTING/LIN/zdrvpox.f @@ -153,7 +153,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex16_lin * @@ -162,10 +162,10 @@ $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, $ RWORK, NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. LOGICAL TSTERR @@ -530,11 +530,12 @@ * * Check the error code from ZPOSVX. * - IF( INFO.NE.IZERO ) - $ CALL ALAERH( PATH, 'ZPOSVX', INFO, IZERO, + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'ZPOSVX', INFO, IZERO, $ FACT // UPLO, N, N, -1, -1, NRHS, $ IMAT, NFAIL, NERRS, NOUT ) GO TO 90 + END IF * IF( INFO.EQ.0 ) THEN IF( .NOT.PREFAC ) THEN diff --git a/lapack-netlib/TESTING/LIN/zdrvrfp.f b/lapack-netlib/TESTING/LIN/zdrvrfp.f index 6efc625c3..e101abafa 100644 --- a/lapack-netlib/TESTING/LIN/zdrvrfp.f +++ b/lapack-netlib/TESTING/LIN/zdrvrfp.f @@ -232,7 +232,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex16_lin * @@ -244,10 +244,10 @@ + Z_WORK_ZPOT03, D_WORK_ZLATMS, D_WORK_ZLANHE, + D_WORK_ZPOT01, D_WORK_ZPOT02, D_WORK_ZPOT03 ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. INTEGER NN, NNS, NNT, NOUT @@ -345,7 +345,7 @@ * * If N.EQ.0, only consider the first type * - IF( N.EQ.0 .AND. IIT.GT.1 ) GO TO 120 + IF( N.EQ.0 .AND. IIT.GE.1 ) GO TO 120 * * Skip types 3, 4, or 5 if the matrix size is too small. * @@ -449,16 +449,19 @@ * Form the inverse of A. * CALL ZPOTRI( UPLO, N, A, LDA, INFO ) + + IF ( N .NE. 0 ) THEN * -* Compute the 1-norm condition number of A. +* Compute the 1-norm condition number of A. * - AINVNM = ZLANHE( '1', UPLO, N, A, LDA, + AINVNM = ZLANHE( '1', UPLO, N, A, LDA, + D_WORK_ZLANHE ) - RCONDC = ( ONE / ANORM ) / AINVNM + RCONDC = ( ONE / ANORM ) / AINVNM * -* Restore the matrix A. +* Restore the matrix A. * - CALL ZLACPY( UPLO, N, N, ASAV, LDA, A, LDA ) + CALL ZLACPY( UPLO, N, N, ASAV, LDA, A, LDA ) + END IF * END IF * diff --git a/lapack-netlib/TESTING/LIN/zdrvsy.f b/lapack-netlib/TESTING/LIN/zdrvsy.f index 5fa0e64ee..5e0c60e23 100644 --- a/lapack-netlib/TESTING/LIN/zdrvsy.f +++ b/lapack-netlib/TESTING/LIN/zdrvsy.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -11,7 +11,7 @@ * SUBROUTINE ZDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, * A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, * NOUT ) -* +* * .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NMAX, NN, NOUT, NRHS @@ -24,7 +24,7 @@ * COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), * $ WORK( * ), X( * ), XACT( * ) * .. -* +* * *> \par Purpose: * ============= @@ -117,8 +117,7 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is COMPLEX*16 array, dimension -*> (NMAX*max(2,NRHS)) +*> WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS)) *> \endverbatim *> *> \param[out] RWORK @@ -140,12 +139,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex16_lin * @@ -154,10 +153,10 @@ $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, $ NOUT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. LOGICAL TSTERR diff --git a/lapack-netlib/TESTING/LIN/zdrvsy_rook.f b/lapack-netlib/TESTING/LIN/zdrvsy_rook.f new file mode 100644 index 000000000..0718a9838 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zdrvsy_rook.f @@ -0,0 +1,534 @@ +*> \brief \b ZDRVSY_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, +* NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, +* IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDRVSY_ROOK tests the driver routines ZSYSV_ROOK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is 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. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZDRVSY_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NOUT, NRHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 11, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 MATPATH, PATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCONDC +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) + +* .. +* .. External Functions .. + DOUBLE PRECISION ZLANSY + EXTERNAL ZLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, ZERRVX, ZGET04, + $ ZLACPY, ZLARHS, ZLASET, ZLATB4, ZLATMS, ZLATSY, + $ ZPOT05, ZSYSV_ROOK, ZSYT01_ROOK, ZSYT02, + $ ZSYTRF_ROOK, ZSYTRI_ROOK +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'SR' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Zomplex precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL ZERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for which the block +* routine should be used, which will be later returned by ILAENV. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* + IF( IMAT.NE.NTYPES ) THEN +* +* Begin generate the test matrix A. +* +* Set up parameters with ZLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with ZLATMS. +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from DLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of +* the matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF + ELSE +* +* IMAT = NTYPES: Use a special block diagonal matrix to +* test alternate code for the 2-by-2 blocks. +* + CALL ZLATSY( UPLO, N, A, LDA, ISEED ) + END IF +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Compute the condition number for comparison with +* the value returned by ZSYSVX_ROOK. +* + IF( ZEROT ) THEN + IF( IFACT.EQ.1 ) + $ GO TO 150 + RCONDC = ZERO +* + ELSE IF( IFACT.EQ.1 ) THEN +* +* Compute the 1-norm of A. +* + ANORM = ZLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* + + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL ZSYTRF_ROOK( UPLO, N, AFAC, LDA, IWORK, WORK, + $ LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* + CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + LWORK = (N+NB+1)*(NB+3) + CALL ZSYTRI_ROOK( UPLO, N, AINV, LDA, IWORK, + $ WORK, INFO ) + AINVNM = ZLANSY( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'ZLARHS' + CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test ZSYSV_ROOK --- +* + IF( IFACT.EQ.2 ) THEN + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using +* ZSYSV_ROOK. +* + SRNAMT = 'ZSYSV_ROOK' + CALL ZSYSV_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from ZSYSV_ROOK and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'ZSYSV_ROOK', INFO, K, UPLO, + $ N, N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +*+ TEST 1 Reconstruct matrix from factors and compute +* residual. +* + CALL ZSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDA, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +*+ TEST 2 Compute residual of the computed solution. +* + CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL ZSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +*+ TEST 3 +* Check solution from generated exact solution. +* + CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 3 ) ) + NT = 3 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'ZSYSV_ROOK', UPLO, + $ N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of ZDRVSY_ROOK +* + END diff --git a/lapack-netlib/TESTING/LIN/zerrhe.f b/lapack-netlib/TESTING/LIN/zerrhe.f index 4d88e7388..600662889 100644 --- a/lapack-netlib/TESTING/LIN/zerrhe.f +++ b/lapack-netlib/TESTING/LIN/zerrhe.f @@ -2,19 +2,19 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZERRHE( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -43,22 +43,22 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRHE( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -88,9 +88,11 @@ EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHKXER, ZHECON, ZHERFS, ZHETF2, ZHETRF, - $ ZHETRI, ZHETRI2, ZHETRS, ZHPCON, ZHPRFS, - $ ZHPTRF, ZHPTRI, ZHPTRS + EXTERNAL ALAESM, CHKXER, ZHECON, ZHECON_ROOK, ZHERFS, + $ ZHETF2, ZHETF2_ROOK, ZHETRF, ZHETRF_ROOK, + $ ZHETRI, ZHETRI_ROOK, ZHETRI2, ZHETRS, + $ ZHETRS_ROOK, ZHPCON, ZHPRFS, ZHPTRF, ZHPTRI, + $ ZHPTRS * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -129,8 +131,9 @@ ANRM = 1.0D0 OK = .TRUE. * -* Test error exits of the routines that use the diagonal pivoting -* factorization of a Hermitian indefinite matrix. +* Test error exits of the routines that use factorization +* of a Hermitian indefinite matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. * IF( LSAMEN( 2, C2, 'HE' ) ) THEN * @@ -253,8 +256,89 @@ CALL ZHECON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'ZHECON', INFOT, NOUT, LERR, OK ) * -* Test error exits of the routines that use the diagonal pivoting -* factorization of a Hermitian indefinite packed matrix. +* Test error exits of the routines that use factorization +* of a Hermitian indefinite matrix with "rook" +* (bounded Bunch-Kaufman) diagonal pivoting method. +* + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN +* +* ZHETRF_ROOK +* + SRNAMT = 'ZHETRF_ROOK' + INFOT = 1 + CALL ZHETRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) + CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK ) +* +* ZHETF2_ROOK +* + SRNAMT = 'ZHETF2_ROOK' + INFOT = 1 + CALL ZHETF2_ROOK( '/', 0, A, 1, IP, INFO ) + CALL CHKXER( 'ZHETF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETF2_ROOK( 'U', -1, A, 1, IP, INFO ) + CALL CHKXER( 'ZHETF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETF2_ROOK( 'U', 2, A, 1, IP, INFO ) + CALL CHKXER( 'ZHETF2_ROOK', INFOT, NOUT, LERR, OK ) +* +* ZHETRI_ROOK +* + SRNAMT = 'ZHETRI_ROOK' + INFOT = 1 + CALL ZHETRI_ROOK( '/', 0, A, 1, IP, W, INFO ) + CALL CHKXER( 'ZHETRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRI_ROOK( 'U', -1, A, 1, IP, W, INFO ) + CALL CHKXER( 'ZHETRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRI_ROOK( 'U', 2, A, 1, IP, W, INFO ) + CALL CHKXER( 'ZHETRI_ROOK', INFOT, NOUT, LERR, OK ) +* +* ZHETRS_ROOK +* + SRNAMT = 'ZHETRS_ROOK' + INFOT = 1 + CALL ZHETRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHETRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHETRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO ) + CALL CHKXER( 'ZHETRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHETRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_ROOK', INFOT, NOUT, LERR, OK ) +* +* ZHECON_ROOK +* + SRNAMT = 'ZHECON_ROOK' + INFOT = 1 + CALL ZHECON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZHECON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHECON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZHECON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHECON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZHECON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZHECON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZHECON_ROOK', INFOT, NOUT, LERR, OK ) +* +* Test error exits of the routines that use factorization +* of a Hermitian indefinite packed matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. * ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/zerrhex.f b/lapack-netlib/TESTING/LIN/zerrhex.f index 7dafede06..49c07df1d 100644 --- a/lapack-netlib/TESTING/LIN/zerrhex.f +++ b/lapack-netlib/TESTING/LIN/zerrhex.f @@ -51,17 +51,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRHE( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -94,9 +94,11 @@ EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHKXER, ZHECON, ZHERFS, ZHETF2, ZHETRF, - $ ZHETRI, ZHETRI2, ZHETRS, ZHPCON, ZHPRFS, - $ ZHPTRF, ZHPTRI, ZHPTRS, ZHERFSX + EXTERNAL ALAESM, CHKXER, ZHECON, ZHECON_ROOK, ZHERFS, + $ ZHETF2, ZHETF2_ROOK, ZHETRF, ZHETRF_ROOK, + $ ZHETRI, ZHETRI_ROOK, ZHETRI2, ZHETRS, + $ ZHETRS_ROOK, ZHPCON, ZHPRFS, ZHPTRF, ZHPTRI, + $ ZHPTRS, ZHERFSX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -136,8 +138,9 @@ ANRM = 1.0D0 OK = .TRUE. * -* Test error exits of the routines that use the diagonal pivoting -* factorization of a Hermitian indefinite matrix. +* Test error exits of the routines that use factorization +* of a Hermitian indefinite matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. * IF( LSAMEN( 2, C2, 'HE' ) ) THEN * @@ -307,8 +310,89 @@ CALL ZHECON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'ZHECON', INFOT, NOUT, LERR, OK ) * -* Test error exits of the routines that use the diagonal pivoting -* factorization of a Hermitian indefinite packed matrix. +* Test error exits of the routines that use factorization +* of a Hermitian indefinite matrix with "rook" +* (bounded Bunch-Kaufman) diagonal pivoting method. +* + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN +* +* ZHETRF_ROOK +* + SRNAMT = 'ZHETRF_ROOK' + INFOT = 1 + CALL ZHETRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) + CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK ) +* +* ZHETF2_ROOK +* + SRNAMT = 'ZHETF2_ROOK' + INFOT = 1 + CALL ZHETF2_ROOK( '/', 0, A, 1, IP, INFO ) + CALL CHKXER( 'ZHETF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETF2_ROOK( 'U', -1, A, 1, IP, INFO ) + CALL CHKXER( 'ZHETF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETF2_ROOK( 'U', 2, A, 1, IP, INFO ) + CALL CHKXER( 'ZHETF2_ROOK', INFOT, NOUT, LERR, OK ) +* +* ZHETRI_ROOK +* + SRNAMT = 'ZHETRI_ROOK' + INFOT = 1 + CALL ZHETRI_ROOK( '/', 0, A, 1, IP, W, INFO ) + CALL CHKXER( 'ZHETRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRI_ROOK( 'U', -1, A, 1, IP, W, INFO ) + CALL CHKXER( 'ZHETRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRI_ROOK( 'U', 2, A, 1, IP, W, INFO ) + CALL CHKXER( 'ZHETRI_ROOK', INFOT, NOUT, LERR, OK ) +* +* ZHETRS_ROOK +* + SRNAMT = 'ZHETRS_ROOK' + INFOT = 1 + CALL ZHETRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHETRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHETRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO ) + CALL CHKXER( 'ZHETRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHETRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_ROOK', INFOT, NOUT, LERR, OK ) +* +* ZHECON_ROOK +* + SRNAMT = 'ZHECON_ROOK' + INFOT = 1 + CALL ZHECON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZHECON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHECON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZHECON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHECON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZHECON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZHECON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZHECON_ROOK', INFOT, NOUT, LERR, OK ) +* +* Test error exits of the routines that use factorization +* of a Hermitian indefinite packed matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. * ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/zerrsy.f b/lapack-netlib/TESTING/LIN/zerrsy.f index b6bc4b048..a9126a12f 100644 --- a/lapack-netlib/TESTING/LIN/zerrsy.f +++ b/lapack-netlib/TESTING/LIN/zerrsy.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -88,8 +88,9 @@ * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, ZSPCON, ZSPRFS, ZSPTRF, ZSPTRI, - $ ZSPTRS, ZSYCON, ZSYRFS, ZSYTF2, ZSYTRF, ZSYTRI, - $ ZSYTRI2, ZSYTRS + $ ZSPTRS, ZSYCON, ZSYCON_ROOK, ZSYRFS, ZSYTF2, + $ ZSYTF2_ROOK, ZSYTRF, ZSYTRF_ROOK, ZSYTRI, + $ ZSYTRI_ROOK, ZSYTRI2, ZSYTRS, ZSYTRS_ROOK * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -128,11 +129,11 @@ ANRM = 1.0D0 OK = .TRUE. * - IF( LSAMEN( 2, C2, 'SY' ) ) THEN +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. * -* Test error exits of the routines that use factorization -* of a symmetric indefinite matrix with patrial -* (Bunch-Kaufman) pivoting. + IF( LSAMEN( 2, C2, 'SY' ) ) THEN * * ZSYTRF * @@ -253,11 +254,91 @@ CALL ZSYCON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'ZSYCON', INFOT, NOUT, LERR, OK ) * - ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with "rook" +* (bounded Bunch-Kaufman) diagonal pivoting method. +* + ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN +* +* ZSYTRF_ROOK +* + SRNAMT = 'ZSYTRF_ROOK' + INFOT = 1 + CALL ZSYTRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) + CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK ) +* +* ZSYTF2_ROOK +* + SRNAMT = 'ZSYTF2_ROOK' + INFOT = 1 + CALL ZSYTF2_ROOK( '/', 0, A, 1, IP, INFO ) + CALL CHKXER( 'ZSYTF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTF2_ROOK( 'U', -1, A, 1, IP, INFO ) + CALL CHKXER( 'ZSYTF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTF2_ROOK( 'U', 2, A, 1, IP, INFO ) + CALL CHKXER( 'ZSYTF2_ROOK', INFOT, NOUT, LERR, OK ) +* +* ZSYTRI_ROOK +* + SRNAMT = 'ZSYTRI_ROOK' + INFOT = 1 + CALL ZSYTRI_ROOK( '/', 0, A, 1, IP, W, INFO ) + CALL CHKXER( 'ZSYTRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRI_ROOK( 'U', -1, A, 1, IP, W, INFO ) + CALL CHKXER( 'ZSYTRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTRI_ROOK( 'U', 2, A, 1, IP, W, INFO ) + CALL CHKXER( 'ZSYTRI_ROOK', INFOT, NOUT, LERR, OK ) +* +* ZSYTRS_ROOK +* + SRNAMT = 'ZSYTRS_ROOK' + INFOT = 1 + CALL ZSYTRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZSYTRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZSYTRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO ) + CALL CHKXER( 'ZSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZSYTRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_ROOK', INFOT, NOUT, LERR, OK ) +* +* ZSYCON_ROOK +* + SRNAMT = 'ZSYCON_ROOK' + INFOT = 1 + CALL ZSYCON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYCON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYCON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZSYCON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZSYCON_ROOK', INFOT, NOUT, LERR, OK ) * * Test error exits of the routines that use factorization * of a symmetric indefinite packed matrix with patrial * (Bunch-Kaufman) pivoting. +* + ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * * ZSPTRF * diff --git a/lapack-netlib/TESTING/LIN/zerrsyx.f b/lapack-netlib/TESTING/LIN/zerrsyx.f index 3da57aea1..601c6ab63 100644 --- a/lapack-netlib/TESTING/LIN/zerrsyx.f +++ b/lapack-netlib/TESTING/LIN/zerrsyx.f @@ -51,17 +51,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -94,8 +94,10 @@ * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, ZSPCON, ZSPRFS, ZSPTRF, ZSPTRI, - $ ZSPTRS, ZSYCON, ZSYRFS, ZSYTF2, ZSYTRF, ZSYTRI, - $ ZSYTRI2, ZSYTRS, ZSYRFSX + $ ZSPTRS, ZSYCON, ZSYCON_ROOK, ZSYRFS, ZSYTF2, + $ ZSYTF2_ROOK, ZSYTRF, ZSYTRF_ROOK, ZSYTRI, + $ ZSYTRI_ROOK, ZSYTRI2, ZSYTRS, ZSYTRS_ROOK, + $ ZSYRFSX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -135,8 +137,9 @@ ANRM = 1.0D0 OK = .TRUE. * -* Test error exits of the routines that use the diagonal pivoting -* factorization of a symmetric indefinite matrix. +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. * IF( LSAMEN( 2, C2, 'SY' ) ) THEN * @@ -306,8 +309,89 @@ CALL ZSYCON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'ZSYCON', INFOT, NOUT, LERR, OK ) * -* Test error exits of the routines that use the diagonal pivoting -* factorization of a symmetric indefinite packed matrix. +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with "rook" +* (bounded Bunch-Kaufman) diagonal pivoting method. +* + ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN +* +* ZSYTRF_ROOK +* + SRNAMT = 'ZSYTRF_ROOK' + INFOT = 1 + CALL ZSYTRF_ROOK( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRF_ROOK( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) + CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK ) +* +* ZSYTF2_ROOK +* + SRNAMT = 'ZSYTF2_ROOK' + INFOT = 1 + CALL ZSYTF2_ROOK( '/', 0, A, 1, IP, INFO ) + CALL CHKXER( 'ZSYTF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTF2_ROOK( 'U', -1, A, 1, IP, INFO ) + CALL CHKXER( 'ZSYTF2_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTF2_ROOK( 'U', 2, A, 1, IP, INFO ) + CALL CHKXER( 'ZSYTF2_ROOK', INFOT, NOUT, LERR, OK ) +* +* ZSYTRI_ROOK +* + SRNAMT = 'ZSYTRI_ROOK' + INFOT = 1 + CALL ZSYTRI_ROOK( '/', 0, A, 1, IP, W, INFO ) + CALL CHKXER( 'ZSYTRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRI_ROOK( 'U', -1, A, 1, IP, W, INFO ) + CALL CHKXER( 'ZSYTRI_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTRI_ROOK( 'U', 2, A, 1, IP, W, INFO ) + CALL CHKXER( 'ZSYTRI_ROOK', INFOT, NOUT, LERR, OK ) +* +* ZSYTRS_ROOK +* + SRNAMT = 'ZSYTRS_ROOK' + INFOT = 1 + CALL ZSYTRS_ROOK( '/', 0, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRS_ROOK( 'U', -1, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZSYTRS_ROOK( 'U', 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZSYTRS_ROOK( 'U', 2, 1, A, 1, IP, B, 2, INFO ) + CALL CHKXER( 'ZSYTRS_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZSYTRS_ROOK( 'U', 2, 1, A, 2, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_ROOK', INFOT, NOUT, LERR, OK ) +* +* ZSYCON_ROOK +* + SRNAMT = 'ZSYCON_ROOK' + INFOT = 1 + CALL ZSYCON_ROOK( '/', 0, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYCON_ROOK( 'U', -1, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYCON_ROOK( 'U', 2, A, 1, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZSYCON_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZSYCON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZSYCON_ROOK', INFOT, NOUT, LERR, OK ) +* +* Test error exits of the routines that use factorization +* of a symmetric indefinite packed matrix with patrial +* (Bunch-Kaufman) pivoting. * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/zerrvx.f b/lapack-netlib/TESTING/LIN/zerrvx.f index ddbb90707..057bf872b 100644 --- a/lapack-netlib/TESTING/LIN/zerrvx.f +++ b/lapack-netlib/TESTING/LIN/zerrvx.f @@ -2,8 +2,8 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRVX( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -90,10 +90,10 @@ * .. * .. External Subroutines .. EXTERNAL CHKXER, ZGBSV, ZGBSVX, ZGESV, ZGESVX, ZGTSV, - $ ZGTSVX, ZHESV, ZHESVX, ZHPSV, ZHPSVX, ZPBSV, - $ ZPBSVX, ZPOSV, ZPOSVX, ZPPSV, ZPPSVX, ZPTSV, - $ ZPTSVX, ZSPSV, ZSPSVX, ZSYSV, - $ ZSYSVX + $ ZGTSVX, ZHESV, ZHESV_ROOK, ZHESVX, ZHPSV, + $ ZHPSVX, ZPBSV, ZPBSVX, ZPOSV, ZPOSVX, ZPPSV, + $ ZPPSVX, ZPTSV, ZPTSVX, ZSPSV, ZSPSVX, ZSYSV, + $ ZSYSV_ROOK, ZSYSVX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -633,6 +633,24 @@ CALL ZHESVX( 'N', 'U', 2, 0, A, 2, AF, 2, IP, B, 2, X, 2, $ RCOND, R1, R2, W, 3, RW, INFO ) CALL CHKXER( 'ZHESVX', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN +* +* ZHESV_ROOK +* + SRNAMT = 'ZHESV_ROOK' + INFOT = 1 + CALL ZHESV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHESV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHESV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * @@ -737,6 +755,24 @@ CALL ZSYSVX( 'N', 'U', 2, 0, A, 2, AF, 2, IP, B, 2, X, 2, $ RCOND, R1, R2, W, 3, RW, INFO ) CALL CHKXER( 'ZSYSVX', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN +* +* ZSYSV_ROOK +* + SRNAMT = 'ZSYSV_ROOK' + INFOT = 1 + CALL ZSYSV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYSV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZSYSV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/zerrvxx.f b/lapack-netlib/TESTING/LIN/zerrvxx.f index 09bc746d5..c974c3b42 100644 --- a/lapack-netlib/TESTING/LIN/zerrvxx.f +++ b/lapack-netlib/TESTING/LIN/zerrvxx.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRVX( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -91,10 +91,11 @@ * .. * .. External Subroutines .. EXTERNAL CHKXER, ZGBSV, ZGBSVX, ZGESV, ZGESVX, ZGTSV, - $ ZGTSVX, ZHESV, ZHESVX, ZHPSV, ZHPSVX, ZPBSV, - $ ZPBSVX, ZPOSV, ZPOSVX, ZPPSV, ZPPSVX, ZPTSV, - $ ZPTSVX, ZSPSV, ZSPSVX, ZSYSV, ZSYSVX, ZGESVXX, - $ ZSYSVXX, ZPOSVXX, ZHESVXX, ZGBSVXX + $ ZGTSVX, ZHESV, ZHESV_ROOK, ZHESVX, ZHPSV, + $ ZHPSVX, ZPBSV, ZPBSVX, ZPOSV, ZPOSVX, ZPPSV, + $ ZPPSVX, ZPTSV, ZPTSVX, ZSPSV, ZSPSVX, ZSYSV, + $ ZSYSV_ROOK, ZSYSVX, ZGESVXX, ZSYSVXX, ZPOSVXX, + $ ZHESVXX, ZGBSVXX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -499,6 +500,24 @@ $ AF( 1, 1 ), AF( 1, 2 ), AF( 1, 3 ), AF( 1, 4 ), $ IP, B, 2, X, 1, RCOND, R1, R2, W, RW, INFO ) CALL CHKXER( 'ZGTSVX', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN +* +* ZHESV_ROOK +* + SRNAMT = 'ZHESV_ROOK' + INFOT = 1 + CALL ZHESV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHESV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHESV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'PO' ) ) THEN * @@ -912,6 +931,24 @@ $ 1, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_N, $ ERR_BNDS_C, NPARAMS, PARAMS, W, RW, INFO ) CALL CHKXER( 'ZHESVXX', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN +* +* ZHESV_ROOK +* + SRNAMT = 'ZHESV_ROOK' + INFOT = 1 + CALL ZHESV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHESV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHESV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * @@ -1066,6 +1103,25 @@ $ 1, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_N, $ ERR_BNDS_C, NPARAMS, PARAMS, W, RW, INFO ) CALL CHKXER( 'ZSYSVXX', INFOT, NOUT, LERR, OK ) + CALL CHKXER( 'ZSYSVX', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN +* +* ZSYSV_ROOK +* + SRNAMT = 'ZSYSV_ROOK' + INFOT = 1 + CALL ZSYSV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYSV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZSYSV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/zhet01.f b/lapack-netlib/TESTING/LIN/zhet01.f index 5b3ecee37..b8ec93ac9 100644 --- a/lapack-netlib/TESTING/LIN/zhet01.f +++ b/lapack-netlib/TESTING/LIN/zhet01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZHET01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDAFAC, LDC, N @@ -21,7 +21,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ) * .. -* +* * *> \par Purpose: * ============= @@ -113,12 +113,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex16_lin * @@ -126,10 +126,10 @@ SUBROUTINE ZHET01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zhet01_rook.f b/lapack-netlib/TESTING/LIN/zhet01_rook.f new file mode 100644 index 000000000..8474c2577 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zhet01_rook.f @@ -0,0 +1,239 @@ +*> \brief \b ZHET01_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHET01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, +* RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHET01_ROOK reconstructs a complex Hermitian indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix, EPS is the machine epsilon, +*> L' is the transpose of L, and U' is the transpose of U. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> complex Hermitian matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The original complex Hermitian matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (LDAFAC,N) +*> The factored form of the matrix A. AFAC contains the block +*> diagonal matrix D and the multipliers used to obtain the +*> factor L or U from the block L*D*L' or U*D*U' factorization +*> as computed by CSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from CSYTRF_ROOK. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is DOUBLE PRECISION +*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) +*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZHET01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + DOUBLE PRECISION ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION ZLANHE, DLAMCH + EXTERNAL LSAME, ZLANHE, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL ZLASET, ZLAVHE_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC DIMAG, DBLE +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* Determine EPS and the norm of A. +* + EPS = DLAMCH( 'Epsilon' ) + ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK ) +* +* Check the imaginary parts of the diagonal elements and return with +* an error code if any are nonzero. +* + DO 10 J = 1, N + IF( DIMAG( AFAC( J, J ) ).NE.ZERO ) THEN + RESID = ONE / EPS + RETURN + END IF + 10 CONTINUE +* +* Initialize C to the identity matrix. +* + CALL ZLASET( 'Full', N, N, CZERO, CONE, C, LDC ) +* +* Call ZLAVHE_ROOK to form the product D * U' (or D * L' ). +* + CALL ZLAVHE_ROOK( UPLO, 'Conjugate', 'Non-unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* Call ZLAVHE_ROOK again to multiply by U (or L ). +* + CALL ZLAVHE_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 30 J = 1, N + DO 20 I = 1, J - 1 + C( I, J ) = C( I, J ) - A( I, J ) + 20 CONTINUE + C( J, J ) = C( J, J ) - DBLE( A( J, J ) ) + 30 CONTINUE + ELSE + DO 50 J = 1, N + C( J, J ) = C( J, J ) - DBLE( A( J, J ) ) + DO 40 I = J + 1, N + C( I, J ) = C( I, J ) - A( I, J ) + 40 CONTINUE + 50 CONTINUE + END IF +* +* Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = ZLANHE( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID/DBLE( N ) )/ANORM ) / EPS + END IF +* + RETURN +* +* End of ZHET01_ROOK +* + END diff --git a/lapack-netlib/TESTING/LIN/zlatb4.f b/lapack-netlib/TESTING/LIN/zlatb4.f index 93f8bc6bc..44db6e8f1 100644 --- a/lapack-netlib/TESTING/LIN/zlatb4.f +++ b/lapack-netlib/TESTING/LIN/zlatb4.f @@ -61,7 +61,8 @@ *> TYPE is CHARACTER*1 *> The type of the matrix to be generated: *> = 'S': symmetric matrix -*> = 'P': symmetric positive (semi)definite matrix +*> = 'H': Hermitian matrix +*> = 'P': Hermitian positive (semi)definite matrix *> = 'N': nonsymmetric matrix *> \endverbatim *> @@ -112,7 +113,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex16_lin * @@ -120,10 +121,10 @@ SUBROUTINE ZLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, $ CNDNUM, DIST ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER DIST, TYPE diff --git a/lapack-netlib/TESTING/LIN/zlavhe.f b/lapack-netlib/TESTING/LIN/zlavhe.f index fd0bedcb2..bf58d7d74 100644 --- a/lapack-netlib/TESTING/LIN/zlavhe.f +++ b/lapack-netlib/TESTING/LIN/zlavhe.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLAVHE( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, * LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -19,118 +19,133 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> ZLAVHE performs one of the matrix-vector operations -*> x := A*x or x := A^H*x, -*> where x is an N element vector and A is one of the factors -*> from the symmetric factorization computed by ZHETRF. -*> ZHETRF produces a factorization of the form -*> U * D * U^H or L * D * L^H, -*> where U (or L) is a product of permutation and unit upper (lower) -*> triangular matrices, U^H (or L^H) is the conjugate transpose of -*> U (or L), and D is Hermitian and block diagonal with 1 x 1 and -*> 2 x 2 diagonal blocks. The multipliers for the transformations -*> and the upper or lower triangular parts of the diagonal blocks -*> are stored in the leading upper or lower triangle of the 2-D -*> array A. +*> ZLAVHE performs one of the matrix-vector operations +*> x := A*x or x := A^H*x, +*> where x is an N element vector and A is one of the factors +*> from the block U*D*U' or L*D*L' factorization computed by ZHETRF. *> -*> If TRANS = 'N' or 'n', ZLAVHE multiplies either by U or U * D -*> (or L or L * D). -*> If TRANS = 'C' or 'c', ZLAVHE multiplies either by U^H or D * U^H -*> (or L^H or D * L^H ). +*> If TRANS = 'N', multiplies by U or U * D (or L or L * D) +*> If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L') *> \endverbatim * * Arguments: * ========== * +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the factor stored in A is upper or lower +*> triangular. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> Specifies the operation to be performed: +*> = 'N': x := A*x +*> = 'C': x := A'*x +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> Specifies whether or not the diagonal blocks are unit +*> matrices. If the diagonal blocks are assumed to be unit, +*> then A = U or A = L, otherwise A = U*D or A = L*D. +*> = 'U': Diagonal blocks are assumed to be unit matrices. +*> = 'N': Diagonal blocks are assumed to be non-unit matrices. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS *> \verbatim -*> UPLO - CHARACTER*1 -*> On entry, UPLO specifies whether the triangular matrix -*> stored in A is upper or lower triangular. -*> UPLO = 'U' or 'u' The matrix is upper triangular. -*> UPLO = 'L' or 'l' The matrix is lower triangular. -*> Unchanged on exit. +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of vectors +*> x to be multiplied by A. NRHS >= 0. +*> \endverbatim *> -*> TRANS - CHARACTER*1 -*> On entry, TRANS specifies the operation to be performed as -*> follows: -*> TRANS = 'N' or 'n' x := A*x. -*> TRANS = 'C' or 'c' x := A^H*x. -*> Unchanged on exit. +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by ZHETRF. +*> Stored as a 2-D triangular matrix. +*> \endverbatim *> -*> DIAG - CHARACTER*1 -*> On entry, DIAG specifies whether the diagonal blocks are -*> assumed to be unit matrices: -*> DIAG = 'U' or 'u' Diagonal blocks are unit matrices. -*> DIAG = 'N' or 'n' Diagonal blocks are non-unit. -*> Unchanged on exit. +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim *> -*> N - INTEGER -*> On entry, N specifies the order of the matrix A. -*> N must be at least zero. -*> Unchanged on exit. +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, +*> as determined by ZHETRF. *> -*> NRHS - INTEGER -*> On entry, NRHS specifies the number of right hand sides, -*> i.e., the number of vectors x to be multiplied by A. -*> NRHS must be at least zero. -*> Unchanged on exit. +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> (If IPIV( k ) = k, no interchange was done). *> -*> A - COMPLEX*16 array, dimension( LDA, N ) -*> On entry, A contains a block diagonal matrix and the -*> multipliers of the transformations used to obtain it, -*> stored as a 2-D triangular matrix. -*> Unchanged on exit. +*> If IPIV(k) = IPIV(k-1) < 0, then rows and +*> columns k-1 and -IPIV(k) were interchanged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. *> -*> LDA - INTEGER -*> On entry, LDA specifies the first dimension of A as declared -*> in the calling ( sub ) program. LDA must be at least -*> max( 1, N ). -*> Unchanged on exit. +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> (If IPIV( k ) = k, no interchange was done). *> -*> IPIV - INTEGER array, dimension( N ) -*> On entry, IPIV contains the vector of pivot indices as -*> determined by ZSYTRF or ZHETRF. -*> If IPIV( K ) = K, no interchange was done. -*> If IPIV( K ) <> K but IPIV( K ) > 0, then row K was inter- -*> changed with row IPIV( K ) and a 1 x 1 pivot block was used. -*> If IPIV( K ) < 0 and UPLO = 'U', then row K-1 was exchanged -*> with row | IPIV( K ) | and a 2 x 2 pivot block was used. -*> If IPIV( K ) < 0 and UPLO = 'L', then row K+1 was exchanged -*> with row | IPIV( K ) | and a 2 x 2 pivot block was used. +*> If IPIV(k) = IPIV(k+1) < 0, then rows and +*> columns k+1 and -IPIV(k) were interchanged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim *> -*> B - COMPLEX*16 array, dimension( LDB, NRHS ) -*> On entry, B contains NRHS vectors of length N. -*> On exit, B is overwritten with the product A * B. +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB,NRHS) +*> On entry, B contains NRHS vectors of length N. +*> On exit, B is overwritten with the product A * B. +*> \endverbatim *> -*> LDB - INTEGER -*> On entry, LDB contains the leading dimension of B as -*> declared in the calling program. LDB must be at least -*> max( 1, N ). -*> Unchanged on exit. +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim *> -*> INFO - INTEGER -*> INFO is the error flag. -*> On exit, a value of 0 indicates a successful exit. -*> A negative value, say -K, indicates that the K-th argument -*> has an illegal value. +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value *> \endverbatim * * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex16_lin * @@ -138,10 +153,10 @@ SUBROUTINE ZLAVHE( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, $ LDB, INFO ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/zlavhe_rook.f b/lapack-netlib/TESTING/LIN/zlavhe_rook.f new file mode 100644 index 000000000..b8e708f50 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zlavhe_rook.f @@ -0,0 +1,600 @@ +*> \brief \b ZLAVHE_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZLAVHE_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, +* LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, TRANS, UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> ZLAVHE_ROOK performs one of the matrix-vector operations +*> x := A*x or x := A^H*x, +*> where x is an N element vector and A is one of the factors +*> from the block U*D*U' or L*D*L' factorization computed by ZHETRF_ROOK. +*> +*> If TRANS = 'N', multiplies by U or U * D (or L or L * D) +*> If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L') +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the factor stored in A is upper or lower +*> triangular. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> Specifies the operation to be performed: +*> = 'N': x := A*x +*> = 'C': x := A^H*x +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> Specifies whether or not the diagonal blocks are unit +*> matrices. If the diagonal blocks are assumed to be unit, +*> then A = U or A = L, otherwise A = U*D or A = L*D. +*> = 'U': Diagonal blocks are assumed to be unit matrices. +*> = 'N': Diagonal blocks are assumed to be non-unit matrices. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of vectors +*> x to be multiplied by A. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by ZHETRF_ROOK. +*> Stored as a 2-D triangular matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, +*> as determined by ZHETRF_ROOK. +*> If UPLO = 'U': +*> Only the last KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) were +*> interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> Only the first KB elements of IPIV are set. +*> +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension (LDB,NRHS) +*> On entry, B contains NRHS vectors of length N. +*> On exit, B is overwritten with the product A * B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZLAVHE_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, + $ B, LDB, INFO ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER DIAG, TRANS, UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL NOUNIT + INTEGER J, K, KP + COMPLEX*16 D11, D12, D21, D22, T1, T2 +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZGEMV, ZGERU, ZLACGV, ZSCAL, ZSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DCONJG, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) + $ THEN + INFO = -2 + ELSE IF( .NOT.LSAME( DIAG, 'U' ) .AND. .NOT.LSAME( DIAG, 'N' ) ) + $ THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLAVHE_ROOK ', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* + NOUNIT = LSAME( DIAG, 'N' ) +*------------------------------------------ +* +* Compute B := A * B (No transpose) +* +*------------------------------------------ + IF( LSAME( TRANS, 'N' ) ) THEN +* +* Compute B := U*B +* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Loop forward applying the transformations. +* + K = 1 + 10 CONTINUE + IF( K.GT.N ) + $ GO TO 30 + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 pivot block +* +* Multiply by the diagonal element if forming U * D. +* + IF( NOUNIT ) + $ CALL ZSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) +* +* Multiply by P(K) * inv(U(K)) if K > 1. +* + IF( K.GT.1 ) THEN +* +* Apply the transformation. +* + CALL ZGERU( K-1, NRHS, CONE, A( 1, K ), 1, B( K, 1 ), + $ LDB, B( 1, 1 ), LDB ) +* +* Interchange if P(K) != I. +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + K = K + 1 + ELSE +* +* 2 x 2 pivot block +* +* Multiply by the diagonal block if forming U * D. +* + IF( NOUNIT ) THEN + D11 = A( K, K ) + D22 = A( K+1, K+1 ) + D12 = A( K, K+1 ) + D21 = DCONJG( D12 ) + DO 20 J = 1, NRHS + T1 = B( K, J ) + T2 = B( K+1, J ) + B( K, J ) = D11*T1 + D12*T2 + B( K+1, J ) = D21*T1 + D22*T2 + 20 CONTINUE + END IF +* +* Multiply by P(K) * inv(U(K)) if K > 1. +* + IF( K.GT.1 ) THEN +* +* Apply the transformations. +* + CALL ZGERU( K-1, NRHS, CONE, A( 1, K ), 1, B( K, 1 ), + $ LDB, B( 1, 1 ), LDB ) + CALL ZGERU( K-1, NRHS, CONE, A( 1, K+1 ), 1, + $ B( K+1, 1 ), LDB, B( 1, 1 ), LDB ) +* +* Interchange if a permutation was applied at the +* K-th step of the factorization. +* +* Swap the first of pair with IMAXth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* NOW swap the first of pair with Pth +* + KP = ABS( IPIV( K+1 ) ) + IF( KP.NE.K+1 ) + $ CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), + $ LDB ) + END IF + K = K + 2 + END IF + GO TO 10 + 30 CONTINUE +* +* Compute B := L*B +* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . +* + ELSE +* +* Loop backward applying the transformations to B. +* + K = N + 40 CONTINUE + IF( K.LT.1 ) + $ GO TO 60 +* +* Test the pivot index. If greater than zero, a 1 x 1 +* pivot was used, otherwise a 2 x 2 pivot was used. +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 pivot block: +* +* Multiply by the diagonal element if forming L * D. +* + IF( NOUNIT ) + $ CALL ZSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) +* +* Multiply by P(K) * inv(L(K)) if K < N. +* + IF( K.NE.N ) THEN + KP = IPIV( K ) +* +* Apply the transformation. +* + CALL ZGERU( N-K, NRHS, CONE, A( K+1, K ), 1, + $ B( K, 1 ), LDB, B( K+1, 1 ), LDB ) +* +* Interchange if a permutation was applied at the +* K-th step of the factorization. +* + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + K = K - 1 +* + ELSE +* +* 2 x 2 pivot block: +* +* Multiply by the diagonal block if forming L * D. +* + IF( NOUNIT ) THEN + D11 = A( K-1, K-1 ) + D22 = A( K, K ) + D21 = A( K, K-1 ) + D12 = DCONJG( D21 ) + DO 50 J = 1, NRHS + T1 = B( K-1, J ) + T2 = B( K, J ) + B( K-1, J ) = D11*T1 + D12*T2 + B( K, J ) = D21*T1 + D22*T2 + 50 CONTINUE + END IF +* +* Multiply by P(K) * inv(L(K)) if K < N. +* + IF( K.NE.N ) THEN +* +* Apply the transformation. +* + CALL ZGERU( N-K, NRHS, CONE, A( K+1, K ), 1, + $ B( K, 1 ), LDB, B( K+1, 1 ), LDB ) + CALL ZGERU( N-K, NRHS, CONE, A( K+1, K-1 ), 1, + $ B( K-1, 1 ), LDB, B( K+1, 1 ), LDB ) +* +* Interchange if a permutation was applied at the +* K-th step of the factorization. +* +* +* Swap the second of pair with IMAXth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* NOW swap the first of pair with Pth +* + KP = ABS( IPIV( K-1 ) ) + IF( KP.NE.K-1 ) + $ CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), + $ LDB ) +* + END IF + K = K - 2 + END IF + GO TO 40 + 60 CONTINUE + END IF +*-------------------------------------------------- +* +* Compute B := A^H * B (conjugate transpose) +* +*-------------------------------------------------- + ELSE +* +* Form B := U^H*B +* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) +* and U^H = inv(U^H(1))*P(1)* ... *inv(U^H(m))*P(m) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Loop backward applying the transformations. +* + K = N + 70 IF( K.LT.1 ) + $ GO TO 90 +* +* 1 x 1 pivot block. +* + IF( IPIV( K ).GT.0 ) THEN + IF( K.GT.1 ) THEN +* +* Interchange if P(K) != I. +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Apply the transformation +* y = y - B' DCONJG(x), +* where x is a column of A and y is a row of B. +* + CALL ZLACGV( NRHS, B( K, 1 ), LDB ) + CALL ZGEMV( 'Conjugate', K-1, NRHS, CONE, B, LDB, + $ A( 1, K ), 1, CONE, B( K, 1 ), LDB ) + CALL ZLACGV( NRHS, B( K, 1 ), LDB ) + END IF + IF( NOUNIT ) + $ CALL ZSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) + K = K - 1 +* +* 2 x 2 pivot block. +* + ELSE + IF( K.GT.2 ) THEN +* +* Swap the second of pair with Pth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Now swap the first of pair with IMAX(r)th +* + KP = ABS( IPIV( K-1 ) ) + IF( KP.NE.K-1 ) + $ CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), + $ LDB ) +* +* Apply the transformations +* y = y - B' DCONJG(x), +* where x is a block column of A and y is a block +* row of B. +* + CALL ZLACGV( NRHS, B( K, 1 ), LDB ) + CALL ZGEMV( 'Conjugate', K-2, NRHS, CONE, B, LDB, + $ A( 1, K ), 1, CONE, B( K, 1 ), LDB ) + CALL ZLACGV( NRHS, B( K, 1 ), LDB ) +* + CALL ZLACGV( NRHS, B( K-1, 1 ), LDB ) + CALL ZGEMV( 'Conjugate', K-2, NRHS, CONE, B, LDB, + $ A( 1, K-1 ), 1, CONE, B( K-1, 1 ), LDB ) + CALL ZLACGV( NRHS, B( K-1, 1 ), LDB ) + END IF +* +* Multiply by the diagonal block if non-unit. +* + IF( NOUNIT ) THEN + D11 = A( K-1, K-1 ) + D22 = A( K, K ) + D12 = A( K-1, K ) + D21 = DCONJG( D12 ) + DO 80 J = 1, NRHS + T1 = B( K-1, J ) + T2 = B( K, J ) + B( K-1, J ) = D11*T1 + D12*T2 + B( K, J ) = D21*T1 + D22*T2 + 80 CONTINUE + END IF + K = K - 2 + END IF + GO TO 70 + 90 CONTINUE +* +* Form B := L^H*B +* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) +* and L^H = inv(L^H(m))*P(m)* ... *inv(L^H(1))*P(1) +* + ELSE +* +* Loop forward applying the L-transformations. +* + K = 1 + 100 CONTINUE + IF( K.GT.N ) + $ GO TO 120 +* +* 1 x 1 pivot block +* + IF( IPIV( K ).GT.0 ) THEN + IF( K.LT.N ) THEN +* +* Interchange if P(K) != I. +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Apply the transformation +* + CALL ZLACGV( NRHS, B( K, 1 ), LDB ) + CALL ZGEMV( 'Conjugate', N-K, NRHS, CONE, B( K+1, 1 ), + $ LDB, A( K+1, K ), 1, CONE, B( K, 1 ), LDB ) + CALL ZLACGV( NRHS, B( K, 1 ), LDB ) + END IF + IF( NOUNIT ) + $ CALL ZSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) + K = K + 1 +* +* 2 x 2 pivot block. +* + ELSE + IF( K.LT.N-1 ) THEN +* +* Swap the first of pair with Pth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Now swap the second of pair with IMAX(r)th +* + KP = ABS( IPIV( K+1 ) ) + IF( KP.NE.K+1 ) + $ CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), + $ LDB ) +* +* Apply the transformation +* + CALL ZLACGV( NRHS, B( K+1, 1 ), LDB ) + CALL ZGEMV( 'Conjugate', N-K-1, NRHS, CONE, + $ B( K+2, 1 ), LDB, A( K+2, K+1 ), 1, CONE, + $ B( K+1, 1 ), LDB ) + CALL ZLACGV( NRHS, B( K+1, 1 ), LDB ) +* + CALL ZLACGV( NRHS, B( K, 1 ), LDB ) + CALL ZGEMV( 'Conjugate', N-K-1, NRHS, CONE, + $ B( K+2, 1 ), LDB, A( K+2, K ), 1, CONE, + $ B( K, 1 ), LDB ) + CALL ZLACGV( NRHS, B( K, 1 ), LDB ) + END IF +* +* Multiply by the diagonal block if non-unit. +* + IF( NOUNIT ) THEN + D11 = A( K, K ) + D22 = A( K+1, K+1 ) + D21 = A( K+1, K ) + D12 = DCONJG( D21 ) + DO 110 J = 1, NRHS + T1 = B( K, J ) + T2 = B( K+1, J ) + B( K, J ) = D11*T1 + D12*T2 + B( K+1, J ) = D21*T1 + D22*T2 + 110 CONTINUE + END IF + K = K + 2 + END IF + GO TO 100 + 120 CONTINUE + END IF +* + END IF + RETURN +* +* End of ZLAVHE_ROOK +* + END diff --git a/lapack-netlib/TESTING/LIN/zlavsy.f b/lapack-netlib/TESTING/LIN/zlavsy.f index 6005e7058..2f8ecd88f 100644 --- a/lapack-netlib/TESTING/LIN/zlavsy.f +++ b/lapack-netlib/TESTING/LIN/zlavsy.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZLAVSY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, * LDB, INFO ) -* +* * .. Scalar Arguments .. * CHARACTER DIAG, TRANS, UPLO * INTEGER INFO, LDA, LDB, N, NRHS @@ -19,14 +19,14 @@ * INTEGER IPIV( * ) * COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. -* +* * *> \par Purpose: * ============= *> *> \verbatim *> -*> ZLAVSY performs one of the matrix-vector operations +*> ZLAVSY performs one of the matrix-vector operations *> x := A*x or x := A'*x, *> where x is an N element vector and A is one of the factors *> from the block U*D*U' or L*D*L' factorization computed by ZSYTRF. @@ -83,6 +83,7 @@ *> A is COMPLEX*16 array, dimension (LDA,N) *> The block diagonal matrix D and the multipliers used to *> obtain the factor U or L as computed by ZSYTRF. +*> Stored as a 2-D triangular matrix. *> \endverbatim *> *> \param[in] LDA @@ -95,7 +96,7 @@ *> \verbatim *> IPIV is INTEGER array, dimension (N) *> Details of the interchanges and the block structure of D, -*> as determined by ZSYTRF or ZHETRF. +*> as determined by ZSYTRF. *> *> If UPLO = 'U': *> If IPIV(k) > 0, then rows and columns k and IPIV(k) @@ -139,12 +140,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2013 * *> \ingroup complex16_lin * @@ -152,10 +153,10 @@ SUBROUTINE ZLAVSY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, $ LDB, INFO ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2013 * * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO diff --git a/lapack-netlib/TESTING/LIN/zlavsy_rook.f b/lapack-netlib/TESTING/LIN/zlavsy_rook.f new file mode 100644 index 000000000..ed62f8f17 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zlavsy_rook.f @@ -0,0 +1,581 @@ +*> \brief \b ZLAVSY_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZLAVSY_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, +* LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, TRANS, UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLAVSY_ROOK performs one of the matrix-vector operations +*> x := A*x or x := A'*x, +*> where x is an N element vector and A is one of the factors +*> from the block U*D*U' or L*D*L' factorization computed by ZSYTRF_ROOK. +*> +*> If TRANS = 'N', multiplies by U or U * D (or L or L * D) +*> If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L') +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the factor stored in A is upper or lower +*> triangular. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> Specifies the operation to be performed: +*> = 'N': x := A*x +*> = 'T': x := A'*x +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> Specifies whether or not the diagonal blocks are unit +*> matrices. If the diagonal blocks are assumed to be unit, +*> then A = U or A = L, otherwise A = U*D or A = L*D. +*> = 'U': Diagonal blocks are assumed to be unit matrices. +*> = 'N': Diagonal blocks are assumed to be non-unit matrices. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of vectors +*> x to be multiplied by A. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by ZSYTRF_ROOK. +*> Stored as a 2-D triangular matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, +*> as determined by ZSYTRF_ROOK. +*> +*> If UPLO = 'U': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> (If IPIV( k ) = k, no interchange was done). +*> +*> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k-1 and -IPIV(k-1) were inerchaged, +*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block. +*> +*> If UPLO = 'L': +*> If IPIV(k) > 0, then rows and columns k and IPIV(k) +*> were interchanged and D(k,k) is a 1-by-1 diagonal block. +*> (If IPIV( k ) = k, no interchange was done). +*> +*> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and +*> columns k and -IPIV(k) were interchanged and rows and +*> columns k+1 and -IPIV(k+1) were inerchaged, +*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB,NRHS) +*> On entry, B contains NRHS vectors of length N. +*> On exit, B is overwritten with the product A * B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZLAVSY_ROOK( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, + $ B, LDB, INFO ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER DIAG, TRANS, UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL NOUNIT + INTEGER J, K, KP + COMPLEX*16 D11, D12, D21, D22, T1, T2 +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZGEMV, ZGERU, ZSCAL, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) ) + $ THEN + INFO = -2 + ELSE IF( .NOT.LSAME( DIAG, 'U' ) .AND. .NOT.LSAME( DIAG, 'N' ) ) + $ THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLAVSY_ROOK ', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* + NOUNIT = LSAME( DIAG, 'N' ) +*------------------------------------------ +* +* Compute B := A * B (No transpose) +* +*------------------------------------------ + IF( LSAME( TRANS, 'N' ) ) THEN +* +* Compute B := U*B +* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Loop forward applying the transformations. +* + K = 1 + 10 CONTINUE + IF( K.GT.N ) + $ GO TO 30 + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 pivot block +* +* Multiply by the diagonal element if forming U * D. +* + IF( NOUNIT ) + $ CALL ZSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) +* +* Multiply by P(K) * inv(U(K)) if K > 1. +* + IF( K.GT.1 ) THEN +* +* Apply the transformation. +* + CALL ZGERU( K-1, NRHS, CONE, A( 1, K ), 1, B( K, 1 ), + $ LDB, B( 1, 1 ), LDB ) +* +* Interchange if P(K) != I. +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + K = K + 1 + ELSE +* +* 2 x 2 pivot block +* +* Multiply by the diagonal block if forming U * D. +* + IF( NOUNIT ) THEN + D11 = A( K, K ) + D22 = A( K+1, K+1 ) + D12 = A( K, K+1 ) + D21 = D12 + DO 20 J = 1, NRHS + T1 = B( K, J ) + T2 = B( K+1, J ) + B( K, J ) = D11*T1 + D12*T2 + B( K+1, J ) = D21*T1 + D22*T2 + 20 CONTINUE + END IF +* +* Multiply by P(K) * inv(U(K)) if K > 1. +* + IF( K.GT.1 ) THEN +* +* Apply the transformations. +* + CALL ZGERU( K-1, NRHS, CONE, A( 1, K ), 1, B( K, 1 ), + $ LDB, B( 1, 1 ), LDB ) + CALL ZGERU( K-1, NRHS, CONE, A( 1, K+1 ), 1, + $ B( K+1, 1 ), LDB, B( 1, 1 ), LDB ) +* +* Interchange if a permutation was applied at the +* K-th step of the factorization. +* +* Swap the first of pair with IMAXth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* NOW swap the first of pair with Pth +* + KP = ABS( IPIV( K+1 ) ) + IF( KP.NE.K+1 ) + $ CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), + $ LDB ) + END IF + K = K + 2 + END IF + GO TO 10 + 30 CONTINUE +* +* Compute B := L*B +* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . +* + ELSE +* +* Loop backward applying the transformations to B. +* + K = N + 40 CONTINUE + IF( K.LT.1 ) + $ GO TO 60 +* +* Test the pivot index. If greater than zero, a 1 x 1 +* pivot was used, otherwise a 2 x 2 pivot was used. +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 pivot block: +* +* Multiply by the diagonal element if forming L * D. +* + IF( NOUNIT ) + $ CALL ZSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) +* +* Multiply by P(K) * inv(L(K)) if K < N. +* + IF( K.NE.N ) THEN + KP = IPIV( K ) +* +* Apply the transformation. +* + CALL ZGERU( N-K, NRHS, CONE, A( K+1, K ), 1, + $ B( K, 1 ), LDB, B( K+1, 1 ), LDB ) +* +* Interchange if a permutation was applied at the +* K-th step of the factorization. +* + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + K = K - 1 +* + ELSE +* +* 2 x 2 pivot block: +* +* Multiply by the diagonal block if forming L * D. +* + IF( NOUNIT ) THEN + D11 = A( K-1, K-1 ) + D22 = A( K, K ) + D21 = A( K, K-1 ) + D12 = D21 + DO 50 J = 1, NRHS + T1 = B( K-1, J ) + T2 = B( K, J ) + B( K-1, J ) = D11*T1 + D12*T2 + B( K, J ) = D21*T1 + D22*T2 + 50 CONTINUE + END IF +* +* Multiply by P(K) * inv(L(K)) if K < N. +* + IF( K.NE.N ) THEN +* +* Apply the transformation. +* + CALL ZGERU( N-K, NRHS, CONE, A( K+1, K ), 1, + $ B( K, 1 ), LDB, B( K+1, 1 ), LDB ) + CALL ZGERU( N-K, NRHS, CONE, A( K+1, K-1 ), 1, + $ B( K-1, 1 ), LDB, B( K+1, 1 ), LDB ) +* +* Interchange if a permutation was applied at the +* K-th step of the factorization. +* +* Swap the second of pair with IMAXth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* NOW swap the first of pair with Pth +* + KP = ABS( IPIV( K-1 ) ) + IF( KP.NE.K-1 ) + $ CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), + $ LDB ) + END IF + K = K - 2 + END IF + GO TO 40 + 60 CONTINUE + END IF +*---------------------------------------- +* +* Compute B := A' * B (transpose) +* +*---------------------------------------- + ELSE IF( LSAME( TRANS, 'T' ) ) THEN +* +* Form B := U'*B +* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) +* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Loop backward applying the transformations. +* + K = N + 70 CONTINUE + IF( K.LT.1 ) + $ GO TO 90 +* +* 1 x 1 pivot block. +* + IF( IPIV( K ).GT.0 ) THEN + IF( K.GT.1 ) THEN +* +* Interchange if P(K) != I. +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Apply the transformation +* + CALL ZGEMV( 'Transpose', K-1, NRHS, CONE, B, LDB, + $ A( 1, K ), 1, CONE, B( K, 1 ), LDB ) + END IF + IF( NOUNIT ) + $ CALL ZSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) + K = K - 1 +* +* 2 x 2 pivot block. +* + ELSE + IF( K.GT.2 ) THEN +* +* Swap the second of pair with Pth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Now swap the first of pair with IMAX(r)th +* + KP = ABS( IPIV( K-1 ) ) + IF( KP.NE.K-1 ) + $ CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), + $ LDB ) +* +* Apply the transformations +* + CALL ZGEMV( 'Transpose', K-2, NRHS, CONE, B, LDB, + $ A( 1, K ), 1, CONE, B( K, 1 ), LDB ) + CALL ZGEMV( 'Transpose', K-2, NRHS, CONE, B, LDB, + $ A( 1, K-1 ), 1, CONE, B( K-1, 1 ), LDB ) + END IF +* +* Multiply by the diagonal block if non-unit. +* + IF( NOUNIT ) THEN + D11 = A( K-1, K-1 ) + D22 = A( K, K ) + D12 = A( K-1, K ) + D21 = D12 + DO 80 J = 1, NRHS + T1 = B( K-1, J ) + T2 = B( K, J ) + B( K-1, J ) = D11*T1 + D12*T2 + B( K, J ) = D21*T1 + D22*T2 + 80 CONTINUE + END IF + K = K - 2 + END IF + GO TO 70 + 90 CONTINUE +* +* Form B := L'*B +* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) +* and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1) +* + ELSE +* +* Loop forward applying the L-transformations. +* + K = 1 + 100 CONTINUE + IF( K.GT.N ) + $ GO TO 120 +* +* 1 x 1 pivot block +* + IF( IPIV( K ).GT.0 ) THEN + IF( K.LT.N ) THEN +* +* Interchange if P(K) != I. +* + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Apply the transformation +* + CALL ZGEMV( 'Transpose', N-K, NRHS, CONE, B( K+1, 1 ), + $ LDB, A( K+1, K ), 1, CONE, B( K, 1 ), LDB ) + END IF + IF( NOUNIT ) + $ CALL ZSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) + K = K + 1 +* +* 2 x 2 pivot block. +* + ELSE + IF( K.LT.N-1 ) THEN +* +* Swap the first of pair with Pth +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) +* +* Now swap the second of pair with IMAX(r)th +* + KP = ABS( IPIV( K+1 ) ) + IF( KP.NE.K+1 ) + $ CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), + $ LDB ) +* +* Apply the transformation +* + CALL ZGEMV( 'Transpose', N-K-1, NRHS, CONE, + $ B( K+2, 1 ), LDB, A( K+2, K+1 ), 1, CONE, + $ B( K+1, 1 ), LDB ) + CALL ZGEMV( 'Transpose', N-K-1, NRHS, CONE, + $ B( K+2, 1 ), LDB, A( K+2, K ), 1, CONE, + $ B( K, 1 ), LDB ) + END IF +* +* Multiply by the diagonal block if non-unit. +* + IF( NOUNIT ) THEN + D11 = A( K, K ) + D22 = A( K+1, K+1 ) + D21 = A( K+1, K ) + D12 = D21 + DO 110 J = 1, NRHS + T1 = B( K, J ) + T2 = B( K+1, J ) + B( K, J ) = D11*T1 + D12*T2 + B( K+1, J ) = D21*T1 + D22*T2 + 110 CONTINUE + END IF + K = K + 2 + END IF + GO TO 100 + 120 CONTINUE + END IF + END IF + RETURN +* +* End of ZLAVSY_ROOK +* + END diff --git a/lapack-netlib/TESTING/LIN/zsyt01.f b/lapack-netlib/TESTING/LIN/zsyt01.f index 9b3d44ba3..4ec551180 100644 --- a/lapack-netlib/TESTING/LIN/zsyt01.f +++ b/lapack-netlib/TESTING/LIN/zsyt01.f @@ -2,15 +2,15 @@ * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * * Definition: * =========== * * SUBROUTINE ZSYT01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, * RWORK, RESID ) -* +* * .. Scalar Arguments .. * CHARACTER UPLO * INTEGER LDA, LDAFAC, LDC, N @@ -21,7 +21,7 @@ * DOUBLE PRECISION RWORK( * ) * COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ) * .. -* +* * *> \par Purpose: * ============= @@ -112,12 +112,12 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * -*> \date November 2011 +*> \date November 2013 * *> \ingroup complex16_lin * @@ -125,10 +125,10 @@ SUBROUTINE ZSYT01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, $ RWORK, RESID ) * -* -- LAPACK test routine (version 3.4.0) -- +* -- LAPACK test routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 +* November 2013 * * .. Scalar Arguments .. CHARACTER UPLO diff --git a/lapack-netlib/TESTING/LIN/zsyt01_rook.f b/lapack-netlib/TESTING/LIN/zsyt01_rook.f new file mode 100644 index 000000000..4e7ea24aa --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zsyt01_rook.f @@ -0,0 +1,227 @@ +*> \brief \b ZSYT01_ROOK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, +* RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSYT01_ROOK reconstructs a complex symmetric indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix, EPS is the machine epsilon, +*> L' is the transpose of L, and U' is the transpose of U. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> complex symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The original complex symmetric matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (LDAFAC,N) +*> The factored form of the matrix A. AFAC contains the block +*> diagonal matrix D and the multipliers used to obtain the +*> factor L or U from the block L*D*L' or U*D*U' factorization +*> as computed by ZSYTRF_ROOK. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from ZSYTRF_ROOK. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is DOUBLE PRECISION +*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) +*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + DOUBLE PRECISION ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, ZLANSY + EXTERNAL LSAME, DLAMCH, ZLANSY +* .. +* .. External Subroutines .. + EXTERNAL ZLASET, ZLAVSY_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* Determine EPS and the norm of A. +* + EPS = DLAMCH( 'Epsilon' ) + ANORM = ZLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Initialize C to the identity matrix. +* + CALL ZLASET( 'Full', N, N, CZERO, CONE, C, LDC ) +* +* Call ZLAVSY_ROOK to form the product D * U' (or D * L' ). +* + CALL ZLAVSY_ROOK( UPLO, 'Transpose', 'Non-unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* Call ZLAVSY_ROOK again to multiply by U (or L ). +* + CALL ZLAVSY_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF +* +* Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = ZLANSY( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS + END IF +* + RETURN +* +* End of ZSYT01_ROOK +* + END diff --git a/lapack-netlib/TESTING/csd.in b/lapack-netlib/TESTING/csd.in index b146d3954..a0a2e5450 100644 --- a/lapack-netlib/TESTING/csd.in +++ b/lapack-netlib/TESTING/csd.in @@ -3,7 +3,7 @@ CSD: Data file for testing CS decomposition routines 0 10 10 10 10 21 24 30 22 32 55 Values of M (row and column dimension of unitary matrix) 0 4 4 0 10 9 10 20 12 12 40 Values of P (row dimension of top-left block) 0 0 10 4 4 15 12 8 20 8 20 Values of Q (column dimension of top-left block) -10.0 Threshold value of test ratio +30.0 Threshold value of test ratio T Put T to test the error exits 1 Code to interpret the seed -CSD 3 List types on next line if 0 < NTYPES < 3 +CSD 4 List types on next line if 0 < NTYPES < 3 diff --git a/lapack-netlib/TESTING/ctest.in b/lapack-netlib/TESTING/ctest.in index de44a09c5..e46549310 100644 --- a/lapack-netlib/TESTING/ctest.in +++ b/lapack-netlib/TESTING/ctest.in @@ -23,8 +23,10 @@ CPP 9 List types on next line if 0 < NTYPES < 9 CPB 8 List types on next line if 0 < NTYPES < 8 CPT 12 List types on next line if 0 < NTYPES < 12 CHE 10 List types on next line if 0 < NTYPES < 10 +CHR 10 List types on next line if 0 < NTYPES < 10 CHP 10 List types on next line if 0 < NTYPES < 10 CSY 11 List types on next line if 0 < NTYPES < 11 +CSR 11 List types on next line if 0 < NTYPES < 11 CSP 11 List types on next line if 0 < NTYPES < 11 CTR 18 List types on next line if 0 < NTYPES < 18 CTP 18 List types on next line if 0 < NTYPES < 18 diff --git a/lapack-netlib/TESTING/dtest.in b/lapack-netlib/TESTING/dtest.in index 5925174aa..467a01c80 100644 --- a/lapack-netlib/TESTING/dtest.in +++ b/lapack-netlib/TESTING/dtest.in @@ -23,6 +23,7 @@ DPP 9 List types on next line if 0 < NTYPES < 9 DPB 8 List types on next line if 0 < NTYPES < 8 DPT 12 List types on next line if 0 < NTYPES < 12 DSY 10 List types on next line if 0 < NTYPES < 10 +DSR 10 List types on next line if 0 < NTYPES < 10 DSP 10 List types on next line if 0 < NTYPES < 10 DTR 18 List types on next line if 0 < NTYPES < 18 DTP 18 List types on next line if 0 < NTYPES < 18 diff --git a/lapack-netlib/TESTING/stest.in b/lapack-netlib/TESTING/stest.in index 155a50f7d..bd7f884ba 100644 --- a/lapack-netlib/TESTING/stest.in +++ b/lapack-netlib/TESTING/stest.in @@ -23,6 +23,7 @@ SPP 9 List types on next line if 0 < NTYPES < 9 SPB 8 List types on next line if 0 < NTYPES < 8 SPT 12 List types on next line if 0 < NTYPES < 12 SSY 10 List types on next line if 0 < NTYPES < 10 +SSR 10 List types on next line if 0 < NTYPES < 10 SSP 10 List types on next line if 0 < NTYPES < 10 STR 18 List types on next line if 0 < NTYPES < 18 STP 18 List types on next line if 0 < NTYPES < 18 diff --git a/lapack-netlib/TESTING/ztest.in b/lapack-netlib/TESTING/ztest.in index a9d9daea4..106035101 100644 --- a/lapack-netlib/TESTING/ztest.in +++ b/lapack-netlib/TESTING/ztest.in @@ -23,8 +23,10 @@ ZPP 9 List types on next line if 0 < NTYPES < 9 ZPB 8 List types on next line if 0 < NTYPES < 8 ZPT 12 List types on next line if 0 < NTYPES < 12 ZHE 10 List types on next line if 0 < NTYPES < 10 +ZHR 10 List types on next line if 0 < NTYPES < 10 ZHP 10 List types on next line if 0 < NTYPES < 10 ZSY 11 List types on next line if 0 < NTYPES < 11 +ZSR 11 List types on next line if 0 < NTYPES < 11 ZSP 11 List types on next line if 0 < NTYPES < 11 ZTR 18 List types on next line if 0 < NTYPES < 18 ZTP 18 List types on next line if 0 < NTYPES < 18 diff --git a/lapack-netlib/lapack_testing.py b/lapack-netlib/lapack_testing.py index 3bd94621b..d0b9aaac5 100755 --- a/lapack-netlib/lapack_testing.py +++ b/lapack-netlib/lapack_testing.py @@ -139,7 +139,7 @@ def run_summary_test( f, cmdline, short_summary): if (short_summary==0): print line, whereisout= words_in_line.index("out") nb_test_fail+=int(words_in_line[whereisout-1]) - if (line.find("illegal")!=-1): + if ((line.find("illegal")!=-1) or (line.find("Illegal")!=-1)): if (short_summary==0):print line, nb_test_illegal+=1 if (line.find(" INFO")!=-1): diff --git a/lapack-netlib/lapacke/example/CMakeLists.txt b/lapack-netlib/lapacke/example/CMakeLists.txt index 9e00c94ef..a1c590965 100644 --- a/lapack-netlib/lapacke/example/CMakeLists.txt +++ b/lapack-netlib/lapacke/example/CMakeLists.txt @@ -1,8 +1,14 @@ -add_executable(xexample_DGESV_rowmajor example_DGESV_rowmajor.c) -add_executable(xexample_ZGESV_rowmajor example_ZGESV_rowmajor.c) +add_executable(xexample_DGESV_rowmajor example_DGESV_rowmajor.c lapacke_example_aux.c lapacke_example_aux.h) +add_executable(xexample_DGESV_colmajor example_DGESV_colmajor.c lapacke_example_aux.c lapacke_example_aux.h) +add_executable(xexample_DGELS_rowmajor example_DGELS_rowmajor.c lapacke_example_aux.c lapacke_example_aux.h) +add_executable(xexample_DGELS_colmajor example_DGELS_colmajor.c lapacke_example_aux.c lapacke_example_aux.h) target_link_libraries(xexample_DGESV_rowmajor lapacke ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) -target_link_libraries(xexample_ZGESV_rowmajor lapacke ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) +target_link_libraries(xexample_DGESV_colmajor lapacke ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) +target_link_libraries(xexample_DGELS_rowmajor lapacke ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) +target_link_libraries(xexample_DGELS_colmajor lapacke ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) add_test(example_DGESV_rowmajor ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/xexample_DGESV_rowmajor) -add_test(example_ZGESV_rowmajor ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/xexample_ZGESV_rowmajor) +add_test(example_DGESV_colmajor ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/xexample_DGESV_colmajor) +add_test(example_DGELS_rowmajor ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/xexample_DGELS_rowmajor) +add_test(example_DGELS_colmajor ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/xexample_DGELS_colmajor) diff --git a/lapack-netlib/lapacke/example/Makefile b/lapack-netlib/lapacke/example/Makefile index a2ffaefe0..52c46707f 100644 --- a/lapack-netlib/lapacke/example/Makefile +++ b/lapack-netlib/lapacke/example/Makefile @@ -1,19 +1,35 @@ include ../../make.inc -all: xexample_DGESV_rowmajor xexample_ZGESV_rowmajor +all: xexample_DGESV_rowmajor \ + xexample_DGESV_colmajor \ + xexample_DGELS_rowmajor \ + xexample_DGELS_colmajor -xexample_DGESV_rowmajor: example_DGESV_rowmajor.o ../../$(LAPACKLIB) ../../$(LAPACKELIB) - $(LOADER) $(LOADOPTS) example_DGESV_rowmajor.o \ - ../../$(LAPACKELIB) $(CEXTRALIB) -o $@ +LIBRAIRIES= ../../$(LAPACKELIB) ../../$(LAPACKLIB) $(BLASLIB) + +# Double Precision Examples +xexample_DGESV_rowmajor: example_DGESV_rowmajor.o lapacke_example_aux.o $(LIBRAIRIES) + $(LOADER) $(LOADOPTS) example_DGESV_rowmajor.o lapacke_example_aux.o \ + $(LIBRAIRIES) -o $@ + ./$@ + +xexample_DGESV_colmajor: example_DGESV_colmajor.o lapacke_example_aux.o $(LIBRAIRIES) + $(LOADER) $(LOADOPTS) example_DGESV_colmajor.o lapacke_example_aux.o \ + $(LIBRAIRIES) -o $@ + ./$@ + +xexample_DGELS_rowmajor: example_DGELS_rowmajor.o lapacke_example_aux.o $(LIBRAIRIES) + $(LOADER) $(LOADOPTS) example_DGELS_rowmajor.o lapacke_example_aux.o \ + $(LIBRAIRIES) -o $@ ./$@ -xexample_ZGESV_rowmajor: example_ZGESV_rowmajor.o ../../$(LAPACKLIB) ../../$(LAPACKELIB) - $(LOADER) $(LOADOPTS) example_ZGESV_rowmajor.o \ - ../../$(LAPACKELIB) $(CEXTRALIB) -o $@ +xexample_DGELS_colmajor: example_DGELS_colmajor.o lapacke_example_aux.o $(LIBRAIRIES) + $(LOADER) $(LOADOPTS) example_DGELS_colmajor.o lapacke_example_aux.o \ + $(LIBRAIRIES) -o $@ ./$@ .c.o: - $(CC) -c $(CFLAGS) -I ../include -o $@ $< + $(CC) -c $(CFLAGS) -I. -I ../include -o $@ $< clean: - rm -f *.o xexample_DGESV_rowmajor xexample_ZGESV_rowmajor \ No newline at end of file + rm -f *.o x* diff --git a/lapack-netlib/lapacke/example/example_DGELS_colmajor.c b/lapack-netlib/lapacke/example/example_DGELS_colmajor.c new file mode 100644 index 000000000..b5e0bbbb1 --- /dev/null +++ b/lapack-netlib/lapacke/example/example_DGELS_colmajor.c @@ -0,0 +1,96 @@ +/* + LAPACKE Example : Calling DGELS using col-major order + ===================================================== + + The program computes the solution to the system of linear + equations with a square matrix A and multiple + right-hand sides B, where A is the coefficient matrix + and b is the right-hand side matrix: + + Description + =========== + + In this example, we wish solve the least squares problem min_x || B - Ax || + for two right-hand sides using the LAPACK routine DGELS. For input we will + use the 5-by-3 matrix + + ( 1 1 1 ) + ( 2 3 4 ) + A = ( 3 5 2 ) + ( 4 2 5 ) + ( 5 4 3 ) + and the 5-by-2 matrix + + ( -10 -3 ) + ( 12 14 ) + B = ( 14 12 ) + ( 16 16 ) + ( 18 16 ) + We will first store the input matrix as a static C two-dimensional array, + which is stored in col-major order, and let LAPACKE handle the work space + array allocation. The LAPACK base name for this function is gels, and we + will use double precision (d), so the LAPACKE function name is LAPACKE_dgels. + + lda=5 and ldb=5. The output for each right hand side is stored in b as + consecutive vectors of length 3. The correct answer for this problem is + the 3-by-2 matrix + + ( 2 1 ) + ( 1 1 ) + ( 1 2 ) + + A complete C program for this example is given below. Note that when the arrays + are passed to the LAPACK routine, they must be dereferenced, since LAPACK is + expecting arrays of type double *, not double **. + + + LAPACKE Interface + ================= + + LAPACKE_dgels (col-major, high-level) Example Program Results + + -- LAPACKE Example routine (version 3.5.0) -- + -- LAPACK is a software package provided by Univ. of Tennessee, -- + -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + February 2012 + +*/ +/* Calling DGELS using col-major order */ + +/* Includes */ +#include +#include +#include "lapacke_example_aux.h" + +/* Main program */ +int main (int argc, const char * argv[]) +{ + /* Locals */ + double A[5][3] = {1,2,3,4,5,1,3,5,2,4,1,4,2,5,3}; + double b[5][2] = {-10,12,14,16,18,-3,14,12,16,16}; + lapack_int info,m,n,lda,ldb,nrhs; + int i,j; + + /* Initialization */ + m = 5; + n = 3; + nrhs = 2; + lda = 5; + ldb = 5; + + /* Print Entry Matrix */ + print_matrix_colmajor( "Entry Matrix A", m, n, *A, lda ); + /* Print Right Rand Side */ + print_matrix_colmajor( "Right Hand Side b", n, nrhs, *b, ldb ); + printf( "\n" ); + + /* Executable statements */ + printf( "LAPACKE_dgels (col-major, high-level) Example Program Results\n" ); + /* Solve least squares problem*/ + info = LAPACKE_dgels(LAPACK_COL_MAJOR,'N',m,n,nrhs,*A,lda,*b,ldb); + + /* Print Solution */ + print_matrix_colmajor( "Solution", n, nrhs, *b, ldb ); + printf( "\n" ); + exit( 0 ); +} /* End of LAPACKE_dgels Example */ diff --git a/lapack-netlib/lapacke/example/example_DGELS_rowmajor.c b/lapack-netlib/lapacke/example/example_DGELS_rowmajor.c new file mode 100644 index 000000000..331aa2f8d --- /dev/null +++ b/lapack-netlib/lapacke/example/example_DGELS_rowmajor.c @@ -0,0 +1,96 @@ +/* + LAPACKE Example : Calling DGELS using row-major order + ===================================================== + + The program computes the solution to the system of linear + equations with a square matrix A and multiple + right-hand sides B, where A is the coefficient matrix + and b is the right-hand side matrix: + + Description + =========== + + In this example, we wish solve the least squares problem min_x || B - Ax || + for two right-hand sides using the LAPACK routine DGELS. For input we will + use the 5-by-3 matrix + + ( 1 1 1 ) + ( 2 3 4 ) + A = ( 3 5 2 ) + ( 4 2 5 ) + ( 5 4 3 ) + and the 5-by-2 matrix + + ( -10 -3 ) + ( 12 14 ) + B = ( 14 12 ) + ( 16 16 ) + ( 18 16 ) + We will first store the input matrix as a static C two-dimensional array, + which is stored in row-major order, and let LAPACKE handle the work space + array allocation. The LAPACK base name for this function is gels, and we + will use double precision (d), so the LAPACKE function name is LAPACKE_dgels. + + thus lda=3 and ldb=2. The output for each right hand side is stored in b as + consecutive vectors of length 3. The correct answer for this problem is + the 3-by-2 matrix + + ( 2 1 ) + ( 1 1 ) + ( 1 2 ) + + A complete C program for this example is given below. Note that when the arrays + are passed to the LAPACK routine, they must be dereferenced, since LAPACK is + expecting arrays of type double *, not double **. + + + LAPACKE Interface + ================= + + LAPACKE_dgels (row-major, high-level) Example Program Results + + -- LAPACKE Example routine (version 3.5.0) -- + -- LAPACK is a software package provided by Univ. of Tennessee, -- + -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + February 2012 + +*/ +/* Calling DGELS using row-major order */ + +/* Includes */ +#include +#include +#include "lapacke_example_aux.h" + +/* Main program */ +int main (int argc, const char * argv[]) +{ + /* Locals */ + double A[5][3] = {1,1,1,2,3,4,3,5,2,4,2,5,5,4,3}; + double b[5][2] = {-10,-3,12,14,14,12,16,16,18,16}; + lapack_int info,m,n,lda,ldb,nrhs; + int i,j; + + /* Initialization */ + m = 5; + n = 3; + nrhs = 2; + lda = 3; + ldb = 2; + + /* Print Entry Matrix */ + print_matrix_rowmajor( "Entry Matrix A", m, n, *A, lda ); + /* Print Right Rand Side */ + print_matrix_rowmajor( "Right Hand Side b", n, nrhs, *b, ldb ); + printf( "\n" ); + + /* Executable statements */ + printf( "LAPACKE_dgels (row-major, high-level) Example Program Results\n" ); + /* Solve least squares problem*/ + info = LAPACKE_dgels(LAPACK_ROW_MAJOR,'N',m,n,nrhs,*A,lda,*b,ldb); + + /* Print Solution */ + print_matrix_rowmajor( "Solution", n, nrhs, *b, ldb ); + printf( "\n" ); + exit( 0 ); +} /* End of LAPACKE_dgels Example */ diff --git a/lapack-netlib/lapacke/example/example_DGESV_colmajor.c b/lapack-netlib/lapacke/example/example_DGESV_colmajor.c new file mode 100644 index 000000000..be0432c0c --- /dev/null +++ b/lapack-netlib/lapacke/example/example_DGESV_colmajor.c @@ -0,0 +1,111 @@ +/* + LAPACKE_dgesv Example + ===================== + + The program computes the solution to the system of linear + equations with a square matrix A and multiple + right-hand sides B, where A is the coefficient matrix + and b is the right-hand side matrix: + + Description + =========== + + The routine solves for X the system of linear equations A*X = B, + where A is an n-by-n matrix, the columns of matrix B are individual + right-hand sides, and the columns of X are the corresponding + solutions. + + The LU decomposition with partial pivoting and row interchanges is + used to factor A as A = P*L*U, where P is a permutation matrix, L + is unit lower triangular, and U is upper triangular. The factored + form of A is then used to solve the system of equations A*X = B. + + LAPACKE Interface + ================= + + LAPACKE_dgesv (col-major, high-level) Example Program Results + + -- LAPACKE Example routine (version 3.5.0) -- + -- LAPACK is a software package provided by Univ. of Tennessee, -- + -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + February 2012 + +*/ +/* Includes */ +#include +#include +#include +#include "lapacke.h" +#include "lapacke_example_aux.h" + +/* Main program */ +int main(int argc, char **argv) { + + /* Locals */ + lapack_int n, nrhs, lda, ldb, info; + int i, j; + double normr, normb; + /* Local arrays */ + double *A, *b, *Acopy, *bcopy; + lapack_int *ipiv; + + /* Default Value */ + n = 5; nrhs = 1; + + /* Arguments */ + for( i = 1; i < argc; i++ ) { + if( strcmp( argv[i], "-n" ) == 0 ) { + n = atoi(argv[i+1]); + i++; + } + if( strcmp( argv[i], "-nrhs" ) == 0 ) { + nrhs = atoi(argv[i+1]); + i++; + } + } + + /* Initialization */ + lda=n, ldb=n; + A = (double *)malloc(n*n*sizeof(double)) ; + if (A==NULL){ printf("error of memory allocation\n"); exit(0); } + b = (double *)malloc(n*nrhs*sizeof(double)) ; + if (b==NULL){ printf("error of memory allocation\n"); exit(0); } + ipiv = (lapack_int *)malloc(n*sizeof(lapack_int)) ; + if (ipiv==NULL){ printf("error of memory allocation\n"); exit(0); } + + for( i = 0; i < n; i++ ) { + for( j = 0; j < n; j++ ) A[i+j*lda] = ((double) rand()) / ((double) RAND_MAX) - 0.5; + } + + for(i=0;i 0 ) { + printf( "The diagonal element of the triangular factor of A,\n" ); + printf( "U(%i,%i) is zero, so that A is singular;\n", info, info ); + printf( "the solution could not be computed.\n" ); + exit( 1 ); + } + if (info <0) exit( 1 ); + /* Print solution */ + print_matrix_colmajor( "Solution", n, nrhs, b, ldb ); + /* Print details of LU factorization */ + print_matrix_colmajor( "Details of LU factorization", n, n, A, lda ); + /* Print pivot indices */ + print_vector( "Pivot indices", n, ipiv ); + exit( 0 ); +} /* End of LAPACKE_dgesv Example */ + diff --git a/lapack-netlib/lapacke/example/example_DGESV_rowmajor.c b/lapack-netlib/lapacke/example/example_DGESV_rowmajor.c index a932e8093..4406733ac 100644 --- a/lapack-netlib/lapacke/example/example_DGESV_rowmajor.c +++ b/lapack-netlib/lapacke/example/example_DGESV_rowmajor.c @@ -1,44 +1,14 @@ -/******************************************************************************* -* Copyright (C) 2009-2011 Intel Corporation. All Rights Reserved. -* The information and material ("Material") provided below is owned by Intel -* Corporation or its suppliers or licensors, and title to such Material remains -* with Intel Corporation or its suppliers or licensors. The Material contains -* proprietary information of Intel or its suppliers and licensors. The Material -* is protected by worldwide copyright laws and treaty provisions. No part of -* the Material may be copied, reproduced, published, uploaded, posted, -* transmitted, or distributed in any way without Intel's prior express written -* permission. No license under any patent, copyright or other intellectual -* property rights in the Material is granted to or conferred upon you, either -* expressly, by implication, inducement, estoppel or otherwise. Any license -* under such intellectual property rights must be express and approved by Intel -* in writing. -* -******************************************************************************** -*/ /* - LAPACKE_dgesv Example. - ====================== + LAPACKE_dgesv Example + ===================== The program computes the solution to the system of linear equations with a square matrix A and multiple - right-hand sides B, where A is the coefficient matrix: - - 6.80 -6.05 -0.45 8.32 -9.67 - -2.11 -3.30 2.58 2.71 -5.14 - 5.66 5.36 -2.70 4.35 -7.26 - 5.97 -4.44 0.27 -7.17 6.08 - 8.23 1.08 9.04 2.14 -6.87 - - and B is the right-hand side matrix: - - 4.02 -1.56 9.81 - 6.19 4.00 -4.09 - -8.22 -8.67 -4.57 - -7.57 1.75 -8.61 - -3.03 2.86 8.99 - - Description. - ============ + right-hand sides B, where A is the coefficient matrix + and b is the right-hand side matrix: + + Description + =========== The routine solves for X the system of linear equations A*X = B, where A is an n-by-n matrix, the columns of matrix B are individual @@ -50,71 +20,74 @@ is unit lower triangular, and U is upper triangular. The factored form of A is then used to solve the system of equations A*X = B. - Example Program Results. - ======================== - - LAPACKE_dgesv (row-major, high-level) Example Program Results + LAPACKE Interface + ================= - Solution - -0.80 -0.39 0.96 - -0.70 -0.55 0.22 - 0.59 0.84 1.90 - 1.32 -0.10 5.36 - 0.57 0.11 4.04 + LAPACKE_dgesv (row-major, high-level) Example Program Results - Details of LU factorization - 8.23 1.08 9.04 2.14 -6.87 - 0.83 -6.94 -7.92 6.55 -3.99 - 0.69 -0.67 -14.18 7.24 -5.19 - 0.73 0.75 0.02 -13.82 14.19 - -0.26 0.44 -0.59 -0.34 -3.43 + -- LAPACKE Example routine (version 3.5.0) -- + -- LAPACK is a software package provided by Univ. of Tennessee, -- + -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + February 2012 - Pivot indices - 5 5 3 4 5 */ #include #include -#include "lapacke.h" - -/* Auxiliary routines prototypes */ -extern void print_matrix( char* desc, lapack_int m, lapack_int n, double* a, lapack_int lda ); -extern void print_int_vector( char* desc, lapack_int n, lapack_int* a ); - -/* Parameters */ -#define N 5 -#define NRHS 3 -#define LDA N -#define LDB NRHS +#include +#include +#include "lapacke_example_aux.h" /* Main program */ -int main() { +int main(int argc, char **argv) { + /* Locals */ - lapack_int n = N, nrhs = NRHS, lda = LDA, ldb = LDB, info; + lapack_int n, nrhs, lda, ldb, info; + int i, j; + double normr, normb; /* Local arrays */ - lapack_int ipiv[N]; - double a[LDA*N] = { - 6.80, -6.05, -0.45, 8.32, -9.67, - -2.11, -3.30, 2.58, 2.71, -5.14, - 5.66, 5.36, -2.70, 4.35, -7.26, - 5.97, -4.44, 0.27, -7.17, 6.08, - 8.23, 1.08, 9.04, 2.14, -6.87 - }; - double b[LDB*N] = { - 4.02, -1.56, 9.81, - 6.19, 4.00, -4.09, - -8.22, -8.67, -4.57, - -7.57, 1.75, -8.61, - -3.03, 2.86, 8.99 - }; + double *A, *b, *Acopy, *bcopy; + lapack_int *ipiv; + + /* Default Value */ + n = 5; nrhs = 1; + + /* Arguments */ + for( i = 1; i < argc; i++ ) { + if( strcmp( argv[i], "-n" ) == 0 ) { + n = atoi(argv[i+1]); + i++; + } + if( strcmp( argv[i], "-nrhs" ) == 0 ) { + nrhs = atoi(argv[i+1]); + i++; + } + } + + /* Initialization */ + lda=n, ldb=nrhs; + A = (double *)malloc(n*n*sizeof(double)) ; + if (A==NULL){ printf("error of memory allocation\n"); exit(0); } + b = (double *)malloc(n*nrhs*sizeof(double)) ; + if (b==NULL){ printf("error of memory allocation\n"); exit(0); } + ipiv = (lapack_int *)malloc(n*sizeof(lapack_int)) ; + if (ipiv==NULL){ printf("error of memory allocation\n"); exit(0); } + + for( i = 0; i < n; i++ ) { + for( j = 0; j < n; j++ ) A[i*lda+j] = ((double) rand()) / ((double) RAND_MAX) - 0.5; + } + + for(i=0;i 0 ) { @@ -123,29 +96,13 @@ int main() { printf( "the solution could not be computed.\n" ); exit( 1 ); } + if (info <0) exit( 1 ); /* Print solution */ - print_matrix( "Solution", n, nrhs, b, ldb ); + print_matrix_rowmajor( "Solution", n, nrhs, b, ldb ); /* Print details of LU factorization */ - print_matrix( "Details of LU factorization", n, n, a, lda ); + print_matrix_rowmajor( "Details of LU factorization", n, n, A, lda ); /* Print pivot indices */ - print_int_vector( "Pivot indices", n, ipiv ); + print_vector( "Pivot indices", n, ipiv ); exit( 0 ); } /* End of LAPACKE_dgesv Example */ -/* Auxiliary routine: printing a matrix */ -void print_matrix( char* desc, lapack_int m, lapack_int n, double* a, lapack_int lda ) { - lapack_int i, j; - printf( "\n %s\n", desc ); - for( i = 0; i < m; i++ ) { - for( j = 0; j < n; j++ ) printf( " %6.2f", a[i*lda+j] ); - printf( "\n" ); - } -} - -/* Auxiliary routine: printing a vector of integers */ -void print_int_vector( char* desc, lapack_int n, lapack_int* a ) { - lapack_int j; - printf( "\n %s\n", desc ); - for( j = 0; j < n; j++ ) printf( " %6i", a[j] ); - printf( "\n" ); -} diff --git a/lapack-netlib/lapacke/example/example_user.c b/lapack-netlib/lapacke/example/example_user.c new file mode 100644 index 000000000..c481fa705 --- /dev/null +++ b/lapack-netlib/lapacke/example/example_user.c @@ -0,0 +1,97 @@ +#include +#include +#include "lapacke.h" + +/* Auxiliary routines prototypes */ +extern void print_matrix( char* desc, lapack_int m, lapack_int n, double* a, lapack_int lda ); +extern void print_int_vector( char* desc, lapack_int n, lapack_int* a ); + +/* Parameters */ +#define N 5 +#define NRHS 3 +#define LDA N +#define LDB NRHS + +/* Main program */ +int main() { + /* Locals */ + lapack_int n = N, nrhs = NRHS, lda = LDA, ldb = LDB, info; + /* Local arrays */ + lapack_int ipiv[N]; + double a[LDA*N] = { + 6.80, -6.05, -0.45, 8.32, -9.67, + -2.11, -3.30, 2.58, 2.71, -5.14, + 5.66, 5.36, -2.70, 4.35, -7.26, + 5.97, -4.44, 0.27, -7.17, 6.08, + 8.23, 1.08, 9.04, 2.14, -6.87 + }; + double b[LDB*N] = { + 4.02, -1.56, 9.81, + 6.19, 4.00, -4.09, + -8.22, -8.67, -4.57, + -7.57, 1.75, -8.61, + -3.03, 2.86, 8.99 + }; + + double aNorm; + double rcond; + char ONE_NORM = '1'; + lapack_int NROWS = n; + lapack_int NCOLS = n; + lapack_int LEADING_DIMENSION_A = n; + + /* Print Entry Matrix */ + print_matrix( "Entry Matrix A", n, n, a, lda ); + /* Print Right Rand Side */ + print_matrix( "Right Rand Side", n, nrhs, b, ldb ); + printf( "\n" ); + /* Executable statements */ + printf( "LAPACKE_dgecon Example Program Results\n" ); + aNorm = LAPACKE_dlange(LAPACK_ROW_MAJOR, ONE_NORM, NROWS, NCOLS, a, LEADING_DIMENSION_A); + info = LAPACKE_dgetrf(LAPACK_ROW_MAJOR, NROWS, NCOLS, a, LEADING_DIMENSION_A, ipiv); + info = LAPACKE_dgecon(LAPACK_ROW_MAJOR, ONE_NORM, n, a, LEADING_DIMENSION_A, aNorm, &rcond); // aNorm should be 35.019999999999996 + double work[4*N]; + int iwork[N]; + //info = LAPACKE_dgecon_work(LAPACK_ROW_MAJOR, ONE_NORM, n, a, LEADING_DIMENSION_A, aNorm, &rcond, work, iwork); // aNorm should be 35.019999999999996 + //dgecon_( &ONE_NORM, &n, a, &LEADING_DIMENSION_A, &aNorm, &rcond, work, iwork, &info ); + /* Check for the exact singularity */ + if (info == 0) + { + printf("LAPACKE_dgecon completed SUCCESSFULLY...\n"); + } + else if ( info < 0 ) + { + printf( "Element %d of A had an illegal value\n", -info ); + exit( 1 ); + } + else + { + printf( "Unrecognized value of INFO = %d\n", info ); + exit( 1 ); + } + + /* Print solution */ + printf("LAPACKE_dlange / One-norm of A = %lf\n", aNorm); + printf("LAPACKE_dgecon / RCOND of A = %f\n", rcond); + exit( 0 ); +} /* End of LAPACKE_dgesv Example */ + +/* Auxiliary routine: printing a matrix */ +void print_matrix( char* desc, lapack_int m, lapack_int n, double* a, lapack_int lda ) { + lapack_int i, j; + printf( "\n %s\n", desc ); + for( i = 0; i < m; i++ ) { + for( j = 0; j < n; j++ ) printf( " %6.2f", a[i*lda+j] ); + printf( "\n" ); + } +} + +/* Auxiliary routine: printing a vector of integers */ +void print_int_vector( char* desc, lapack_int n, lapack_int* a ) { + lapack_int j; + printf( "\n %s\n", desc ); + for( j = 0; j < n; j++ ) printf( " %6i", a[j] ); + printf( "\n" ); +} + + diff --git a/lapack-netlib/lapacke/example/lapacke_example_aux.c b/lapack-netlib/lapacke/example/lapacke_example_aux.c new file mode 100644 index 000000000..dfd60eb1d --- /dev/null +++ b/lapack-netlib/lapacke/example/lapacke_example_aux.c @@ -0,0 +1,33 @@ +#include +#include + +/* Auxiliary routine: printing a matrix */ +void print_matrix_rowmajor( char* desc, lapack_int m, lapack_int n, double* mat, lapack_int ldm ) { + lapack_int i, j; + printf( "\n %s\n", desc ); + + for( i = 0; i < m; i++ ) { + for( j = 0; j < n; j++ ) printf( " %6.2f", mat[i*ldm+j] ); + printf( "\n" ); + } +} + + +/* Auxiliary routine: printing a matrix */ +void print_matrix_colmajor( char* desc, lapack_int m, lapack_int n, double* mat, lapack_int ldm ) { + lapack_int i, j; + printf( "\n %s\n", desc ); + + for( i = 0; i < m; i++ ) { + for( j = 0; j < n; j++ ) printf( " %6.2f", mat[i+j*ldm] ); + printf( "\n" ); + } +} + +/* Auxiliary routine: printing a vector of integers */ +void print_vector( char* desc, lapack_int n, lapack_int* vec ) { + lapack_int j; + printf( "\n %s\n", desc ); + for( j = 0; j < n; j++ ) printf( " %6i", vec[j] ); + printf( "\n" ); +} diff --git a/lapack-netlib/lapacke/example/lapacke_example_aux.h b/lapack-netlib/lapacke/example/lapacke_example_aux.h new file mode 100644 index 000000000..f83351152 --- /dev/null +++ b/lapack-netlib/lapacke/example/lapacke_example_aux.h @@ -0,0 +1,9 @@ +#ifndef _LAPACKE_EXAMPLE_AUX_ +#define _LAPACKE_EXAMPLE_AUX_ + + +void print_matrix_rowmajor( char* desc, lapack_int m, lapack_int n, double* mat, lapack_int ldm ); +void print_matrix_colmajor( char* desc, lapack_int m, lapack_int n, double* mat, lapack_int ldm ); +void print_vector( char* desc, lapack_int n, lapack_int* vec ); + +#endif /* _LAPACKE_EXAMPLE_AUX_*/ diff --git a/lapack-netlib/lapacke/include/lapacke.h b/lapack-netlib/lapacke/include/lapacke.h index e0367a25b..a31c10d6d 100644 --- a/lapack-netlib/lapacke/include/lapacke.h +++ b/lapack-netlib/lapacke/include/lapacke.h @@ -41,10 +41,6 @@ #include "lapacke_config.h" #endif -#ifdef __cplusplus -extern "C" { -#endif /* __cplusplus */ - #include #ifndef lapack_int @@ -106,6 +102,10 @@ lapack_complex_double lapack_make_complex_double( double re, double im ); #endif +#ifdef __cplusplus +extern "C" { +#endif /* __cplusplus */ + #ifndef LAPACKE_malloc #define LAPACKE_malloc( size ) malloc( size ) #endif @@ -2102,6 +2102,17 @@ lapack_int LAPACKE_clacgv( lapack_int n, lapack_complex_float* x, lapack_int LAPACKE_zlacgv( lapack_int n, lapack_complex_double* x, lapack_int incx ); +lapack_int LAPACKE_slacn2( lapack_int n, float* v, float* x, lapack_int* isgn, + float* est, lapack_int* kase, lapack_int* isave ); +lapack_int LAPACKE_dlacn2( lapack_int n, double* v, double* x, lapack_int* isgn, + double* est, lapack_int* kase, lapack_int* isave ); +lapack_int LAPACKE_clacn2( lapack_int n, lapack_complex_float* v, + lapack_complex_float* x, + float* est, lapack_int* kase, lapack_int* isave ); +lapack_int LAPACKE_zlacn2( lapack_int n, lapack_complex_double* v, + lapack_complex_double* x, + double* est, lapack_int* kase, lapack_int* isave ); + lapack_int LAPACKE_slacpy( int matrix_order, char uplo, lapack_int m, lapack_int n, const float* a, lapack_int lda, float* b, lapack_int ldb ); @@ -2117,6 +2128,13 @@ lapack_int LAPACKE_zlacpy( int matrix_order, char uplo, lapack_int m, lapack_int lda, lapack_complex_double* b, lapack_int ldb ); +lapack_int LAPACKE_clacp2( int matrix_order, char uplo, lapack_int m, + lapack_int n, const float* a, lapack_int lda, + lapack_complex_float* b, lapack_int ldb ); +lapack_int LAPACKE_zlacp2( int matrix_order, char uplo, lapack_int m, + lapack_int n, const double* a, lapack_int lda, + lapack_complex_double* b, lapack_int ldb ); + lapack_int LAPACKE_zlag2c( int matrix_order, lapack_int m, lapack_int n, const lapack_complex_double* a, lapack_int lda, lapack_complex_float* sa, lapack_int ldsa ); @@ -6883,6 +6901,21 @@ lapack_int LAPACKE_clacgv_work( lapack_int n, lapack_complex_float* x, lapack_int LAPACKE_zlacgv_work( lapack_int n, lapack_complex_double* x, lapack_int incx ); +lapack_int LAPACKE_slacn2_work( lapack_int n, float* v, float* x, + lapack_int* isgn, float* est, lapack_int* kase, + lapack_int* isave ); +lapack_int LAPACKE_dlacn2_work( lapack_int n, double* v, double* x, + lapack_int* isgn, double* est, lapack_int* kase, + lapack_int* isave ); +lapack_int LAPACKE_clacn2_work( lapack_int n, lapack_complex_float* v, + lapack_complex_float* x, + float* est, lapack_int* kase, + lapack_int* isave ); +lapack_int LAPACKE_zlacn2_work( lapack_int n, lapack_complex_double* v, + lapack_complex_double* x, + double* est, lapack_int* kase, + lapack_int* isave ); + lapack_int LAPACKE_slacpy_work( int matrix_order, char uplo, lapack_int m, lapack_int n, const float* a, lapack_int lda, float* b, lapack_int ldb ); @@ -6898,6 +6931,13 @@ lapack_int LAPACKE_zlacpy_work( int matrix_order, char uplo, lapack_int m, lapack_int lda, lapack_complex_double* b, lapack_int ldb ); +lapack_int LAPACKE_clacp2_work( int matrix_order, char uplo, lapack_int m, + lapack_int n, const float* a, lapack_int lda, + lapack_complex_float* b, lapack_int ldb ); +lapack_int LAPACKE_zlacp2_work( int matrix_order, char uplo, lapack_int m, + lapack_int n, const double* a, lapack_int lda, + lapack_complex_double* b, lapack_int ldb ); + lapack_int LAPACKE_zlag2c_work( int matrix_order, lapack_int m, lapack_int n, const lapack_complex_double* a, lapack_int lda, lapack_complex_float* sa, lapack_int ldsa ); @@ -8779,6 +8819,27 @@ lapack_int LAPACKE_zsysv_work( int matrix_order, char uplo, lapack_int n, lapack_complex_double* b, lapack_int ldb, lapack_complex_double* work, lapack_int lwork ); +lapack_int LAPACKE_ssysv_rook_work( int matrix_order, char uplo, lapack_int n, + lapack_int nrhs, float* a, lapack_int lda, + lapack_int* ipiv, float* b, lapack_int ldb, + float* work, lapack_int lwork ); +lapack_int LAPACKE_dsysv_rook_work( int matrix_order, char uplo, lapack_int n, + lapack_int nrhs, double* a, lapack_int lda, + lapack_int* ipiv, double* b, lapack_int ldb, + double* work, lapack_int lwork ); +lapack_int LAPACKE_csysv_rook_work( int matrix_order, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_float* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* work, + lapack_int lwork ); +lapack_int LAPACKE_zsysv_rook_work( int matrix_order, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_double* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* work, + lapack_int lwork ); + lapack_int LAPACKE_ssysvx_work( int matrix_order, char fact, char uplo, lapack_int n, lapack_int nrhs, const float* a, lapack_int lda, float* af, lapack_int ldaf, @@ -10593,6 +10654,20 @@ lapack_int LAPACKE_ztprfb_work( int matrix_order, char side, char trans, lapack_complex_double* b, lapack_int ldb, const double* work, lapack_int ldwork ); //LAPACK 3.X.X +lapack_int LAPACKE_ssysv_rook( int matrix_order, char uplo, lapack_int n, + lapack_int nrhs, float* a, lapack_int lda, + lapack_int* ipiv, float* b, lapack_int ldb ); +lapack_int LAPACKE_dsysv_rook( int matrix_order, char uplo, lapack_int n, + lapack_int nrhs, double* a, lapack_int lda, + lapack_int* ipiv, double* b, lapack_int ldb ); +lapack_int LAPACKE_csysv_rook( int matrix_order, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_float* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb ); +lapack_int LAPACKE_zsysv_rook( int matrix_order, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_double* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb ); lapack_int LAPACKE_csyr( int matrix_order, char uplo, lapack_int n, lapack_complex_float alpha, const lapack_complex_float* x, lapack_int incx, @@ -10602,6 +10677,26 @@ lapack_int LAPACKE_zsyr( int matrix_order, char uplo, lapack_int n, const lapack_complex_double* x, lapack_int incx, lapack_complex_double* a, lapack_int lda ); +lapack_int LAPACKE_ssysv_rook_work( int matrix_order, char uplo, lapack_int n, + lapack_int nrhs, float* a, lapack_int lda, + lapack_int* ipiv, float* b, lapack_int ldb, + float* work, lapack_int lwork ); +lapack_int LAPACKE_dsysv_rook_work( int matrix_order, char uplo, lapack_int n, + lapack_int nrhs, double* a, lapack_int lda, + lapack_int* ipiv, double* b, lapack_int ldb, + double* work, lapack_int lwork ); +lapack_int LAPACKE_csysv_rook_work( int matrix_order, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_float* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* work, + lapack_int lwork ); +lapack_int LAPACKE_zsysv_rook_work( int matrix_order, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_double* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* work, + lapack_int lwork ); lapack_int LAPACKE_csyr_work( int matrix_order, char uplo, lapack_int n, lapack_complex_float alpha, const lapack_complex_float* x, @@ -11485,10 +11580,16 @@ void LAPACKE_ilaver( const lapack_int* vers_major, #define LAPACK_dgeqr2 LAPACK_GLOBAL(dgeqr2,DGEQR2) #define LAPACK_cgeqr2 LAPACK_GLOBAL(cgeqr2,CGEQR2) #define LAPACK_zgeqr2 LAPACK_GLOBAL(zgeqr2,ZGEQR2) +#define LAPACK_slacn2 LAPACK_GLOBAL(slacn2,SLACN2) +#define LAPACK_dlacn2 LAPACK_GLOBAL(dlacn2,DLACN2) +#define LAPACK_clacn2 LAPACK_GLOBAL(clacn2,CLACN2) +#define LAPACK_zlacn2 LAPACK_GLOBAL(zlacn2,ZLACN2) #define LAPACK_slacpy LAPACK_GLOBAL(slacpy,SLACPY) #define LAPACK_dlacpy LAPACK_GLOBAL(dlacpy,DLACPY) #define LAPACK_clacpy LAPACK_GLOBAL(clacpy,CLACPY) #define LAPACK_zlacpy LAPACK_GLOBAL(zlacpy,ZLACPY) +#define LAPACK_clacp2 LAPACK_GLOBAL(clacp2,CLACP2) +#define LAPACK_zlacp2 LAPACK_GLOBAL(zlacp2,ZLACP2) #define LAPACK_sgetf2 LAPACK_GLOBAL(sgetf2,SGETF2) #define LAPACK_dgetf2 LAPACK_GLOBAL(dgetf2,DGETF2) #define LAPACK_cgetf2 LAPACK_GLOBAL(cgetf2,CGETF2) @@ -11647,6 +11748,10 @@ void LAPACKE_ilaver( const lapack_int* vers_major, #define LAPACK_ctprfb LAPACK_GLOBAL(ctprfb,CTPRFB) #define LAPACK_ztprfb LAPACK_GLOBAL(ztprfb,ZTPRFB) // LAPACK 3.X.X +#define LAPACK_ssysv_rook LAPACK_GLOBAL(ssysv_rook,SSYSV_ROOK) +#define LAPACK_dsysv_rook LAPACK_GLOBAL(dsysv_rook,DSYSV_ROOK) +#define LAPACK_csysv_rook LAPACK_GLOBAL(csysv_rook,CSYSV_ROOK) +#define LAPACK_zsysv_rook LAPACK_GLOBAL(zsysv_rook,ZSYSV_ROOK) #define LAPACK_csyr LAPACK_GLOBAL(csyr,CSYR) #define LAPACK_zsyr LAPACK_GLOBAL(zsyr,ZSYR) #define LAPACK_ilaver LAPACK_GLOBAL(ilaver,ILAVER) @@ -15672,6 +15777,16 @@ void LAPACK_cgeqr2( lapack_int* m, lapack_int* n, lapack_complex_float* a, void LAPACK_zgeqr2( lapack_int* m, lapack_int* n, lapack_complex_double* a, lapack_int* lda, lapack_complex_double* tau, lapack_complex_double* work, lapack_int *info ); +void LAPACK_slacn2( lapack_int* n, float* v, float* x, lapack_int* isgn, + float* est, lapack_int* kase, lapack_int* isave ); +void LAPACK_dlacn2( lapack_int* n, double* v, double* x, lapack_int* isgn, + double* est, lapack_int* kase, lapack_int* isave ); +void LAPACK_clacn2( lapack_int* n, lapack_complex_float* v, + lapack_complex_float* x, float* est, + lapack_int* kase, lapack_int* isave ); +void LAPACK_zlacn2( lapack_int* n, lapack_complex_double* v, + lapack_complex_double* x, double* est, + lapack_int* kase, lapack_int* isave ); void LAPACK_slacpy( char* uplo, lapack_int* m, lapack_int* n, const float* a, lapack_int* lda, float* b, lapack_int* ldb ); void LAPACK_dlacpy( char* uplo, lapack_int* m, lapack_int* n, const double* a, @@ -15682,6 +15797,13 @@ void LAPACK_clacpy( char* uplo, lapack_int* m, lapack_int* n, void LAPACK_zlacpy( char* uplo, lapack_int* m, lapack_int* n, const lapack_complex_double* a, lapack_int* lda, lapack_complex_double* b, lapack_int* ldb ); + +void LAPACK_clacp2( char* uplo, lapack_int* m, lapack_int* n, const float* a, + lapack_int* lda, lapack_complex_float* b, lapack_int* ldb ); +void LAPACK_zlacp2( char* uplo, lapack_int* m, lapack_int* n, const double* a, + lapack_int* lda, lapack_complex_double* b, + lapack_int* ldb ); + void LAPACK_sgetf2( lapack_int* m, lapack_int* n, float* a, lapack_int* lda, lapack_int* ipiv, lapack_int *info ); void LAPACK_dgetf2( lapack_int* m, lapack_int* n, double* a, lapack_int* lda, @@ -16288,7 +16410,25 @@ void LAPACK_ztprfb( char* side, char* trans, char* direct, char* storev, lapack_complex_double* a, lapack_int* lda, lapack_complex_double* b, lapack_int* ldb, const double* work, lapack_int* ldwork ); -// LAPACK 3.X.X +// LAPACK 3.5.0 +void LAPACK_ssysv_rook( char* uplo, lapack_int* n, lapack_int* nrhs, float* a, + lapack_int* lda, lapack_int* ipiv, float* b, + lapack_int* ldb, float* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_dsysv_rook( char* uplo, lapack_int* n, lapack_int* nrhs, double* a, + lapack_int* lda, lapack_int* ipiv, double* b, + lapack_int* ldb, double* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_csysv_rook( char* uplo, lapack_int* n, lapack_int* nrhs, + lapack_complex_float* a, lapack_int* lda, + lapack_int* ipiv, lapack_complex_float* b, + lapack_int* ldb, lapack_complex_float* work, + lapack_int* lwork, lapack_int *info ); +void LAPACK_zsysv_rook( char* uplo, lapack_int* n, lapack_int* nrhs, + lapack_complex_double* a, lapack_int* lda, + lapack_int* ipiv, lapack_complex_double* b, + lapack_int* ldb, lapack_complex_double* work, + lapack_int* lwork, lapack_int *info ); void LAPACK_csyr( char* uplo, lapack_int* n, lapack_complex_float* alpha, const lapack_complex_float* x, lapack_int* incx, lapack_complex_float* a, lapack_int* lda ); diff --git a/lapack-netlib/lapacke/src/CMakeLists.txt b/lapack-netlib/lapacke/src/CMakeLists.txt index 56698172d..e1b5cfd57 100644 --- a/lapack-netlib/lapacke/src/CMakeLists.txt +++ b/lapack-netlib/lapacke/src/CMakeLists.txt @@ -233,6 +233,10 @@ lapacke_chseqr.c lapacke_chseqr_work.c lapacke_clacgv.c lapacke_clacgv_work.c +lapacke_clacn2.c +lapacke_clacn2_work.c +lapacke_clacp2.c +lapacke_clacp2_work.c lapacke_clacpy.c lapacke_clacpy_work.c lapacke_clag2z.c @@ -368,6 +372,8 @@ lapacke_csyequb_work.c lapacke_csyrfs.c lapacke_csyrfs_work.c lapacke_csysv.c +lapacke_csysv_rook.c +lapacke_csysv_rook_work.c lapacke_csysv_work.c lapacke_csysvx.c lapacke_csysvx_work.c @@ -641,6 +647,8 @@ lapacke_dhsein.c lapacke_dhsein_work.c lapacke_dhseqr.c lapacke_dhseqr_work.c +lapacke_dlacn2.c +lapacke_dlacn2_work.c lapacke_dlacpy.c lapacke_dlacpy_work.c lapacke_dlag2s.c @@ -890,6 +898,8 @@ lapacke_dsygvx_work.c lapacke_dsyrfs.c lapacke_dsyrfs_work.c lapacke_dsysv.c +lapacke_dsysv_rook.c +lapacke_dsysv_rook_work.c lapacke_dsysv_work.c lapacke_dsysvx.c lapacke_dsysvx_work.c @@ -1127,6 +1137,8 @@ lapacke_shsein.c lapacke_shsein_work.c lapacke_shseqr.c lapacke_shseqr_work.c +lapacke_slacn2.c +lapacke_slacn2_work.c lapacke_slacpy.c lapacke_slacpy_work.c lapacke_slag2d.c @@ -1372,6 +1384,8 @@ lapacke_ssygvx_work.c lapacke_ssyrfs.c lapacke_ssyrfs_work.c lapacke_ssysv.c +lapacke_ssysv_rook.c +lapacke_ssysv_rook_work.c lapacke_ssysv_work.c lapacke_ssysvx.c lapacke_ssysvx_work.c @@ -1695,6 +1709,10 @@ lapacke_zhseqr.c lapacke_zhseqr_work.c lapacke_zlacgv.c lapacke_zlacgv_work.c +lapacke_zlacn2.c +lapacke_zlacn2_work.c +lapacke_zlacp2.c +lapacke_zlacp2_work.c lapacke_zlacpy.c lapacke_zlacpy_work.c lapacke_zlag2c.c @@ -1830,6 +1848,8 @@ lapacke_zsyequb_work.c lapacke_zsyrfs.c lapacke_zsyrfs_work.c lapacke_zsysv.c +lapacke_zsysv_rook.c +lapacke_zsysv_rook_work.c lapacke_zsysv_work.c lapacke_zsysvx.c lapacke_zsysvx_work.c @@ -2007,4 +2027,4 @@ lapacke_slagsy.c lapacke_slagsy_work.c lapacke_zlagsy.c lapacke_zlagsy_work.c -) \ No newline at end of file +) diff --git a/lapack-netlib/lapacke/src/Makefile b/lapack-netlib/lapacke/src/Makefile index 6297b9e76..51a947e22 100644 --- a/lapack-netlib/lapacke/src/Makefile +++ b/lapack-netlib/lapacke/src/Makefile @@ -34,7 +34,7 @@ # include ../../make.inc -CSRC_OBJ = \ +SRC_OBJ = \ lapacke_cbbcsd.o \ lapacke_cbbcsd_work.o \ lapacke_cbdsqr.o \ @@ -267,6 +267,10 @@ lapacke_chseqr.o \ lapacke_chseqr_work.o \ lapacke_clacgv.o \ lapacke_clacgv_work.o \ +lapacke_clacn2.o \ +lapacke_clacn2_work.o \ +lapacke_clacp2.o \ +lapacke_clacp2_work.o \ lapacke_clacpy.o \ lapacke_clacpy_work.o \ lapacke_clag2z.o \ @@ -402,6 +406,8 @@ lapacke_csyequb_work.o \ lapacke_csyrfs.o \ lapacke_csyrfs_work.o \ lapacke_csysv.o \ +lapacke_csysv_rook.o \ +lapacke_csysv_rook_work.o \ lapacke_csysv_work.o \ lapacke_csysvx.o \ lapacke_csysvx_work.o \ @@ -526,9 +532,7 @@ lapacke_cunmtr_work.o \ lapacke_cupgtr.o \ lapacke_cupgtr_work.o \ lapacke_cupmtr.o \ -lapacke_cupmtr_work.o - -DSRC_OBJ = \ +lapacke_cupmtr_work.o \ lapacke_dbbcsd.o \ lapacke_dbbcsd_work.o \ lapacke_dbdsdc.o \ @@ -677,6 +681,8 @@ lapacke_dhsein.o \ lapacke_dhsein_work.o \ lapacke_dhseqr.o \ lapacke_dhseqr_work.o \ +lapacke_dlacn2.o \ +lapacke_dlacn2_work.o \ lapacke_dlacpy.o \ lapacke_dlacpy_work.o \ lapacke_dlag2s.o \ @@ -926,6 +932,8 @@ lapacke_dsygvx_work.o \ lapacke_dsyrfs.o \ lapacke_dsyrfs_work.o \ lapacke_dsysv.o \ +lapacke_dsysv_rook.o \ +lapacke_dsysv_rook_work.o \ lapacke_dsysv_work.o \ lapacke_dsysvx.o \ lapacke_dsysvx_work.o \ @@ -1014,9 +1022,7 @@ lapacke_dtrttf_work.o \ lapacke_dtrttp.o \ lapacke_dtrttp_work.o \ lapacke_dtzrzf.o \ -lapacke_dtzrzf_work.o - -SSRC_OBJ = \ +lapacke_dtzrzf_work.o \ lapacke_sbbcsd.o \ lapacke_sbbcsd_work.o \ lapacke_sbdsdc.o \ @@ -1165,6 +1171,8 @@ lapacke_shsein.o \ lapacke_shsein_work.o \ lapacke_shseqr.o \ lapacke_shseqr_work.o \ +lapacke_slacn2.o \ +lapacke_slacn2_work.o \ lapacke_slacpy.o \ lapacke_slacpy_work.o \ lapacke_slag2d.o \ @@ -1410,6 +1418,8 @@ lapacke_ssygvx_work.o \ lapacke_ssyrfs.o \ lapacke_ssyrfs_work.o \ lapacke_ssysv.o \ +lapacke_ssysv_rook.o \ +lapacke_ssysv_rook_work.o \ lapacke_ssysv_work.o \ lapacke_ssysvx.o \ lapacke_ssysvx_work.o \ @@ -1496,9 +1506,7 @@ lapacke_strttf_work.o \ lapacke_strttp.o \ lapacke_strttp_work.o \ lapacke_stzrzf.o \ -lapacke_stzrzf_work.o - -ZSRC_OBJ = \ +lapacke_stzrzf_work.o \ lapacke_zbbcsd.o \ lapacke_zbbcsd_work.o \ lapacke_zbdsqr.o \ @@ -1735,6 +1743,10 @@ lapacke_zhseqr.o \ lapacke_zhseqr_work.o \ lapacke_zlacgv.o \ lapacke_zlacgv_work.o \ +lapacke_zlacn2.o \ +lapacke_zlacn2_work.o \ +lapacke_zlacp2.o \ +lapacke_zlacp2_work.o \ lapacke_zlacpy.o \ lapacke_zlacpy_work.o \ lapacke_zlag2c.o \ @@ -1870,6 +1882,8 @@ lapacke_zsyequb_work.o \ lapacke_zsyrfs.o \ lapacke_zsyrfs_work.o \ lapacke_zsysv.o \ +lapacke_zsysv_rook.o \ +lapacke_zsysv_rook_work.o \ lapacke_zsysv_work.o \ lapacke_zsysvx.o \ lapacke_zsysvx_work.o \ @@ -2047,29 +2061,24 @@ lapacke_slagsy_work.o \ lapacke_zlagsy.o \ lapacke_zlagsy_work.o -COBJ_FILES := $(CSRC_OBJ) -SOBJ_FILES := $(SSRC_OBJ) -DOBJ_FILES := $(DSRC_OBJ) -ZOBJ_FILES := $(ZSRC_OBJ) -ifdef LAPACKE_EXTENDED -OBJ_FILES += $(SRCX_OBJ) -endif +ALLOBJ = $(SRC_OBJ) ifdef LAPACKE_TESTING -OBJ_FILES += $(MATGEN_OBJ) +ALLOBJ += $(MATGEN_OBJ) endif +ifdef USEXBLAS +ALLXOBJ = $(SXLASRC) $(DXLASRC) $(CXLASRC) $(ZXLASRC) +endif + + +OBJ_FILES := $(C_FILES:.o=.o) + all: ../../$(LAPACKELIB) -../../$(LAPACKELIB): $(COBJ_FILES) $(DOBJ_FILES) $(SOBJ_FILES) $(ZOBJ_FILES) $(OBJ_FILES) - $(ARCH) $(ARCHFLAGS) ../../$(LAPACKELIB) $(COBJ_FILES) - $(ARCH) $(ARCHFLAGS) ../../$(LAPACKELIB) $(DOBJ_FILES) - $(ARCH) $(ARCHFLAGS) ../../$(LAPACKELIB) $(SOBJ_FILES) - $(ARCH) $(ARCHFLAGS) ../../$(LAPACKELIB) $(ZOBJ_FILES) -ifneq ($(strip $(OBJ_FILES)),) - $(ARCH) $(ARCHFLAGS) ../../$(LAPACKELIB) $(OBJ_FILES) -endif +../../$(LAPACKELIB): $(ALLOBJ) $(ALLXOBJ) + $(ARCH) $(ARCHFLAGS) ../../$(LAPACKELIB) $(ALLOBJ) $(ALLXOBJ) $(RANLIB) ../../$(LAPACKELIB) .c.o: diff --git a/lapack-netlib/lapacke/src/lapacke_clacn2.c b/lapack-netlib/lapacke/src/lapacke_clacn2.c new file mode 100644 index 000000000..890c486f8 --- /dev/null +++ b/lapack-netlib/lapacke/src/lapacke_clacn2.c @@ -0,0 +1,50 @@ +/***************************************************************************** + Copyright (c) 2010, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native high-level C interface to LAPACK function clacn2 +* Author: Intel Corporation +* Generated October, 2012 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_clacn2( lapack_int n, lapack_complex_float* v, + lapack_complex_float* x, + float* est, lapack_int* kase, lapack_int* isave ) +{ +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_s_nancheck( 1, est, 1 ) ) { + return -5; + } + if( LAPACKE_c_nancheck( n, x, 1 ) ) { + return -3; + } +#endif + return LAPACKE_clacn2_work( n, v, x, est, kase, isave ); +} diff --git a/lapack-netlib/lapacke/src/lapacke_clacn2_work.c b/lapack-netlib/lapacke/src/lapacke_clacn2_work.c new file mode 100644 index 000000000..970b7d7dd --- /dev/null +++ b/lapack-netlib/lapacke/src/lapacke_clacn2_work.c @@ -0,0 +1,45 @@ +/***************************************************************************** + Copyright (c) 2010, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native middle-level C interface to LAPACK function clacn2 +* Author: Intel Corporation +* Generated October, 2012 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_clacn2_work( lapack_int n, lapack_complex_float* v, + lapack_complex_float* x, + float* est, lapack_int* kase, + lapack_int* isave ) +{ + lapack_int info = 0; + /* Call LAPACK function and adjust info */ + LAPACK_clacn2( &n, v, x, est, kase, isave ); + return info; +} diff --git a/lapack-netlib/lapacke/src/lapacke_clacp2.c b/lapack-netlib/lapacke/src/lapacke_clacp2.c new file mode 100644 index 000000000..fa7e825f9 --- /dev/null +++ b/lapack-netlib/lapacke/src/lapacke_clacp2.c @@ -0,0 +1,51 @@ +/***************************************************************************** + Copyright (c) 2011, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native high-level C interface to LAPACK function clacp2 +* Author: Intel Corporation +* Generated January, 2013 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_clacp2( int matrix_order, char uplo, lapack_int m, + lapack_int n, const float* a, lapack_int lda, + lapack_complex_float* b, lapack_int ldb ) +{ + if( matrix_order != LAPACK_COL_MAJOR && matrix_order != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_clacp2", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_sge_nancheck( matrix_order, m, n, a, lda ) ) { + return -5; + } +#endif + return LAPACKE_clacp2_work( matrix_order, uplo, m, n, a, lda, b, ldb ); +} diff --git a/lapack-netlib/lapacke/src/lapacke_clacp2_work.c b/lapack-netlib/lapacke/src/lapacke_clacp2_work.c new file mode 100644 index 000000000..479fd9c2b --- /dev/null +++ b/lapack-netlib/lapacke/src/lapacke_clacp2_work.c @@ -0,0 +1,96 @@ +/***************************************************************************** + Copyright (c) 2010, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native middle-level C interface to LAPACK function clacp2 +* Author: Intel Corporation +* Generated January, 2013 +*****************************************************************************/ + +#include "lapacke.h" +#include "lapacke_utils.h" + +lapack_int LAPACKE_clacp2_work( int matrix_order, char uplo, lapack_int m, + lapack_int n, const float* a, lapack_int lda, + lapack_complex_float* b, lapack_int ldb ) +{ + lapack_int info = 0; + if( matrix_order == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_clacp2( &uplo, &m, &n, a, &lda, b, &ldb ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_order == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,m); + lapack_int ldb_t = MAX(1,m); + float* a_t = NULL; + lapack_complex_float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_clacp2_work", info ); + return info; + } + if( ldb < n ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_clacp2_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * ldb_t * MAX(1,n) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_sge_trans( matrix_order, m, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_clacp2( &uplo, &m, &n, a_t, &lda_t, b_t, &ldb_t ); + info = 0; /* LAPACK call is ok! */ + /* Transpose output matrices */ + LAPACKE_cge_trans( LAPACK_COL_MAJOR, m, n, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_clacp2_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_clacp2_work", info ); + } + return info; +} diff --git a/lapack-netlib/lapacke/src/lapacke_cstegr_work.c b/lapack-netlib/lapacke/src/lapacke_cstegr_work.c index afd889662..a7ede3a49 100644 --- a/lapack-netlib/lapacke/src/lapacke_cstegr_work.c +++ b/lapack-netlib/lapacke/src/lapacke_cstegr_work.c @@ -55,7 +55,7 @@ lapack_int LAPACKE_cstegr_work( int matrix_order, char jobz, char range, lapack_int ldz_t = MAX(1,n); lapack_complex_float* z_t = NULL; /* Check leading dimension(s) */ - if( ldz < *m ) { + if( ( LAPACKE_lsame( jobz, 'v' ) && ( ldz < ldz_t ) ) || ( ldz < 1 ) ) { info = -15; LAPACKE_xerbla( "LAPACKE_cstegr_work", info ); return info; diff --git a/lapack-netlib/lapacke/src/lapacke_csysv_rook.c b/lapack-netlib/lapacke/src/lapacke_csysv_rook.c new file mode 100644 index 000000000..e67768ca8 --- /dev/null +++ b/lapack-netlib/lapacke/src/lapacke_csysv_rook.c @@ -0,0 +1,82 @@ +/***************************************************************************** + Copyright (c) 2010, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native high-level C interface to LAPACK function csysv_rook +* Author: Intel Corporation +* Generated January, 2012 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_csysv_rook( int matrix_order, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_float* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_order != LAPACK_COL_MAJOR && matrix_order != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_csysv_rook", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_csy_nancheck( matrix_order, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_cge_nancheck( matrix_order, n, nrhs, b, ldb ) ) { + return -8; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_csysv_rook_work( matrix_order, uplo, n, nrhs, a, lda, ipiv, + b, ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_csysv_rook_work( matrix_order, uplo, n, nrhs, a, lda, ipiv, + b, ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_csysv_rook", info ); + } + return info; +} diff --git a/lapack-netlib/lapacke/src/lapacke_csysv_rook_work.c b/lapack-netlib/lapacke/src/lapacke_csysv_rook_work.c new file mode 100644 index 000000000..5c173187e --- /dev/null +++ b/lapack-netlib/lapacke/src/lapacke_csysv_rook_work.c @@ -0,0 +1,112 @@ +/***************************************************************************** + Copyright (c) 2010, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native middle-level C interface to LAPACK function csysv_rook +* Author: Intel Corporation +* Generated January, 2012 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_csysv_rook_work( int matrix_order, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_float* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* work, + lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_order == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_csysv_rook( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_order == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + lapack_complex_float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_csysv_rook_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_csysv_rook_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_csysv_rook( &uplo, &n, &nrhs, a, &lda_t, ipiv, b, &ldb_t, + work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * + ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_csy_trans( matrix_order, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_cge_trans( matrix_order, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_csysv_rook( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t, + work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_csy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_csysv_rook_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_csysv_rook_work", info ); + } + return info; +} diff --git a/lapack-netlib/lapacke/src/lapacke_dlacn2.c b/lapack-netlib/lapacke/src/lapacke_dlacn2.c new file mode 100644 index 000000000..1ccf0a9da --- /dev/null +++ b/lapack-netlib/lapacke/src/lapacke_dlacn2.c @@ -0,0 +1,49 @@ +/***************************************************************************** + Copyright (c) 2010, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native high-level C interface to LAPACK function dlacn2 +* Author: Intel Corporation +* Generated October, 2012 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dlacn2( lapack_int n, double* v, double* x, lapack_int* isgn, + double* est, lapack_int* kase, lapack_int* isave ) +{ +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_d_nancheck( 1, est, 1 ) ) { + return -5; + } + if( LAPACKE_d_nancheck( n, x, 1 ) ) { + return -3; + } +#endif + return LAPACKE_dlacn2_work( n, v, x, isgn, est, kase, isave ); +} diff --git a/lapack-netlib/lapacke/src/lapacke_dlacn2_work.c b/lapack-netlib/lapacke/src/lapacke_dlacn2_work.c new file mode 100644 index 000000000..3b015d4e1 --- /dev/null +++ b/lapack-netlib/lapacke/src/lapacke_dlacn2_work.c @@ -0,0 +1,44 @@ +/***************************************************************************** + Copyright (c) 2010, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dlacn2 +* Author: Intel Corporation +* Generated October, 2012 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dlacn2_work( lapack_int n, double* v, double* x, + lapack_int* isgn, double* est, lapack_int* kase, + lapack_int* isave ) +{ + lapack_int info = 0; + /* Call LAPACK function and adjust info */ + LAPACK_dlacn2( &n, v, x, isgn, est, kase, isave ); + return info; +} diff --git a/lapack-netlib/lapacke/src/lapacke_dstegr_work.c b/lapack-netlib/lapacke/src/lapacke_dstegr_work.c index 0bec6530d..26ab31e54 100644 --- a/lapack-netlib/lapacke/src/lapacke_dstegr_work.c +++ b/lapack-netlib/lapacke/src/lapacke_dstegr_work.c @@ -54,7 +54,7 @@ lapack_int LAPACKE_dstegr_work( int matrix_order, char jobz, char range, lapack_int ldz_t = MAX(1,n); double* z_t = NULL; /* Check leading dimension(s) */ - if( ldz < *m ) { + if( ( LAPACKE_lsame( jobz, 'v' ) && ( ldz < ldz_t ) ) || ( ldz < 1 ) ) { info = -15; LAPACKE_xerbla( "LAPACKE_dstegr_work", info ); return info; diff --git a/lapack-netlib/lapacke/src/lapacke_dsysv_rook.c b/lapack-netlib/lapacke/src/lapacke_dsysv_rook.c new file mode 100644 index 000000000..d6af2e4b1 --- /dev/null +++ b/lapack-netlib/lapacke/src/lapacke_dsysv_rook.c @@ -0,0 +1,80 @@ +/***************************************************************************** + Copyright (c) 2010, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native high-level C interface to LAPACK function dsysv_rook +* Author: Intel Corporation +* Generated January, 2012 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsysv_rook( int matrix_order, char uplo, lapack_int n, + lapack_int nrhs, double* a, lapack_int lda, + lapack_int* ipiv, double* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* work = NULL; + double work_query; + if( matrix_order != LAPACK_COL_MAJOR && matrix_order != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dsysv_rook", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dsy_nancheck( matrix_order, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_dge_nancheck( matrix_order, n, nrhs, b, ldb ) ) { + return -8; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_dsysv_rook_work( matrix_order, uplo, n, nrhs, a, lda, ipiv, + b, ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_dsysv_rook_work( matrix_order, uplo, n, nrhs, a, lda, ipiv, + b, ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsysv_rook", info ); + } + return info; +} diff --git a/lapack-netlib/lapacke/src/lapacke_dsysv_rook_work.c b/lapack-netlib/lapacke/src/lapacke_dsysv_rook_work.c new file mode 100644 index 000000000..1932ec1da --- /dev/null +++ b/lapack-netlib/lapacke/src/lapacke_dsysv_rook_work.c @@ -0,0 +1,107 @@ +/***************************************************************************** + Copyright (c) 2010, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dsysv_rook +* Author: Intel Corporation +* Generated January, 2012 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dsysv_rook_work( int matrix_order, char uplo, lapack_int n, + lapack_int nrhs, double* a, lapack_int lda, + lapack_int* ipiv, double* b, lapack_int ldb, + double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_order == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dsysv_rook( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_order == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + double* a_t = NULL; + double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_dsysv_rook_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_dsysv_rook_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_dsysv_rook( &uplo, &n, &nrhs, a, &lda_t, ipiv, b, &ldb_t, + work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (double*)LAPACKE_malloc( sizeof(double) * ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_dsy_trans( matrix_order, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_dge_trans( matrix_order, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dsysv_rook( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t, + work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dsy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dsysv_rook_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dsysv_rook_work", info ); + } + return info; +} diff --git a/lapack-netlib/lapacke/src/lapacke_slacn2.c b/lapack-netlib/lapacke/src/lapacke_slacn2.c new file mode 100644 index 000000000..15d06d551 --- /dev/null +++ b/lapack-netlib/lapacke/src/lapacke_slacn2.c @@ -0,0 +1,49 @@ +/***************************************************************************** + Copyright (c) 2010, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native high-level C interface to LAPACK function slacn2 +* Author: Intel Corporation +* Generated October, 2012 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_slacn2( lapack_int n, float* v, float* x, lapack_int* isgn, + float* est, lapack_int* kase, lapack_int* isave ) +{ +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_s_nancheck( 1, est, 1 ) ) { + return -5; + } + if( LAPACKE_s_nancheck( n, x, 1 ) ) { + return -3; + } +#endif + return LAPACKE_slacn2_work( n, v, x, isgn, est, kase, isave ); +} diff --git a/lapack-netlib/lapacke/src/lapacke_slacn2_work.c b/lapack-netlib/lapacke/src/lapacke_slacn2_work.c new file mode 100644 index 000000000..7908d41c6 --- /dev/null +++ b/lapack-netlib/lapacke/src/lapacke_slacn2_work.c @@ -0,0 +1,44 @@ +/***************************************************************************** + Copyright (c) 2010, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native middle-level C interface to LAPACK function slacn2 +* Author: Intel Corporation +* Generated October, 2012 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_slacn2_work( lapack_int n, float* v, float* x, + lapack_int* isgn, float* est, lapack_int* kase, + lapack_int* isave ) +{ + lapack_int info = 0; + /* Call LAPACK function and adjust info */ + LAPACK_slacn2( &n, v, x, isgn, est, kase, isave ); + return info; +} diff --git a/lapack-netlib/lapacke/src/lapacke_sstegr_work.c b/lapack-netlib/lapacke/src/lapacke_sstegr_work.c index 90188d26e..54bc3d21f 100644 --- a/lapack-netlib/lapacke/src/lapacke_sstegr_work.c +++ b/lapack-netlib/lapacke/src/lapacke_sstegr_work.c @@ -54,7 +54,7 @@ lapack_int LAPACKE_sstegr_work( int matrix_order, char jobz, char range, lapack_int ldz_t = MAX(1,n); float* z_t = NULL; /* Check leading dimension(s) */ - if( ldz < *m ) { + if( ( LAPACKE_lsame( jobz, 'v' ) && ( ldz < ldz_t ) ) || ( ldz < 1 ) ) { info = -15; LAPACKE_xerbla( "LAPACKE_sstegr_work", info ); return info; diff --git a/lapack-netlib/lapacke/src/lapacke_ssysv_rook.c b/lapack-netlib/lapacke/src/lapacke_ssysv_rook.c new file mode 100644 index 000000000..dfa5a7815 --- /dev/null +++ b/lapack-netlib/lapacke/src/lapacke_ssysv_rook.c @@ -0,0 +1,80 @@ +/***************************************************************************** + Copyright (c) 2010, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native high-level C interface to LAPACK function ssysv_rook +* Author: Intel Corporation +* Generated January, 2012 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssysv_rook( int matrix_order, char uplo, lapack_int n, + lapack_int nrhs, float* a, lapack_int lda, + lapack_int* ipiv, float* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* work = NULL; + float work_query; + if( matrix_order != LAPACK_COL_MAJOR && matrix_order != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_ssysv_rook", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_ssy_nancheck( matrix_order, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_sge_nancheck( matrix_order, n, nrhs, b, ldb ) ) { + return -8; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_ssysv_rook_work( matrix_order, uplo, n, nrhs, a, lda, ipiv, + b, ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_ssysv_rook_work( matrix_order, uplo, n, nrhs, a, lda, ipiv, + b, ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssysv_rook", info ); + } + return info; +} diff --git a/lapack-netlib/lapacke/src/lapacke_ssysv_rook_work.c b/lapack-netlib/lapacke/src/lapacke_ssysv_rook_work.c new file mode 100644 index 000000000..c6449fe11 --- /dev/null +++ b/lapack-netlib/lapacke/src/lapacke_ssysv_rook_work.c @@ -0,0 +1,107 @@ +/***************************************************************************** + Copyright (c) 2010, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native middle-level C interface to LAPACK function ssysv_rook +* Author: Intel Corporation +* Generated January, 2012 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_ssysv_rook_work( int matrix_order, char uplo, lapack_int n, + lapack_int nrhs, float* a, lapack_int lda, + lapack_int* ipiv, float* b, lapack_int ldb, + float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_order == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_ssysv_rook( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_order == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + float* a_t = NULL; + float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_ssysv_rook_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_ssysv_rook_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_ssysv_rook( &uplo, &n, &nrhs, a, &lda_t, ipiv, b, &ldb_t, + work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (float*)LAPACKE_malloc( sizeof(float) * ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_ssy_trans( matrix_order, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_sge_trans( matrix_order, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_ssysv_rook( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t, + work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_ssy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_ssysv_rook_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_ssysv_rook_work", info ); + } + return info; +} diff --git a/lapack-netlib/lapacke/src/lapacke_zlacn2.c b/lapack-netlib/lapacke/src/lapacke_zlacn2.c new file mode 100644 index 000000000..e64c0716a --- /dev/null +++ b/lapack-netlib/lapacke/src/lapacke_zlacn2.c @@ -0,0 +1,50 @@ +/***************************************************************************** + Copyright (c) 2010, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native high-level C interface to LAPACK function zlacn2 +* Author: Intel Corporation +* Generated October, 2012 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zlacn2( lapack_int n, lapack_complex_double* v, + lapack_complex_double* x, + double* est, lapack_int* kase, lapack_int* isave ) +{ +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_d_nancheck( 1, est, 1 ) ) { + return -5; + } + if( LAPACKE_z_nancheck( n, x, 1 ) ) { + return -3; + } +#endif + return LAPACKE_zlacn2_work( n, v, x, est, kase, isave ); +} diff --git a/lapack-netlib/lapacke/src/lapacke_zlacn2_work.c b/lapack-netlib/lapacke/src/lapacke_zlacn2_work.c new file mode 100644 index 000000000..6babae5a2 --- /dev/null +++ b/lapack-netlib/lapacke/src/lapacke_zlacn2_work.c @@ -0,0 +1,45 @@ +/***************************************************************************** + Copyright (c) 2010, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zlacn2 +* Author: Intel Corporation +* Generated October, 2012 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zlacn2_work( lapack_int n, lapack_complex_double* v, + lapack_complex_double* x, + double* est, lapack_int* kase, + lapack_int* isave ) +{ + lapack_int info = 0; + /* Call LAPACK function and adjust info */ + LAPACK_zlacn2( &n, v, x, est, kase, isave ); + return info; +} diff --git a/lapack-netlib/lapacke/src/lapacke_zlacp2.c b/lapack-netlib/lapacke/src/lapacke_zlacp2.c new file mode 100644 index 000000000..ffcaac91a --- /dev/null +++ b/lapack-netlib/lapacke/src/lapacke_zlacp2.c @@ -0,0 +1,51 @@ +/***************************************************************************** + Copyright (c) 2011, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native high-level C interface to LAPACK function zlacp2 +* Author: Intel Corporation +* Generated January, 2013 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zlacp2( int matrix_order, char uplo, lapack_int m, + lapack_int n, const double* a, lapack_int lda, + lapack_complex_double* b, lapack_int ldb ) +{ + if( matrix_order != LAPACK_COL_MAJOR && matrix_order != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zlacp2", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dge_nancheck( matrix_order, m, n, a, lda ) ) { + return -5; + } +#endif + return LAPACKE_zlacp2_work( matrix_order, uplo, m, n, a, lda, b, ldb ); +} diff --git a/lapack-netlib/lapacke/src/lapacke_zlacp2_work.c b/lapack-netlib/lapacke/src/lapacke_zlacp2_work.c new file mode 100644 index 000000000..8ece4914c --- /dev/null +++ b/lapack-netlib/lapacke/src/lapacke_zlacp2_work.c @@ -0,0 +1,96 @@ +/***************************************************************************** + Copyright (c) 2010, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zlacp2 +* Author: Intel Corporation +* Generated January, 2013 +*****************************************************************************/ + +#include "lapacke.h" +#include "lapacke_utils.h" + +lapack_int LAPACKE_zlacp2_work( int matrix_order, char uplo, lapack_int m, + lapack_int n, const double* a, lapack_int lda, + lapack_complex_double* b, lapack_int ldb ) +{ + lapack_int info = 0; + if( matrix_order == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zlacp2( &uplo, &m, &n, a, &lda, b, &ldb ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_order == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,m); + lapack_int ldb_t = MAX(1,m); + double* a_t = NULL; + lapack_complex_double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_zlacp2_work", info ); + return info; + } + if( ldb < n ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_zlacp2_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * ldb_t * MAX(1,n) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_dge_trans( matrix_order, m, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zlacp2( &uplo, &m, &n, a_t, &lda_t, b_t, &ldb_t ); + info = 0; /* LAPACK call is ok! */ + /* Transpose output matrices */ + LAPACKE_zge_trans( LAPACK_COL_MAJOR, m, n, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zlacp2_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zlacp2_work", info ); + } + return info; +} diff --git a/lapack-netlib/lapacke/src/lapacke_zstegr_work.c b/lapack-netlib/lapacke/src/lapacke_zstegr_work.c index ad56b96c6..3ed189498 100644 --- a/lapack-netlib/lapacke/src/lapacke_zstegr_work.c +++ b/lapack-netlib/lapacke/src/lapacke_zstegr_work.c @@ -55,7 +55,7 @@ lapack_int LAPACKE_zstegr_work( int matrix_order, char jobz, char range, lapack_int ldz_t = MAX(1,n); lapack_complex_double* z_t = NULL; /* Check leading dimension(s) */ - if( ldz < *m ) { + if( ( LAPACKE_lsame( jobz, 'v' ) && ( ldz < ldz_t ) ) || ( ldz < 1 ) ) { info = -15; LAPACKE_xerbla( "LAPACKE_zstegr_work", info ); return info; diff --git a/lapack-netlib/lapacke/src/lapacke_zsysv_rook.c b/lapack-netlib/lapacke/src/lapacke_zsysv_rook.c new file mode 100644 index 000000000..7db4d6476 --- /dev/null +++ b/lapack-netlib/lapacke/src/lapacke_zsysv_rook.c @@ -0,0 +1,82 @@ +/***************************************************************************** + Copyright (c) 2010, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native high-level C interface to LAPACK function zsysv_rook +* Author: Intel Corporation +* Generated January, 2012 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zsysv_rook( int matrix_order, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_double* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_order != LAPACK_COL_MAJOR && matrix_order != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zsysv_rook", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zsy_nancheck( matrix_order, uplo, n, a, lda ) ) { + return -5; + } + if( LAPACKE_zge_nancheck( matrix_order, n, nrhs, b, ldb ) ) { + return -8; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zsysv_rook_work( matrix_order, uplo, n, nrhs, a, lda, ipiv, + b, ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = LAPACKE_zsysv_rook_work( matrix_order, uplo, n, nrhs, a, lda, ipiv, + b, ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zsysv_rook", info ); + } + return info; +} diff --git a/lapack-netlib/lapacke/src/lapacke_zsysv_rook_work.c b/lapack-netlib/lapacke/src/lapacke_zsysv_rook_work.c new file mode 100644 index 000000000..249d924f0 --- /dev/null +++ b/lapack-netlib/lapacke/src/lapacke_zsysv_rook_work.c @@ -0,0 +1,112 @@ +/***************************************************************************** + Copyright (c) 2010, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zsysv_rook +* Author: Intel Corporation +* Generated January, 2012 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zsysv_rook_work( int matrix_order, char uplo, lapack_int n, + lapack_int nrhs, lapack_complex_double* a, + lapack_int lda, lapack_int* ipiv, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* work, + lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_order == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zsysv_rook( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_order == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + lapack_complex_double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_zsysv_rook_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + LAPACKE_xerbla( "LAPACKE_zsysv_rook_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_zsysv_rook( &uplo, &n, &nrhs, a, &lda_t, ipiv, b, &ldb_t, + work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * + ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + LAPACKE_zsy_trans( matrix_order, uplo, n, a, lda, a_t, lda_t ); + LAPACKE_zge_trans( matrix_order, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zsysv_rook( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t, + work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zsy_trans( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zsysv_rook_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zsysv_rook_work", info ); + } + return info; +} diff --git a/lapack-netlib/make.inc.example b/lapack-netlib/make.inc.example index 940e4c7ea..0f28d6bf6 100644 --- a/lapack-netlib/make.inc.example +++ b/lapack-netlib/make.inc.example @@ -1,7 +1,7 @@ #################################################################### # LAPACK make include file. # -# LAPACK, Version 3.4.0 # -# April 2012 # +# LAPACK, Version 3.5.0 # +# November 2013 # #################################################################### # SHELL = /bin/sh @@ -13,9 +13,9 @@ SHELL = /bin/sh # desired load options for your machine. # FORTRAN = gfortran -OPTS = -O2 +OPTS = -O2 -frecursive DRVOPTS = $(OPTS) -NOOPT = -O0 +NOOPT = -O0 -frecursive LOADER = gfortran LOADOPTS = #