From 6273f536d15680513e8cddfc4d8baa88ad2c64df Mon Sep 17 00:00:00 2001 From: "philippe.theveny" Date: Tue, 24 Feb 2015 23:50:54 +0000 Subject: [PATCH] Add xGGHD3: blocked Hessenberg reduction, code from Daniel Kressner. Add xGGES3 and xGGEV3: computation of the Schur form, the Schur vectors, and the generalized eigenvalues using the blocked Hessenberg reduction. --- LAPACKE/include/lapacke.h | 300 +++++++++++- LAPACKE/src/CMakeLists.txt | 24 + LAPACKE/src/Makefile | 24 + LAPACKE/src/lapacke_cgges3.c | 110 +++++ LAPACKE/src/lapacke_cgges3_work.c | 166 +++++++ LAPACKE/src/lapacke_cggev3.c | 97 ++++ LAPACKE/src/lapacke_cggev3_work.c | 169 +++++++ LAPACKE/src/lapacke_cgghd3.c | 97 ++++ LAPACKE/src/lapacke_cgghd3_work.c | 158 ++++++ LAPACKE/src/lapacke_dgges3.c | 100 ++++ LAPACKE/src/lapacke_dgges3_work.c | 161 ++++++ LAPACKE/src/lapacke_dggev3.c | 86 ++++ LAPACKE/src/lapacke_dggev3_work.c | 161 ++++++ LAPACKE/src/lapacke_dgghd3.c | 94 ++++ LAPACKE/src/lapacke_dgghd3_work.c | 157 ++++++ LAPACKE/src/lapacke_sgges3.c | 99 ++++ LAPACKE/src/lapacke_sgges3_work.c | 161 ++++++ LAPACKE/src/lapacke_sggev3.c | 84 ++++ LAPACKE/src/lapacke_sggev3_work.c | 163 +++++++ LAPACKE/src/lapacke_sgghd3.c | 92 ++++ LAPACKE/src/lapacke_sgghd3_work.c | 157 ++++++ LAPACKE/src/lapacke_zgges3.c | 110 +++++ LAPACKE/src/lapacke_zgges3_work.c | 167 +++++++ LAPACKE/src/lapacke_zggev3.c | 97 ++++ LAPACKE/src/lapacke_zggev3_work.c | 169 +++++++ LAPACKE/src/lapacke_zgghd3.c | 97 ++++ LAPACKE/src/lapacke_zgghd3_work.c | 159 ++++++ SRC/CMakeLists.txt | 28 +- SRC/Makefile | 28 +- SRC/cgges3.f | 597 +++++++++++++++++++++++ SRC/cggev3.f | 560 +++++++++++++++++++++ SRC/cgghd3.f | 901 ++++++++++++++++++++++++++++++++++ SRC/cunm22.f | 440 +++++++++++++++++ SRC/dgges3.f | 674 ++++++++++++++++++++++++++ SRC/dggev3.f | 594 +++++++++++++++++++++++ SRC/dgghd3.f | 898 ++++++++++++++++++++++++++++++++++ SRC/dorm22.f | 441 +++++++++++++++++ SRC/ilaenv.f | 23 +- SRC/iparmq.f | 109 ++++- SRC/sgges3.f | 671 +++++++++++++++++++++++++ SRC/sggev3.f | 589 ++++++++++++++++++++++ SRC/sgghd3.f | 898 ++++++++++++++++++++++++++++++++++ SRC/sorm22.f | 441 +++++++++++++++++ SRC/zgges3.f | 595 +++++++++++++++++++++++ SRC/zggev3.f | 559 +++++++++++++++++++++ SRC/zgghd3.f | 896 ++++++++++++++++++++++++++++++++++ SRC/zunm22.f | 440 +++++++++++++++++ TESTING/EIG/CMakeLists.txt | 80 +-- TESTING/EIG/Makefile | 8 +- TESTING/EIG/cchkee.f | 57 ++- TESTING/EIG/cdrges3.f | 940 +++++++++++++++++++++++++++++++++++ TESTING/EIG/cdrgev3.f | 943 +++++++++++++++++++++++++++++++++++ TESTING/EIG/cerrgg.f | 174 ++++++- TESTING/EIG/dchkee.f | 74 ++- TESTING/EIG/ddrges3.f | 997 ++++++++++++++++++++++++++++++++++++++ TESTING/EIG/ddrgev3.f | 940 +++++++++++++++++++++++++++++++++++ TESTING/EIG/derrgg.f | 142 +++++- TESTING/EIG/schkee.f | 56 ++- TESTING/EIG/sdrges3.f | 997 ++++++++++++++++++++++++++++++++++++++ TESTING/EIG/sdrgev3.f | 941 +++++++++++++++++++++++++++++++++++ TESTING/EIG/serrgg.f | 174 ++++++- TESTING/EIG/zchkee.f | 58 ++- TESTING/EIG/zdrges3.f | 940 +++++++++++++++++++++++++++++++++++ TESTING/EIG/zdrgev3.f | 939 +++++++++++++++++++++++++++++++++++ TESTING/EIG/zerrgg.f | 176 ++++++- TESTING/cgg.in | 15 +- TESTING/dgg.in | 1 + TESTING/sgg.in | 1 + TESTING/zgg.in | 1 + 69 files changed, 22266 insertions(+), 229 deletions(-) create mode 100644 LAPACKE/src/lapacke_cgges3.c create mode 100644 LAPACKE/src/lapacke_cgges3_work.c create mode 100644 LAPACKE/src/lapacke_cggev3.c create mode 100644 LAPACKE/src/lapacke_cggev3_work.c create mode 100644 LAPACKE/src/lapacke_cgghd3.c create mode 100644 LAPACKE/src/lapacke_cgghd3_work.c create mode 100644 LAPACKE/src/lapacke_dgges3.c create mode 100644 LAPACKE/src/lapacke_dgges3_work.c create mode 100644 LAPACKE/src/lapacke_dggev3.c create mode 100644 LAPACKE/src/lapacke_dggev3_work.c create mode 100644 LAPACKE/src/lapacke_dgghd3.c create mode 100644 LAPACKE/src/lapacke_dgghd3_work.c create mode 100644 LAPACKE/src/lapacke_sgges3.c create mode 100644 LAPACKE/src/lapacke_sgges3_work.c create mode 100644 LAPACKE/src/lapacke_sggev3.c create mode 100644 LAPACKE/src/lapacke_sggev3_work.c create mode 100644 LAPACKE/src/lapacke_sgghd3.c create mode 100644 LAPACKE/src/lapacke_sgghd3_work.c create mode 100644 LAPACKE/src/lapacke_zgges3.c create mode 100644 LAPACKE/src/lapacke_zgges3_work.c create mode 100644 LAPACKE/src/lapacke_zggev3.c create mode 100644 LAPACKE/src/lapacke_zggev3_work.c create mode 100644 LAPACKE/src/lapacke_zgghd3.c create mode 100644 LAPACKE/src/lapacke_zgghd3_work.c create mode 100644 SRC/cgges3.f create mode 100644 SRC/cggev3.f create mode 100644 SRC/cgghd3.f create mode 100644 SRC/cunm22.f create mode 100644 SRC/dgges3.f create mode 100644 SRC/dggev3.f create mode 100644 SRC/dgghd3.f create mode 100644 SRC/dorm22.f create mode 100644 SRC/sgges3.f create mode 100644 SRC/sggev3.f create mode 100644 SRC/sgghd3.f create mode 100644 SRC/sorm22.f create mode 100644 SRC/zgges3.f create mode 100644 SRC/zggev3.f create mode 100644 SRC/zgghd3.f create mode 100644 SRC/zunm22.f create mode 100644 TESTING/EIG/cdrges3.f create mode 100644 TESTING/EIG/cdrgev3.f create mode 100644 TESTING/EIG/ddrges3.f create mode 100644 TESTING/EIG/ddrgev3.f create mode 100644 TESTING/EIG/sdrges3.f create mode 100644 TESTING/EIG/sdrgev3.f create mode 100644 TESTING/EIG/zdrges3.f create mode 100644 TESTING/EIG/zdrgev3.f diff --git a/LAPACKE/include/lapacke.h b/LAPACKE/include/lapacke.h index 2551c02..c68fc4c 100644 --- a/LAPACKE/include/lapacke.h +++ b/LAPACKE/include/lapacke.h @@ -1172,6 +1172,35 @@ lapack_int LAPACKE_zgges( int matrix_layout, char jobvsl, char jobvsr, char sort lapack_complex_double* vsl, lapack_int ldvsl, lapack_complex_double* vsr, lapack_int ldvsr ); +lapack_int LAPACKE_sgges3( int matrix_layout, char jobvsl, char jobvsr, + char sort, LAPACK_S_SELECT3 selctg, lapack_int n, + float* a, lapack_int lda, float* b, lapack_int ldb, + lapack_int* sdim, float* alphar, float* alphai, + float* beta, float* vsl, lapack_int ldvsl, + float* vsr, lapack_int ldvsr ); +lapack_int LAPACKE_dgges3( int matrix_layout, char jobvsl, char jobvsr, + char sort, LAPACK_D_SELECT3 selctg, lapack_int n, + double* a, lapack_int lda, double* b, lapack_int ldb, + lapack_int* sdim, double* alphar, double* alphai, + double* beta, double* vsl, lapack_int ldvsl, + double* vsr, lapack_int ldvsr ); +lapack_int LAPACKE_cgges3( int matrix_layout, char jobvsl, char jobvsr, + char sort, LAPACK_C_SELECT2 selctg, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* b, lapack_int ldb, + lapack_int* sdim, lapack_complex_float* alpha, + lapack_complex_float* beta, + lapack_complex_float* vsl, lapack_int ldvsl, + lapack_complex_float* vsr, lapack_int ldvsr ); +lapack_int LAPACKE_zgges3( int matrix_layout, char jobvsl, char jobvsr, + char sort, LAPACK_Z_SELECT2 selctg, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* b, lapack_int ldb, + lapack_int* sdim, lapack_complex_double* alpha, + lapack_complex_double* beta, + lapack_complex_double* vsl, lapack_int ldvsl, + lapack_complex_double* vsr, lapack_int ldvsr ); + lapack_int LAPACKE_sggesx( int matrix_layout, char jobvsl, char jobvsr, char sort, LAPACK_S_SELECT3 selctg, char sense, lapack_int n, float* a, lapack_int lda, float* b, @@ -1232,6 +1261,35 @@ lapack_int LAPACKE_zggev( int matrix_layout, char jobvl, char jobvr, lapack_complex_double* vl, lapack_int ldvl, lapack_complex_double* vr, lapack_int ldvr ); +lapack_int LAPACKE_sggev3( int matrix_layout, char jobvl, char jobvr, + lapack_int n, float* a, lapack_int lda, + float* b, lapack_int ldb, + float* alphar, float* alphai, float* beta, + float* vl, lapack_int ldvl, + float* vr, lapack_int ldvr ); +lapack_int LAPACKE_dggev3( int matrix_layout, char jobvl, char jobvr, + lapack_int n, double* a, lapack_int lda, + double* b, lapack_int ldb, + double* alphar, double* alphai, double* beta, + double* vl, lapack_int ldvl, + double* vr, lapack_int ldvr ); +lapack_int LAPACKE_cggev3( int matrix_layout, char jobvl, char jobvr, + lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* alpha, + lapack_complex_float* beta, + lapack_complex_float* vl, lapack_int ldvl, + lapack_complex_float* vr, lapack_int ldvr ); +lapack_int LAPACKE_zggev3( int matrix_layout, char jobvl, char jobvr, + lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* alpha, + lapack_complex_double* beta, + lapack_complex_double* vl, lapack_int ldvl, + lapack_complex_double* vr, lapack_int ldvr ); + lapack_int LAPACKE_sggevx( int matrix_layout, char balanc, char jobvl, char jobvr, char sense, lapack_int n, float* a, lapack_int lda, float* b, lapack_int ldb, @@ -1309,6 +1367,28 @@ lapack_int LAPACKE_zgghrd( int matrix_layout, char compq, char compz, lapack_complex_double* q, lapack_int ldq, lapack_complex_double* z, lapack_int ldz ); +lapack_int LAPACKE_sgghd3( int matrix_layout, char compq, char compz, + lapack_int n, lapack_int ilo, lapack_int ihi, + float* a, lapack_int lda, float* b, lapack_int ldb, + float* q, lapack_int ldq, float* z, lapack_int ldz ); +lapack_int LAPACKE_dgghd3( int matrix_layout, char compq, char compz, + lapack_int n, lapack_int ilo, lapack_int ihi, + double* a, lapack_int lda, double* b, lapack_int ldb, + double* q, lapack_int ldq, double* z, + lapack_int ldz ); +lapack_int LAPACKE_cgghd3( int matrix_layout, char compq, char compz, + lapack_int n, lapack_int ilo, lapack_int ihi, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* q, lapack_int ldq, + lapack_complex_float* z, lapack_int ldz ); +lapack_int LAPACKE_zgghd3( int matrix_layout, char compq, char compz, + lapack_int n, lapack_int ilo, lapack_int ihi, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* q, lapack_int ldq, + lapack_complex_double* z, lapack_int ldz ); + lapack_int LAPACKE_sgglse( int matrix_layout, lapack_int m, lapack_int n, lapack_int p, float* a, lapack_int lda, float* b, lapack_int ldb, float* c, float* d, float* x ); @@ -5713,6 +5793,49 @@ lapack_int LAPACKE_zgges_work( int matrix_layout, char jobvsl, char jobvsr, lapack_complex_double* work, lapack_int lwork, double* rwork, lapack_logical* bwork ); +lapack_int LAPACKE_sgges3_work( int matrix_layout, char jobvsl, char jobvsr, + char sort, LAPACK_S_SELECT3 selctg, + lapack_int n, + float* a, lapack_int lda, + float* b, lapack_int ldb, lapack_int* sdim, + float* alphar, float* alphai, float* beta, + float* vsl, lapack_int ldvsl, + float* vsr, lapack_int ldvsr, + float* work, lapack_int lwork, + lapack_logical* bwork ); +lapack_int LAPACKE_dgges3_work( int matrix_layout, char jobvsl, char jobvsr, + char sort, LAPACK_D_SELECT3 selctg, + lapack_int n, + double* a, lapack_int lda, + double* b, lapack_int ldb, lapack_int* sdim, + double* alphar, double* alphai, double* beta, + double* vsl, lapack_int ldvsl, + double* vsr, lapack_int ldvsr, + double* work, lapack_int lwork, + lapack_logical* bwork ); +lapack_int LAPACKE_cgges3_work( int matrix_layout, char jobvsl, char jobvsr, + char sort, LAPACK_C_SELECT2 selctg, + lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* b, lapack_int ldb, + lapack_int* sdim, lapack_complex_float* alpha, + lapack_complex_float* beta, + lapack_complex_float* vsl, lapack_int ldvsl, + lapack_complex_float* vsr, lapack_int ldvsr, + lapack_complex_float* work, lapack_int lwork, + float* rwork, lapack_logical* bwork ); +lapack_int LAPACKE_zgges3_work( int matrix_layout, char jobvsl, char jobvsr, + char sort, LAPACK_Z_SELECT2 selctg, + lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* b, lapack_int ldb, + lapack_int* sdim, lapack_complex_double* alpha, + lapack_complex_double* beta, + lapack_complex_double* vsl, lapack_int ldvsl, + lapack_complex_double* vsr, lapack_int ldvsr, + lapack_complex_double* work, lapack_int lwork, + double* rwork, lapack_logical* bwork ); + lapack_int LAPACKE_sggesx_work( int matrix_layout, char jobvsl, char jobvsr, char sort, LAPACK_S_SELECT3 selctg, char sense, lapack_int n, float* a, lapack_int lda, @@ -5791,6 +5914,43 @@ lapack_int LAPACKE_zggev_work( int matrix_layout, char jobvl, char jobvr, lapack_complex_double* work, lapack_int lwork, double* rwork ); +lapack_int LAPACKE_sggev3_work( int matrix_layout, char jobvl, char jobvr, + lapack_int n, + float* a, lapack_int lda, + float* b, lapack_int ldb, + float* alphar, float* alphai, float* beta, + float* vl, lapack_int ldvl, + float* vr, lapack_int ldvr, + float* work, lapack_int lwork ); +lapack_int LAPACKE_dggev3_work( int matrix_layout, char jobvl, char jobvr, + lapack_int n, + double* a, lapack_int lda, + double* b, lapack_int ldb, + double* alphar, double* alphai, double* beta, + double* vl, lapack_int ldvl, + double* vr, lapack_int ldvr, + double* work, lapack_int lwork ); +lapack_int LAPACKE_cggev3_work( int matrix_layout, char jobvl, char jobvr, + lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* alpha, + lapack_complex_float* beta, + lapack_complex_float* vl, lapack_int ldvl, + lapack_complex_float* vr, lapack_int ldvr, + lapack_complex_float* work, lapack_int lwork, + float* rwork ); +lapack_int LAPACKE_zggev3_work( int matrix_layout, char jobvl, char jobvr, + lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* alpha, + lapack_complex_double* beta, + lapack_complex_double* vl, lapack_int ldvl, + lapack_complex_double* vr, lapack_int ldvr, + lapack_complex_double* work, lapack_int lwork, + double* rwork ); + lapack_int LAPACKE_sggevx_work( int matrix_layout, char balanc, char jobvl, char jobvr, char sense, lapack_int n, float* a, lapack_int lda, float* b, lapack_int ldb, @@ -5886,6 +6046,36 @@ lapack_int LAPACKE_zgghrd_work( int matrix_layout, char compq, char compz, lapack_complex_double* q, lapack_int ldq, lapack_complex_double* z, lapack_int ldz ); +lapack_int LAPACKE_sgghd3_work( int matrix_layout, char compq, char compz, + lapack_int n, lapack_int ilo, lapack_int ihi, + float* a, lapack_int lda, + float* b, lapack_int ldb, + float* q, lapack_int ldq, + float* z, lapack_int ldz, + float* work, lapack_int lwork ); +lapack_int LAPACKE_dgghd3_work( int matrix_layout, char compq, char compz, + lapack_int n, lapack_int ilo, lapack_int ihi, + double* a, lapack_int lda, + double* b, lapack_int ldb, + double* q, lapack_int ldq, + double* z, lapack_int ldz, + double* work, lapack_int lwork ); +lapack_int LAPACKE_cgghd3_work( int matrix_layout, char compq, char compz, + lapack_int n, lapack_int ilo, lapack_int ihi, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* q, lapack_int ldq, + lapack_complex_float* z, lapack_int ldz, + lapack_complex_float* work, lapack_int lwork ); +lapack_int LAPACKE_zgghd3_work( int matrix_layout, char compq, char compz, + lapack_int n, lapack_int ilo, lapack_int ihi, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* q, lapack_int ldq, + lapack_complex_double* z, lapack_int ldz, + lapack_complex_double* work, + lapack_int lwork ); + lapack_int LAPACKE_sgglse_work( int matrix_layout, lapack_int m, lapack_int n, lapack_int p, float* a, lapack_int lda, float* b, lapack_int ldb, float* c, float* d, @@ -6971,7 +7161,7 @@ lapack_int LAPACKE_zlagge_work( int matrix_layout, lapack_int m, lapack_int n, lapack_complex_double* a, lapack_int lda, lapack_int* iseed, lapack_complex_double* work ); - + lapack_int LAPACKE_claghe_work( int matrix_layout, lapack_int n, lapack_int k, const float* d, lapack_complex_float* a, lapack_int lda, lapack_int* iseed, @@ -7020,7 +7210,7 @@ lapack_int LAPACKE_slartgs_work( float x, float y, float sigma, float* cs, float* sn ); lapack_int LAPACKE_dlartgs_work( double x, double y, double sigma, double* cs, double* sn ); - + float LAPACKE_slapy2_work( float x, float y ); double LAPACKE_dlapy2_work( double x, double y ); @@ -10430,7 +10620,7 @@ lapack_int LAPACKE_ztpmqrt( int matrix_layout, char side, char trans, const lapack_complex_double* t, lapack_int ldt, lapack_complex_double* a, lapack_int lda, lapack_complex_double* b, lapack_int ldb ); - + lapack_int LAPACKE_stpqrt( int matrix_layout, lapack_int m, lapack_int n, lapack_int l, lapack_int nb, float* a, lapack_int lda, float* b, lapack_int ldb, float* t, @@ -10442,7 +10632,7 @@ lapack_int LAPACKE_dtpqrt( int matrix_layout, lapack_int m, lapack_int n, lapack_int ldt ); lapack_int LAPACKE_ctpqrt( int matrix_layout, lapack_int m, lapack_int n, lapack_int l, lapack_int nb, - lapack_complex_float* a, lapack_int lda, + lapack_complex_float* a, lapack_int lda, lapack_complex_float* b, lapack_int ldb, lapack_complex_float* t, lapack_int ldt ); lapack_int LAPACKE_ztpqrt( int matrix_layout, lapack_int m, lapack_int n, @@ -10461,7 +10651,7 @@ lapack_int LAPACKE_dtpqrt2( int matrix_layout, double* a, lapack_int lda, double* b, lapack_int ldb, double* t, lapack_int ldt ); -lapack_int LAPACKE_ctpqrt2( int matrix_layout, +lapack_int LAPACKE_ctpqrt2( int matrix_layout, lapack_int m, lapack_int n, lapack_int l, lapack_complex_float* a, lapack_int lda, lapack_complex_float* b, lapack_int ldb, @@ -10589,7 +10779,7 @@ lapack_int LAPACKE_ztpmqrt_work( int matrix_layout, char side, char trans, lapack_complex_double* a, lapack_int lda, lapack_complex_double* b, lapack_int ldb, lapack_complex_double* work ); - + lapack_int LAPACKE_stpqrt_work( int matrix_layout, lapack_int m, lapack_int n, lapack_int l, lapack_int nb, float* a, lapack_int lda, float* b, lapack_int ldb, @@ -11347,6 +11537,10 @@ void LAPACKE_ilaver( const lapack_int* vers_major, #define LAPACK_dgghrd LAPACK_GLOBAL(dgghrd,DGGHRD) #define LAPACK_cgghrd LAPACK_GLOBAL(cgghrd,CGGHRD) #define LAPACK_zgghrd LAPACK_GLOBAL(zgghrd,ZGGHRD) +#define LAPACK_sgghd3 LAPACK_GLOBAL(sgghd3,SGGHD3) +#define LAPACK_dgghd3 LAPACK_GLOBAL(dgghd3,DGGHD3) +#define LAPACK_cgghd3 LAPACK_GLOBAL(cgghd3,CGGHD3) +#define LAPACK_zgghd3 LAPACK_GLOBAL(zgghd3,ZGGHD3) #define LAPACK_sggbal LAPACK_GLOBAL(sggbal,SGGBAL) #define LAPACK_dggbal LAPACK_GLOBAL(dggbal,DGGBAL) #define LAPACK_cggbal LAPACK_GLOBAL(cggbal,CGGBAL) @@ -11531,6 +11725,10 @@ void LAPACKE_ilaver( const lapack_int* vers_major, #define LAPACK_dgges LAPACK_GLOBAL(dgges,DGGES) #define LAPACK_cgges LAPACK_GLOBAL(cgges,CGGES) #define LAPACK_zgges LAPACK_GLOBAL(zgges,ZGGES) +#define LAPACK_sgges3 LAPACK_GLOBAL(sgges3,SGGES3) +#define LAPACK_dgges3 LAPACK_GLOBAL(dgges3,DGGES3) +#define LAPACK_cgges3 LAPACK_GLOBAL(cgges3,CGGES3) +#define LAPACK_zgges3 LAPACK_GLOBAL(zgges3,ZGGES3) #define LAPACK_sggesx LAPACK_GLOBAL(sggesx,SGGESX) #define LAPACK_dggesx LAPACK_GLOBAL(dggesx,DGGESX) #define LAPACK_cggesx LAPACK_GLOBAL(cggesx,CGGESX) @@ -11539,6 +11737,10 @@ void LAPACKE_ilaver( const lapack_int* vers_major, #define LAPACK_dggev LAPACK_GLOBAL(dggev,DGGEV) #define LAPACK_cggev LAPACK_GLOBAL(cggev,CGGEV) #define LAPACK_zggev LAPACK_GLOBAL(zggev,ZGGEV) +#define LAPACK_sggev3 LAPACK_GLOBAL(sggev3,SGGEV3) +#define LAPACK_dggev3 LAPACK_GLOBAL(dggev3,DGGEV3) +#define LAPACK_cggev3 LAPACK_GLOBAL(cggev3,CGGEV3) +#define LAPACK_zggev3 LAPACK_GLOBAL(zggev3,ZGGEV3) #define LAPACK_sggevx LAPACK_GLOBAL(sggevx,SGGEVX) #define LAPACK_dggevx LAPACK_GLOBAL(dggevx,DGGEVX) #define LAPACK_cggevx LAPACK_GLOBAL(cggevx,CGGEVX) @@ -14524,6 +14726,32 @@ void LAPACK_zgghrd( char* compq, char* compz, lapack_int* n, lapack_int* ilo, lapack_complex_double* q, lapack_int* ldq, lapack_complex_double* z, lapack_int* ldz, lapack_int *info ); +void LAPACK_sgghd3( char* compq, char* compz, lapack_int* n, lapack_int* ilo, + lapack_int* ihi, float* a, lapack_int* lda, float* b, + lapack_int* ldb, float* q, lapack_int* ldq, float* z, + lapack_int* ldz, float* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_dgghd3( char* compq, char* compz, lapack_int* n, lapack_int* ilo, + lapack_int* ihi, double* a, lapack_int* lda, double* b, + lapack_int* ldb, double* q, lapack_int* ldq, double* z, + lapack_int* ldz, double* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_cgghd3( char* compq, char* compz, lapack_int* n, + lapack_int* ilo, lapack_int* ihi, + lapack_complex_float* a, lapack_int* lda, + lapack_complex_float* b, lapack_int* ldb, + lapack_complex_float* q, lapack_int* ldq, + lapack_complex_float* z, lapack_int* ldz, + lapack_complex_float* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_zgghd3( char* compq, char* compz, lapack_int* n, + lapack_int* ilo, lapack_int* ihi, + lapack_complex_double* a, lapack_int* lda, + lapack_complex_double* b, lapack_int* ldb, + lapack_complex_double* q, lapack_int* ldq, + lapack_complex_double* z, lapack_int* ldz, + lapack_complex_double* work, lapack_int* lwork, + lapack_int *info ); void LAPACK_sggbal( char* job, lapack_int* n, float* a, lapack_int* lda, float* b, lapack_int* ldb, lapack_int* ilo, lapack_int* ihi, float* lscale, float* rscale, float* work, @@ -15561,6 +15789,40 @@ void LAPACK_zgges( char* jobvsl, char* jobvsr, char* sort, lapack_complex_double* vsr, lapack_int* ldvsr, lapack_complex_double* work, lapack_int* lwork, double* rwork, lapack_logical* bwork, lapack_int *info ); +void LAPACK_sgges3( char* jobvsl, char* jobvsr, char* sort, + LAPACK_S_SELECT3 selctg, lapack_int* n, + float* a, lapack_int* lda, float* b, lapack_int* ldb, + lapack_int* sdim, float* alphar, float* alphai, + float* beta, float* vsl, lapack_int* ldvsl, + float* vsr, lapack_int* ldvsr, + float* work, lapack_int* lwork, lapack_logical* bwork, + lapack_int *info ); +void LAPACK_dgges3( char* jobvsl, char* jobvsr, char* sort, + LAPACK_D_SELECT3 selctg, lapack_int* n, double* a, + lapack_int* lda, double* b, lapack_int* ldb, + lapack_int* sdim, double* alphar, double* alphai, + double* beta, double* vsl, lapack_int* ldvsl, double* vsr, + lapack_int* ldvsr, double* work, lapack_int* lwork, + lapack_logical* bwork, lapack_int *info ); +void LAPACK_cgges3( char* jobvsl, char* jobvsr, char* sort, + LAPACK_C_SELECT2 selctg, lapack_int* n, + lapack_complex_float* a, lapack_int* lda, + lapack_complex_float* b, lapack_int* ldb, + lapack_int* sdim, + lapack_complex_float* alpha, lapack_complex_float* beta, + lapack_complex_float* vsl, lapack_int* ldvsl, + lapack_complex_float* vsr, lapack_int* ldvsr, + lapack_complex_float* work, lapack_int* lwork, float* rwork, + lapack_logical* bwork, lapack_int *info ); +void LAPACK_zgges3( char* jobvsl, char* jobvsr, char* sort, + LAPACK_Z_SELECT2 selctg, lapack_int* n, + lapack_complex_double* a, lapack_int* lda, + lapack_complex_double* b, lapack_int* ldb, lapack_int* sdim, + lapack_complex_double* alpha, lapack_complex_double* beta, + lapack_complex_double* vsl, lapack_int* ldvsl, + lapack_complex_double* vsr, lapack_int* ldvsr, + lapack_complex_double* work, lapack_int* lwork, + double* rwork, lapack_logical* bwork, lapack_int *info ); void LAPACK_sggesx( char* jobvsl, char* jobvsr, char* sort, LAPACK_S_SELECT3 selctg, char* sense, lapack_int* n, float* a, lapack_int* lda, float* b, lapack_int* ldb, @@ -15627,6 +15889,32 @@ void LAPACK_zggev( char* jobvl, char* jobvr, lapack_int* n, lapack_complex_double* vr, lapack_int* ldvr, lapack_complex_double* work, lapack_int* lwork, double* rwork, lapack_int *info ); +void LAPACK_sggev3( char* jobvl, char* jobvr, lapack_int* n, float* a, + lapack_int* lda, float* b, lapack_int* ldb, float* alphar, + float* alphai, float* beta, float* vl, lapack_int* ldvl, + float* vr, lapack_int* ldvr, float* work, lapack_int* lwork, + lapack_int *info ); +void LAPACK_dggev3( char* jobvl, char* jobvr, lapack_int* n, double* a, + lapack_int* lda, double* b, lapack_int* ldb, double* alphar, + double* alphai, double* beta, double* vl, lapack_int* ldvl, + double* vr, lapack_int* ldvr, double* work, + lapack_int* lwork, lapack_int *info ); +void LAPACK_cggev3( char* jobvl, char* jobvr, lapack_int* n, + lapack_complex_float* a, lapack_int* lda, + lapack_complex_float* b, lapack_int* ldb, + lapack_complex_float* alpha, lapack_complex_float* beta, + lapack_complex_float* vl, lapack_int* ldvl, + lapack_complex_float* vr, lapack_int* ldvr, + lapack_complex_float* work, lapack_int* lwork, float* rwork, + lapack_int *info ); +void LAPACK_zggev3( char* jobvl, char* jobvr, lapack_int* n, + lapack_complex_double* a, lapack_int* lda, + lapack_complex_double* b, lapack_int* ldb, + lapack_complex_double* alpha, lapack_complex_double* beta, + lapack_complex_double* vl, lapack_int* ldvl, + lapack_complex_double* vr, lapack_int* ldvr, + lapack_complex_double* work, lapack_int* lwork, + double* rwork, lapack_int *info ); void LAPACK_sggevx( char* balanc, char* jobvl, char* jobvr, char* sense, lapack_int* n, float* a, lapack_int* lda, float* b, lapack_int* ldb, float* alphar, float* alphai, float* beta, diff --git a/LAPACKE/src/CMakeLists.txt b/LAPACKE/src/CMakeLists.txt index 20bac67..4a0a319 100644 --- a/LAPACKE/src/CMakeLists.txt +++ b/LAPACKE/src/CMakeLists.txt @@ -103,16 +103,22 @@ lapacke_cggbal.c lapacke_cggbal_work.c lapacke_cgges.c lapacke_cgges_work.c +lapacke_cgges3.c +lapacke_cgges3_work.c lapacke_cggesx.c lapacke_cggesx_work.c lapacke_cggev.c lapacke_cggev_work.c +lapacke_cggev3.c +lapacke_cggev3_work.c lapacke_cggevx.c lapacke_cggevx_work.c lapacke_cggglm.c lapacke_cggglm_work.c lapacke_cgghrd.c lapacke_cgghrd_work.c +lapacke_cgghd3.c +lapacke_cgghd3_work.c lapacke_cgglse.c lapacke_cgglse_work.c lapacke_cggqrf.c @@ -609,16 +615,22 @@ lapacke_dggbal.c lapacke_dggbal_work.c lapacke_dgges.c lapacke_dgges_work.c +lapacke_dgges3.c +lapacke_dgges3_work.c lapacke_dggesx.c lapacke_dggesx_work.c lapacke_dggev.c lapacke_dggev_work.c +lapacke_dggev3.c +lapacke_dggev3_work.c lapacke_dggevx.c lapacke_dggevx_work.c lapacke_dggglm.c lapacke_dggglm_work.c lapacke_dgghrd.c lapacke_dgghrd_work.c +lapacke_dgghd3.c +lapacke_dgghd3_work.c lapacke_dgglse.c lapacke_dgglse_work.c lapacke_dggqrf.c @@ -1099,16 +1111,22 @@ lapacke_sggbal.c lapacke_sggbal_work.c lapacke_sgges.c lapacke_sgges_work.c +lapacke_sgges3.c +lapacke_sgges3_work.c lapacke_sggesx.c lapacke_sggesx_work.c lapacke_sggev.c lapacke_sggev_work.c +lapacke_sggev3.c +lapacke_sggev3_work.c lapacke_sggevx.c lapacke_sggevx_work.c lapacke_sggglm.c lapacke_sggglm_work.c lapacke_sgghrd.c lapacke_sgghrd_work.c +lapacke_sgghd3.c +lapacke_sgghd3_work.c lapacke_sgglse.c lapacke_sgglse_work.c lapacke_sggqrf.c @@ -1581,16 +1599,22 @@ lapacke_zggbal.c lapacke_zggbal_work.c lapacke_zgges.c lapacke_zgges_work.c +lapacke_zgges3.c +lapacke_zgges3_work.c lapacke_zggesx.c lapacke_zggesx_work.c lapacke_zggev.c lapacke_zggev_work.c +lapacke_zggev3.c +lapacke_zggev3_work.c lapacke_zggevx.c lapacke_zggevx_work.c lapacke_zggglm.c lapacke_zggglm_work.c lapacke_zgghrd.c lapacke_zgghrd_work.c +lapacke_zgghd3.c +lapacke_zgghd3_work.c lapacke_zgglse.c lapacke_zgglse_work.c lapacke_zggqrf.c diff --git a/LAPACKE/src/Makefile b/LAPACKE/src/Makefile index df57dda..28583ee 100644 --- a/LAPACKE/src/Makefile +++ b/LAPACKE/src/Makefile @@ -137,16 +137,22 @@ lapacke_cggbal.o \ lapacke_cggbal_work.o \ lapacke_cgges.o \ lapacke_cgges_work.o \ +lapacke_cgges3.o \ +lapacke_cgges3_work.o \ lapacke_cggesx.o \ lapacke_cggesx_work.o \ lapacke_cggev.o \ lapacke_cggev_work.o \ +lapacke_cggev3.o \ +lapacke_cggev3_work.o \ lapacke_cggevx.o \ lapacke_cggevx_work.o \ lapacke_cggglm.o \ lapacke_cggglm_work.o \ lapacke_cgghrd.o \ lapacke_cgghrd_work.o \ +lapacke_cgghd3.o \ +lapacke_cgghd3_work.o \ lapacke_cgglse.o \ lapacke_cgglse_work.o \ lapacke_cggqrf.o \ @@ -643,16 +649,22 @@ lapacke_dggbal.o \ lapacke_dggbal_work.o \ lapacke_dgges.o \ lapacke_dgges_work.o \ +lapacke_dgges3.o \ +lapacke_dgges3_work.o \ lapacke_dggesx.o \ lapacke_dggesx_work.o \ lapacke_dggev.o \ lapacke_dggev_work.o \ +lapacke_dggev3.o \ +lapacke_dggev3_work.o \ lapacke_dggevx.o \ lapacke_dggevx_work.o \ lapacke_dggglm.o \ lapacke_dggglm_work.o \ lapacke_dgghrd.o \ lapacke_dgghrd_work.o \ +lapacke_dgghd3.o \ +lapacke_dgghd3_work.o \ lapacke_dgglse.o \ lapacke_dgglse_work.o \ lapacke_dggqrf.o \ @@ -1133,16 +1145,22 @@ lapacke_sggbal.o \ lapacke_sggbal_work.o \ lapacke_sgges.o \ lapacke_sgges_work.o \ +lapacke_sgges3.o \ +lapacke_sgges3_work.o \ lapacke_sggesx.o \ lapacke_sggesx_work.o \ lapacke_sggev.o \ lapacke_sggev_work.o \ +lapacke_sggev3.o \ +lapacke_sggev3_work.o \ lapacke_sggevx.o \ lapacke_sggevx_work.o \ lapacke_sggglm.o \ lapacke_sggglm_work.o \ lapacke_sgghrd.o \ lapacke_sgghrd_work.o \ +lapacke_sgghd3.o \ +lapacke_sgghd3_work.o \ lapacke_sgglse.o \ lapacke_sgglse_work.o \ lapacke_sggqrf.o \ @@ -1615,16 +1633,22 @@ lapacke_zggbal.o \ lapacke_zggbal_work.o \ lapacke_zgges.o \ lapacke_zgges_work.o \ +lapacke_zgges3.o \ +lapacke_zgges3_work.o \ lapacke_zggesx.o \ lapacke_zggesx_work.o \ lapacke_zggev.o \ lapacke_zggev_work.o \ +lapacke_zggev3.o \ +lapacke_zggev3_work.o \ lapacke_zggevx.o \ lapacke_zggevx_work.o \ lapacke_zggglm.o \ lapacke_zggglm_work.o \ lapacke_zgghrd.o \ lapacke_zgghrd_work.o \ +lapacke_zgghd3.o \ +lapacke_zgghd3_work.o \ lapacke_zgglse.o \ lapacke_zgglse_work.o \ lapacke_zggqrf.o \ diff --git a/LAPACKE/src/lapacke_cgges3.c b/LAPACKE/src/lapacke_cgges3.c new file mode 100644 index 0000000..09cd9b9 --- /dev/null +++ b/LAPACKE/src/lapacke_cgges3.c @@ -0,0 +1,110 @@ +/***************************************************************************** + Copyright (c) 2015, 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 cgges3 +* Author: Intel Corporation +* Generated March, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cgges3( int matrix_layout, char jobvsl, char jobvsr, char sort, + LAPACK_C_SELECT2 selctg, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* b, lapack_int ldb, + lapack_int* sdim, lapack_complex_float* alpha, + lapack_complex_float* beta, lapack_complex_float* vsl, + lapack_int ldvsl, lapack_complex_float* vsr, + lapack_int ldvsr ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_logical* bwork = NULL; + float* rwork = NULL; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_cgges3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_cge_nancheck( matrix_layout, n, n, a, lda ) ) { + return -7; + } + if( LAPACKE_cge_nancheck( matrix_layout, n, n, b, ldb ) ) { + return -9; + } +#endif + /* Allocate memory for working array(s) */ + if( LAPACKE_lsame( sort, 's' ) ) { + bwork = (lapack_logical*) + LAPACKE_malloc( sizeof(lapack_logical) * MAX(1,n) ); + if( bwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + } + rwork = (float*)LAPACKE_malloc( sizeof(float) * MAX(1,8*n) ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Query optimal working array(s) size */ + info = LAPACKE_cgges3_work( matrix_layout, jobvsl, jobvsr, sort, selctg, n, a, + lda, b, ldb, sdim, alpha, beta, vsl, ldvsl, vsr, + ldvsr, &work_query, lwork, rwork, bwork ); + if( info != 0 ) { + goto exit_level_2; + } + 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_2; + } + /* Call middle-level interface */ + info = LAPACKE_cgges3_work( matrix_layout, jobvsl, jobvsr, sort, selctg, n, a, + lda, b, ldb, sdim, alpha, beta, vsl, ldvsl, vsr, + ldvsr, work, lwork, rwork, bwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_2: + LAPACKE_free( rwork ); +exit_level_1: + if( LAPACKE_lsame( sort, 's' ) ) { + LAPACKE_free( bwork ); + } +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cgges3", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_cgges3_work.c b/LAPACKE/src/lapacke_cgges3_work.c new file mode 100644 index 0000000..2f0aaad --- /dev/null +++ b/LAPACKE/src/lapacke_cgges3_work.c @@ -0,0 +1,166 @@ +/***************************************************************************** + Copyright (c) 2015, 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 cgges3 +* Author: Intel Corporation +* Generated February, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cgges3_work( int matrix_layout, char jobvsl, char jobvsr, + char sort, LAPACK_C_SELECT2 selctg, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* b, lapack_int ldb, + lapack_int* sdim, lapack_complex_float* alpha, + lapack_complex_float* beta, + lapack_complex_float* vsl, lapack_int ldvsl, + lapack_complex_float* vsr, lapack_int ldvsr, + lapack_complex_float* work, lapack_int lwork, + float* rwork, lapack_logical* bwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_cgges3( &jobvsl, &jobvsr, &sort, selctg, &n, a, &lda, b, &ldb, + sdim, alpha, beta, vsl, &ldvsl, vsr, &ldvsr, + work, &lwork, rwork, bwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_int ldvsl_t = MAX(1,n); + lapack_int ldvsr_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + lapack_complex_float* b_t = NULL; + lapack_complex_float* vsl_t = NULL; + lapack_complex_float* vsr_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_cgges3_work", info ); + return info; + } + if( ldb < n ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_cgges3_work", info ); + return info; + } + if( ldvsl < n ) { + info = -15; + LAPACKE_xerbla( "LAPACKE_cgges3_work", info ); + return info; + } + if( ldvsr < n ) { + info = -17; + LAPACKE_xerbla( "LAPACKE_cgges3_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_cgges3( &jobvsl, &jobvsr, &sort, selctg, &n, a, &lda_t, b, + &ldb_t, sdim, alpha, beta, vsl, &ldvsl_t, vsr, + &ldvsr_t, work, &lwork, rwork, bwork, &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,n) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + if( LAPACKE_lsame( jobvsl, 'v' ) ) { + vsl_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * + ldvsl_t * MAX(1,n) ); + if( vsl_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_2; + } + } + if( LAPACKE_lsame( jobvsr, 'v' ) ) { + vsr_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * + ldvsr_t * MAX(1,n) ); + if( vsr_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_3; + } + } + /* Transpose input matrices */ + LAPACKE_cge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + LAPACKE_cge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_cgges3( &jobvsl, &jobvsr, &sort, selctg, &n, a_t, &lda_t, b_t, + &ldb_t, sdim, alpha, beta, vsl_t, &ldvsl_t, vsr_t, + &ldvsr_t, work, &lwork, rwork, bwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, n, b_t, ldb_t, b, ldb ); + if( LAPACKE_lsame( jobvsl, 'v' ) ) { + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, n, vsl_t, ldvsl_t, vsl, + ldvsl ); + } + if( LAPACKE_lsame( jobvsr, 'v' ) ) { + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, n, vsr_t, ldvsr_t, vsr, + ldvsr ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobvsr, 'v' ) ) { + LAPACKE_free( vsr_t ); + } +exit_level_3: + if( LAPACKE_lsame( jobvsl, 'v' ) ) { + LAPACKE_free( vsl_t ); + } +exit_level_2: + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cgges3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_cgges3_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_cggev3.c b/LAPACKE/src/lapacke_cggev3.c new file mode 100644 index 0000000..e9f94ce --- /dev/null +++ b/LAPACKE/src/lapacke_cggev3.c @@ -0,0 +1,97 @@ +/***************************************************************************** + Copyright (c) 2015, 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 cggev3 +* Author: Intel Corporation +* Generated February, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cggev3( int matrix_layout, + char jobvl, char jobvr, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* alpha, + lapack_complex_float* beta, + lapack_complex_float* vl, lapack_int ldvl, + lapack_complex_float* vr, lapack_int ldvr ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* rwork = NULL; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_cggev3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_cge_nancheck( matrix_layout, n, n, a, lda ) ) { + return -5; + } + if( LAPACKE_cge_nancheck( matrix_layout, n, n, b, ldb ) ) { + return -7; + } +#endif + /* Allocate memory for working array(s) */ + rwork = (float*)LAPACKE_malloc( sizeof(float) * MAX(1,8*n) ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Query optimal working array(s) size */ + info = LAPACKE_cggev3_work( matrix_layout, jobvl, jobvr, n, a, lda, b, ldb, + alpha, beta, vl, ldvl, vr, ldvr, &work_query, + lwork, rwork ); + if( info != 0 ) { + goto exit_level_1; + } + 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_1; + } + /* Call middle-level interface */ + info = LAPACKE_cggev3_work( matrix_layout, jobvl, jobvr, n, a, lda, b, ldb, + alpha, beta, vl, ldvl, vr, ldvr, work, lwork, + rwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( rwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cggev3", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_cggev3_work.c b/LAPACKE/src/lapacke_cggev3_work.c new file mode 100644 index 0000000..ae43cf5 --- /dev/null +++ b/LAPACKE/src/lapacke_cggev3_work.c @@ -0,0 +1,169 @@ +/***************************************************************************** + Copyright (c) 2015, 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 cggev3 +* Author: Intel Corporation +* Generated February, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cggev3_work( int matrix_layout, + char jobvl, char jobvr, lapack_int n, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* alpha, + lapack_complex_float* beta, + lapack_complex_float* vl, lapack_int ldvl, + lapack_complex_float* vr, lapack_int ldvr, + lapack_complex_float* work, lapack_int lwork, + float* rwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_cggev3( &jobvl, &jobvr, &n, a, &lda, b, &ldb, alpha, beta, vl, + &ldvl, vr, &ldvr, work, &lwork, rwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int nrows_vl = LAPACKE_lsame( jobvl, 'v' ) ? n : 1; + lapack_int ncols_vl = LAPACKE_lsame( jobvl, 'v' ) ? n : 1; + lapack_int nrows_vr = LAPACKE_lsame( jobvr, 'v' ) ? n : 1; + lapack_int ncols_vr = LAPACKE_lsame( jobvr, 'v' ) ? n : 1; + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_int ldvl_t = MAX(1,nrows_vl); + lapack_int ldvr_t = MAX(1,nrows_vr); + lapack_complex_float* a_t = NULL; + lapack_complex_float* b_t = NULL; + lapack_complex_float* vl_t = NULL; + lapack_complex_float* vr_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_cggev3_work", info ); + return info; + } + if( ldb < n ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_cggev3_work", info ); + return info; + } + if( ldvl < ncols_vl ) { + info = -12; + LAPACKE_xerbla( "LAPACKE_cggev3_work", info ); + return info; + } + if( ldvr < ncols_vr ) { + info = -14; + LAPACKE_xerbla( "LAPACKE_cggev3_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_cggev3( &jobvl, &jobvr, &n, a, &lda_t, b, &ldb_t, alpha, + beta, vl, &ldvl_t, vr, &ldvr_t, work, &lwork, rwork, + &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,n) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + if( LAPACKE_lsame( jobvl, 'v' ) ) { + vl_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * + ldvl_t * MAX(1,ncols_vl) ); + if( vl_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_2; + } + } + if( LAPACKE_lsame( jobvr, 'v' ) ) { + vr_t = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * + ldvr_t * MAX(1,ncols_vr) ); + if( vr_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_3; + } + } + /* Transpose input matrices */ + LAPACKE_cge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + LAPACKE_cge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_cggev3( &jobvl, &jobvr, &n, a_t, &lda_t, b_t, &ldb_t, alpha, + beta, vl_t, &ldvl_t, vr_t, &ldvr_t, work, &lwork, rwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, n, b_t, ldb_t, b, ldb ); + if( LAPACKE_lsame( jobvl, 'v' ) ) { + LAPACKE_cge_trans( LAPACK_COL_MAJOR, nrows_vl, ncols_vl, vl_t, + ldvl_t, vl, ldvl ); + } + if( LAPACKE_lsame( jobvr, 'v' ) ) { + LAPACKE_cge_trans( LAPACK_COL_MAJOR, nrows_vr, ncols_vr, vr_t, + ldvr_t, vr, ldvr ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobvr, 'v' ) ) { + LAPACKE_free( vr_t ); + } +exit_level_3: + if( LAPACKE_lsame( jobvl, 'v' ) ) { + LAPACKE_free( vl_t ); + } +exit_level_2: + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cggev3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_cggev3_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_cgghd3.c b/LAPACKE/src/lapacke_cgghd3.c new file mode 100644 index 0000000..ff2f110 --- /dev/null +++ b/LAPACKE/src/lapacke_cgghd3.c @@ -0,0 +1,97 @@ +/***************************************************************************** + Copyright (c) 2015, 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 cgghd3 +* Author: Intel Corporation +* Generated January, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cgghd3( int matrix_layout, char compq, char compz, + lapack_int n, lapack_int ilo, lapack_int ihi, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* q, lapack_int ldq, + lapack_complex_float* z, lapack_int ldz ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_float* work = NULL; + lapack_complex_float work_query; + + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_cgghd3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_cge_nancheck( matrix_layout, n, n, a, lda ) ) { + return -7; + } + if( LAPACKE_cge_nancheck( matrix_layout, n, n, b, ldb ) ) { + return -9; + } + if( LAPACKE_lsame( compq, 'i' ) || LAPACKE_lsame( compq, 'v' ) ) { + if( LAPACKE_cge_nancheck( matrix_layout, n, n, q, ldq ) ) { + return -11; + } + } + if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + if( LAPACKE_cge_nancheck( matrix_layout, n, n, z, ldz ) ) { + return -13; + } + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_cgghd3_work( matrix_layout, compq, compz, n, ilo, ihi, + a, lda, b, ldb, q, ldq, z, ldz, &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_cgghd3_work( matrix_layout, compq, compz, n, ilo, ihi, + a, lda, b, ldb, q, ldq, z, ldz, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cgghd3", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_cgghd3_work.c b/LAPACKE/src/lapacke_cgghd3_work.c new file mode 100644 index 0000000..a35ad62 --- /dev/null +++ b/LAPACKE/src/lapacke_cgghd3_work.c @@ -0,0 +1,158 @@ +/***************************************************************************** + Copyright (c) 2015, 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 cgghd3 +* Author: Intel Corporation +* Generated January, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cgghd3_work( int matrix_layout, char compq, char compz, + lapack_int n, lapack_int ilo, lapack_int ihi, + lapack_complex_float* a, lapack_int lda, + lapack_complex_float* b, lapack_int ldb, + lapack_complex_float* q, lapack_int ldq, + lapack_complex_float* z, lapack_int ldz, + lapack_complex_float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_cgghd3( &compq, &compz, &n, &ilo, &ihi, a, &lda, b, &ldb, q, + &ldq, z, &ldz, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_int ldq_t = MAX(1,n); + lapack_int ldz_t = MAX(1,n); + lapack_complex_float* a_t = NULL; + lapack_complex_float* b_t = NULL; + lapack_complex_float* q_t = NULL; + lapack_complex_float* z_t = NULL; + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_cgghd3( &compq, &compz, &n, &ilo, &ihi, a, &lda, b, &ldb, q, + &ldq, z, &ldz, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Check leading dimension(s) */ + if( lda < n ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_cgghd3_work", info ); + return info; + } + if( ldb < n ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_cgghd3_work", info ); + return info; + } + if( ldq < n ) { + info = -12; + LAPACKE_xerbla( "LAPACKE_cgghd3_work", info ); + return info; + } + if( ldz < n ) { + info = -14; + LAPACKE_xerbla( "LAPACKE_cgghd3_work", info ); + return 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,n) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + if( LAPACKE_lsame( compq, 'i' ) || LAPACKE_lsame( compq, 'v' ) ) { + q_t = (lapack_complex_float*)LAPACKE_malloc( sizeof(lapack_complex_float) * ldq_t * MAX(1,n) ); + if( q_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_2; + } + } + if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + z_t = (lapack_complex_float*)LAPACKE_malloc( sizeof(lapack_complex_float) * ldz_t * MAX(1,n) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_3; + } + } + /* Transpose input matrices */ + LAPACKE_cge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + LAPACKE_cge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + if( LAPACKE_lsame( compq, 'v' ) ) { + LAPACKE_cge_trans( matrix_layout, n, n, q, ldq, q_t, ldq_t ); + } + if( LAPACKE_lsame( compz, 'v' ) ) { + LAPACKE_cge_trans( matrix_layout, n, n, z, ldz, z_t, ldz_t ); + } + /* Call LAPACK function and adjust info */ + LAPACK_cgghd3( &compq, &compz, &n, &ilo, &ihi, a_t, &lda_t, b_t, &ldb_t, + q_t, &ldq_t, z_t, &ldz_t, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, n, b_t, ldb_t, b, ldb ); + if( LAPACKE_lsame( compq, 'i' ) || LAPACKE_lsame( compq, 'v' ) ) { + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, n, q_t, ldq_t, q, ldq ); + } + if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + LAPACKE_cge_trans( LAPACK_COL_MAJOR, n, n, z_t, ldz_t, z, ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + LAPACKE_free( z_t ); + } + exit_level_3: + if( LAPACKE_lsame( compq, 'i' ) || LAPACKE_lsame( compq, 'v' ) ) { + LAPACKE_free( q_t ); + } + exit_level_2: + LAPACKE_free( b_t ); + exit_level_1: + LAPACKE_free( a_t ); + exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cgghd3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_cgghd3_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dgges3.c b/LAPACKE/src/lapacke_dgges3.c new file mode 100644 index 0000000..9aae144 --- /dev/null +++ b/LAPACKE/src/lapacke_dgges3.c @@ -0,0 +1,100 @@ +/***************************************************************************** + Copyright (c) 2015, 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 dgges3 +* Author: Intel Corporation +* Generated February, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dgges3( int matrix_layout, char jobvsl, char jobvsr, + char sort, LAPACK_D_SELECT3 selctg, lapack_int n, + double* a, lapack_int lda, double* b, lapack_int ldb, + lapack_int* sdim, double* alphar, double* alphai, + double* beta, double* vsl, lapack_int ldvsl, + double* vsr, lapack_int ldvsr ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_logical* bwork = NULL; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dgges3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dge_nancheck( matrix_layout, n, n, a, lda ) ) { + return -7; + } + if( LAPACKE_dge_nancheck( matrix_layout, n, n, b, ldb ) ) { + return -9; + } +#endif + /* Allocate memory for working array(s) */ + if( LAPACKE_lsame( sort, 's' ) ) { + bwork = (lapack_logical*) + LAPACKE_malloc( sizeof(lapack_logical) * MAX(1,n) ); + if( bwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + } + /* Query optimal working array(s) size */ + info = LAPACKE_dgges3_work( matrix_layout, jobvsl, jobvsr, sort, selctg, + n, a, lda, b, ldb, sdim, alphar, alphai, beta, + vsl, ldvsl, vsr, ldvsr, + &work_query, lwork, bwork ); + if( info != 0 ) { + goto exit_level_1; + } + 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_1; + } + /* Call middle-level interface */ + info = LAPACKE_dgges3_work( matrix_layout, jobvsl, jobvsr, sort, selctg, + n, a, lda, b, ldb, sdim, alphar, alphai, beta, + vsl, ldvsl, vsr, ldvsr, work, lwork, bwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + if( LAPACKE_lsame( sort, 's' ) ) { + LAPACKE_free( bwork ); + } +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dgges3", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dgges3_work.c b/LAPACKE/src/lapacke_dgges3_work.c new file mode 100644 index 0000000..7a05a46 --- /dev/null +++ b/LAPACKE/src/lapacke_dgges3_work.c @@ -0,0 +1,161 @@ +/***************************************************************************** + Copyright (c) 2015, 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 dgges3 +* Author: Intel Corporation +* Generated February, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dgges3_work( int matrix_layout, char jobvsl, char jobvsr, + char sort, LAPACK_D_SELECT3 selctg, + lapack_int n, double* a, lapack_int lda, + double* b, lapack_int ldb, lapack_int* sdim, + double* alphar, double* alphai, double* beta, + double* vsl, lapack_int ldvsl, + double* vsr, lapack_int ldvsr, + double* work, lapack_int lwork, + lapack_logical* bwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dgges3( &jobvsl, &jobvsr, &sort, selctg, &n, a, &lda, b, &ldb, + sdim, alphar, alphai, beta, vsl, &ldvsl, vsr, &ldvsr, + work, &lwork, bwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_int ldvsl_t = MAX(1,n); + lapack_int ldvsr_t = MAX(1,n); + double* a_t = NULL; + double* b_t = NULL; + double* vsl_t = NULL; + double* vsr_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_dgges3_work", info ); + return info; + } + if( ldb < n ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_dgges3_work", info ); + return info; + } + if( ldvsl < n ) { + info = -16; + LAPACKE_xerbla( "LAPACKE_dgges3_work", info ); + return info; + } + if( ldvsr < n ) { + info = -18; + LAPACKE_xerbla( "LAPACKE_dgges3_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_dgges3( &jobvsl, &jobvsr, &sort, selctg, &n, a, &lda_t, b, + &ldb_t, sdim, alphar, alphai, beta, vsl, &ldvsl_t, + vsr, &ldvsr_t, work, &lwork, bwork, &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,n) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + if( LAPACKE_lsame( jobvsl, 'v' ) ) { + vsl_t = (double*) + LAPACKE_malloc( sizeof(double) * ldvsl_t * MAX(1,n) ); + if( vsl_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_2; + } + } + if( LAPACKE_lsame( jobvsr, 'v' ) ) { + vsr_t = (double*) + LAPACKE_malloc( sizeof(double) * ldvsr_t * MAX(1,n) ); + if( vsr_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_3; + } + } + /* Transpose input matrices */ + LAPACKE_dge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + LAPACKE_dge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dgges3( &jobvsl, &jobvsr, &sort, selctg, &n, a_t, &lda_t, b_t, + &ldb_t, sdim, alphar, alphai, beta, vsl_t, &ldvsl_t, + vsr_t, &ldvsr_t, work, &lwork, bwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, b_t, ldb_t, b, ldb ); + if( LAPACKE_lsame( jobvsl, 'v' ) ) { + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, vsl_t, ldvsl_t, vsl, + ldvsl ); + } + if( LAPACKE_lsame( jobvsr, 'v' ) ) { + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, vsr_t, ldvsr_t, vsr, + ldvsr ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobvsr, 'v' ) ) { + LAPACKE_free( vsr_t ); + } +exit_level_3: + if( LAPACKE_lsame( jobvsl, 'v' ) ) { + LAPACKE_free( vsl_t ); + } +exit_level_2: + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dgges3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dgges3_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dggev3.c b/LAPACKE/src/lapacke_dggev3.c new file mode 100644 index 0000000..180b70d --- /dev/null +++ b/LAPACKE/src/lapacke_dggev3.c @@ -0,0 +1,86 @@ +/***************************************************************************** + Copyright (c) 2015, 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 dggev3 +* Author: Intel Corporation +* Generated February, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dggev3( int matrix_layout, + char jobvl, char jobvr, lapack_int n, + double* a, lapack_int lda, + double* b, lapack_int ldb, + double* alphar, double* alphai, double* beta, + double* vl, lapack_int ldvl, + double* vr, lapack_int ldvr ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dggev3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dge_nancheck( matrix_layout, n, n, a, lda ) ) { + return -5; + } + if( LAPACKE_dge_nancheck( matrix_layout, n, n, b, ldb ) ) { + return -7; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_dggev3_work( matrix_layout, jobvl, jobvr, n, a, lda, b, ldb, + alphar, alphai, beta, vl, ldvl, vr, ldvr, + &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_dggev3_work( matrix_layout, jobvl, jobvr, n, a, lda, b, ldb, + alphar, alphai, beta, vl, ldvl, vr, ldvr, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dggev3", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dggev3_work.c b/LAPACKE/src/lapacke_dggev3_work.c new file mode 100644 index 0000000..8e8d0e6 --- /dev/null +++ b/LAPACKE/src/lapacke_dggev3_work.c @@ -0,0 +1,161 @@ +/***************************************************************************** + Copyright (c) 2015, 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 dggev3 +* Author: Intel Corporation +* Generated February, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dggev3_work( int matrix_layout, char jobvl, char jobvr, + lapack_int n, double* a, lapack_int lda, + double* b, lapack_int ldb, double* alphar, + double* alphai, double* beta, double* vl, + lapack_int ldvl, double* vr, lapack_int ldvr, + double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dggev3( &jobvl, &jobvr, &n, a, &lda, b, &ldb, alphar, alphai, + beta, vl, &ldvl, vr, &ldvr, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int nrows_vl = LAPACKE_lsame( jobvl, 'v' ) ? n : 1; + lapack_int ncols_vl = LAPACKE_lsame( jobvl, 'v' ) ? n : 1; + lapack_int nrows_vr = LAPACKE_lsame( jobvr, 'v' ) ? n : 1; + lapack_int ncols_vr = LAPACKE_lsame( jobvr, 'v' ) ? n : 1; + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_int ldvl_t = MAX(1,nrows_vl); + lapack_int ldvr_t = MAX(1,nrows_vr); + double* a_t = NULL; + double* b_t = NULL; + double* vl_t = NULL; + double* vr_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_dggev3_work", info ); + return info; + } + if( ldb < n ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_dggev3_work", info ); + return info; + } + if( ldvl < ncols_vl ) { + info = -13; + LAPACKE_xerbla( "LAPACKE_dggev3_work", info ); + return info; + } + if( ldvr < ncols_vr ) { + info = -15; + LAPACKE_xerbla( "LAPACKE_dggev3_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_dggev3( &jobvl, &jobvr, &n, a, &lda_t, b, &ldb_t, + alphar, alphai, beta, vl, &ldvl_t, vr, &ldvr_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,n) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + if( LAPACKE_lsame( jobvl, 'v' ) ) { + vl_t = (double*) + LAPACKE_malloc( sizeof(double) * ldvl_t * MAX(1,ncols_vl) ); + if( vl_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_2; + } + } + if( LAPACKE_lsame( jobvr, 'v' ) ) { + vr_t = (double*) + LAPACKE_malloc( sizeof(double) * ldvr_t * MAX(1,ncols_vr) ); + if( vr_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_3; + } + } + /* Transpose input matrices */ + LAPACKE_dge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + LAPACKE_dge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dggev3( &jobvl, &jobvr, &n, a_t, &lda_t, b_t, &ldb_t, + alphar, alphai, beta, vl_t, &ldvl_t, vr_t, &ldvr_t, + work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, b_t, ldb_t, b, ldb ); + if( LAPACKE_lsame( jobvl, 'v' ) ) { + LAPACKE_dge_trans( LAPACK_COL_MAJOR, nrows_vl, ncols_vl, vl_t, + ldvl_t, vl, ldvl ); + } + if( LAPACKE_lsame( jobvr, 'v' ) ) { + LAPACKE_dge_trans( LAPACK_COL_MAJOR, nrows_vr, ncols_vr, vr_t, + ldvr_t, vr, ldvr ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobvr, 'v' ) ) { + LAPACKE_free( vr_t ); + } +exit_level_3: + if( LAPACKE_lsame( jobvl, 'v' ) ) { + LAPACKE_free( vl_t ); + } +exit_level_2: + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dggev3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dggev3_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dgghd3.c b/LAPACKE/src/lapacke_dgghd3.c new file mode 100644 index 0000000..106f937 --- /dev/null +++ b/LAPACKE/src/lapacke_dgghd3.c @@ -0,0 +1,94 @@ +/***************************************************************************** + Copyright (c) 2015, 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 dgghd3 +* Author: Intel Corporation +* Generated January, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dgghd3( int matrix_layout, char compq, char compz, + lapack_int n, lapack_int ilo, lapack_int ihi, + double* a, lapack_int lda, + double* b, lapack_int ldb, + double* q, lapack_int ldq, + double* z, lapack_int ldz ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dgghd3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dge_nancheck( matrix_layout, n, n, a, lda ) ) { + return -7; + } + if( LAPACKE_dge_nancheck( matrix_layout, n, n, b, ldb ) ) { + return -9; + } + if( LAPACKE_lsame( compq, 'i' ) || LAPACKE_lsame( compq, 'v' ) ) { + if( LAPACKE_dge_nancheck( matrix_layout, n, n, q, ldq ) ) { + return -11; + } + } + if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + if( LAPACKE_dge_nancheck( matrix_layout, n, n, z, ldz ) ) { + return -13; + } + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_dgghd3_work( matrix_layout, compq, compz, n, ilo, ihi, + a, lda, b, ldb, q, ldq, z, ldz, &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_dgghd3_work( matrix_layout, compq, compz, n, ilo, ihi, + a, lda, b, ldb, q, ldq, z, ldz, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dgghd3", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dgghd3_work.c b/LAPACKE/src/lapacke_dgghd3_work.c new file mode 100644 index 0000000..c7080c6 --- /dev/null +++ b/LAPACKE/src/lapacke_dgghd3_work.c @@ -0,0 +1,157 @@ +/***************************************************************************** + Copyright (c) 2015, 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 dgghd3 +* Author: Intel Corporation +* Generated January, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dgghd3_work( int matrix_layout, char compq, char compz, + lapack_int n, lapack_int ilo, lapack_int ihi, + double* a, lapack_int lda, double* b, + lapack_int ldb, double* q, lapack_int ldq, + double* z, lapack_int ldz, double* work, + lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dgghd3( &compq, &compz, &n, &ilo, &ihi, a, &lda, b, &ldb, q, + &ldq, z, &ldz, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_int ldq_t = MAX(1,n); + lapack_int ldz_t = MAX(1,n); + double* a_t = NULL; + double* b_t = NULL; + double* q_t = NULL; + double* z_t = NULL; + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_dgghd3( &compq, &compz, &n, &ilo, &ihi, a, &lda, b, &ldb, q, + &ldq, z, &ldz, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Check leading dimension(s) */ + if( lda < n ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_dgghd3_work", info ); + return info; + } + if( ldb < n ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_dgghd3_work", info ); + return info; + } + if( ldq < n ) { + info = -12; + LAPACKE_xerbla( "LAPACKE_dgghd3_work", info ); + return info; + } + if( ldz < n ) { + info = -14; + LAPACKE_xerbla( "LAPACKE_dgghd3_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 = (double*)LAPACKE_malloc( sizeof(double) * ldb_t * MAX(1,n) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + if( LAPACKE_lsame( compq, 'i' ) || LAPACKE_lsame( compq, 'v' ) ) { + q_t = (double*)LAPACKE_malloc( sizeof(double) * ldq_t * MAX(1,n) ); + if( q_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_2; + } + } + if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + z_t = (double*)LAPACKE_malloc( sizeof(double) * ldz_t * MAX(1,n) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_3; + } + } + /* Transpose input matrices */ + LAPACKE_dge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + LAPACKE_dge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + if( LAPACKE_lsame( compq, 'v' ) ) { + LAPACKE_dge_trans( matrix_layout, n, n, q, ldq, q_t, ldq_t ); + } + if( LAPACKE_lsame( compz, 'v' ) ) { + LAPACKE_dge_trans( matrix_layout, n, n, z, ldz, z_t, ldz_t ); + } + /* Call LAPACK function and adjust info */ + LAPACK_dgghd3( &compq, &compz, &n, &ilo, &ihi, a_t, &lda_t, b_t, &ldb_t, + q_t, &ldq_t, z_t, &ldz_t, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, b_t, ldb_t, b, ldb ); + if( LAPACKE_lsame( compq, 'i' ) || LAPACKE_lsame( compq, 'v' ) ) { + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, q_t, ldq_t, q, ldq ); + } + if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, z_t, ldz_t, z, ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + LAPACKE_free( z_t ); + } + exit_level_3: + if( LAPACKE_lsame( compq, 'i' ) || LAPACKE_lsame( compq, 'v' ) ) { + LAPACKE_free( q_t ); + } + exit_level_2: + LAPACKE_free( b_t ); + exit_level_1: + LAPACKE_free( a_t ); + exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dgghd3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dgghd3_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_sgges3.c b/LAPACKE/src/lapacke_sgges3.c new file mode 100644 index 0000000..00bd01a --- /dev/null +++ b/LAPACKE/src/lapacke_sgges3.c @@ -0,0 +1,99 @@ +/***************************************************************************** + Copyright (c) 2015, 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 sgges3 +* Author: Intel Corporation +* Generated February, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_sgges3( int matrix_layout, char jobvsl, char jobvsr, + char sort, LAPACK_S_SELECT3 selctg, lapack_int n, + float* a, lapack_int lda, float* b, lapack_int ldb, + lapack_int* sdim, float* alphar, float* alphai, + float* beta, float* vsl, lapack_int ldvsl, + float* vsr, lapack_int ldvsr ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_logical* bwork = NULL; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_sgges3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_sge_nancheck( matrix_layout, n, n, a, lda ) ) { + return -7; + } + if( LAPACKE_sge_nancheck( matrix_layout, n, n, b, ldb ) ) { + return -9; + } +#endif + /* Allocate memory for working array(s) */ + if( LAPACKE_lsame( sort, 's' ) ) { + bwork = (lapack_logical*) + LAPACKE_malloc( sizeof(lapack_logical) * MAX(1,n) ); + if( bwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + } + /* Query optimal working array(s) size */ + info = LAPACKE_sgges3_work( matrix_layout, jobvsl, jobvsr, sort, selctg, n, + a, lda, b, ldb, sdim, alphar, alphai, beta, vsl, + ldvsl, vsr, ldvsr, &work_query, lwork, bwork ); + if( info != 0 ) { + goto exit_level_1; + } + 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_1; + } + /* Call middle-level interface */ + info = LAPACKE_sgges3_work( matrix_layout, jobvsl, jobvsr, sort, selctg, n, + a, lda, b, ldb, sdim, alphar, alphai, beta, vsl, + ldvsl, vsr, ldvsr, work, lwork, bwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + if( LAPACKE_lsame( sort, 's' ) ) { + LAPACKE_free( bwork ); + } +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_sgges3", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_sgges3_work.c b/LAPACKE/src/lapacke_sgges3_work.c new file mode 100644 index 0000000..deb6de7 --- /dev/null +++ b/LAPACKE/src/lapacke_sgges3_work.c @@ -0,0 +1,161 @@ +/***************************************************************************** + Copyright (c) 2015, 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 sgges3 +* Author: Intel Corporation +* Generated February, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_sgges3_work( int matrix_layout, char jobvsl, char jobvsr, + char sort, LAPACK_S_SELECT3 selctg, + lapack_int n, float* a, lapack_int lda, + float* b, lapack_int ldb, lapack_int* sdim, + float* alphar, float* alphai, float* beta, + float* vsl, lapack_int ldvsl, + float* vsr, lapack_int ldvsr, + float* work, lapack_int lwork, + lapack_logical* bwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_sgges3( &jobvsl, &jobvsr, &sort, selctg, &n, a, &lda, b, &ldb, + sdim, alphar, alphai, beta, vsl, &ldvsl, vsr, &ldvsr, + work, &lwork, bwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_int ldvsl_t = MAX(1,n); + lapack_int ldvsr_t = MAX(1,n); + float* a_t = NULL; + float* b_t = NULL; + float* vsl_t = NULL; + float* vsr_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_sgges3_work", info ); + return info; + } + if( ldb < n ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_sgges3_work", info ); + return info; + } + if( ldvsl < n ) { + info = -16; + LAPACKE_xerbla( "LAPACKE_sgges3_work", info ); + return info; + } + if( ldvsr < n ) { + info = -18; + LAPACKE_xerbla( "LAPACKE_sgges3_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_sgges3( &jobvsl, &jobvsr, &sort, selctg, &n, a, &lda_t, b, + &ldb_t, sdim, alphar, alphai, beta, vsl, &ldvsl_t, + vsr, &ldvsr_t, work, &lwork, bwork, &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,n) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + if( LAPACKE_lsame( jobvsl, 'v' ) ) { + vsl_t = (float*) + LAPACKE_malloc( sizeof(float) * ldvsl_t * MAX(1,n) ); + if( vsl_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_2; + } + } + if( LAPACKE_lsame( jobvsr, 'v' ) ) { + vsr_t = (float*) + LAPACKE_malloc( sizeof(float) * ldvsr_t * MAX(1,n) ); + if( vsr_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_3; + } + } + /* Transpose input matrices */ + LAPACKE_sge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + LAPACKE_sge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_sgges3( &jobvsl, &jobvsr, &sort, selctg, &n, a_t, &lda_t, b_t, + &ldb_t, sdim, alphar, alphai, beta, vsl_t, &ldvsl_t, + vsr_t, &ldvsr_t, work, &lwork, bwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, n, b_t, ldb_t, b, ldb ); + if( LAPACKE_lsame( jobvsl, 'v' ) ) { + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, n, vsl_t, ldvsl_t, vsl, + ldvsl ); + } + if( LAPACKE_lsame( jobvsr, 'v' ) ) { + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, n, vsr_t, ldvsr_t, vsr, + ldvsr ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobvsr, 'v' ) ) { + LAPACKE_free( vsr_t ); + } +exit_level_3: + if( LAPACKE_lsame( jobvsl, 'v' ) ) { + LAPACKE_free( vsl_t ); + } +exit_level_2: + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_sgges3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_sgges3_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_sggev3.c b/LAPACKE/src/lapacke_sggev3.c new file mode 100644 index 0000000..0b32ffa --- /dev/null +++ b/LAPACKE/src/lapacke_sggev3.c @@ -0,0 +1,84 @@ +/***************************************************************************** + Copyright (c) 2015, 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 sggev3 +* Author: Intel Corporation +* Generated February, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_sggev3( int matrix_layout, char jobvl, char jobvr, + lapack_int n, float* a, lapack_int lda, float* b, + lapack_int ldb, float* alphar, float* alphai, + float* beta, float* vl, lapack_int ldvl, float* vr, + lapack_int ldvr ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_sggev3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_sge_nancheck( matrix_layout, n, n, a, lda ) ) { + return -5; + } + if( LAPACKE_sge_nancheck( matrix_layout, n, n, b, ldb ) ) { + return -7; + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_sggev3_work( matrix_layout, jobvl, jobvr, n, a, lda, b, ldb, + alphar, alphai, beta, vl, ldvl, vr, ldvr, + &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_sggev3_work( matrix_layout, jobvl, jobvr, n, a, lda, b, ldb, + alphar, alphai, beta, vl, ldvl, vr, ldvr, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_sggev3", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_sggev3_work.c b/LAPACKE/src/lapacke_sggev3_work.c new file mode 100644 index 0000000..08ce681 --- /dev/null +++ b/LAPACKE/src/lapacke_sggev3_work.c @@ -0,0 +1,163 @@ +/***************************************************************************** + Copyright (c) 2015, 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 sggev3 +* Author: Intel Corporation +* Generated February, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_sggev3_work( int matrix_layout, + char jobvl, char jobvr, lapack_int n, + float* a, lapack_int lda, + float* b, lapack_int ldb, + float* alphar, float* alphai, float* beta, + float* vl, lapack_int ldvl, + float* vr, lapack_int ldvr, + float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_sggev3( &jobvl, &jobvr, &n, a, &lda, b, &ldb, alphar, alphai, + beta, vl, &ldvl, vr, &ldvr, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int nrows_vl = LAPACKE_lsame( jobvl, 'v' ) ? n : 1; + lapack_int ncols_vl = LAPACKE_lsame( jobvl, 'v' ) ? n : 1; + lapack_int nrows_vr = LAPACKE_lsame( jobvr, 'v' ) ? n : 1; + lapack_int ncols_vr = LAPACKE_lsame( jobvr, 'v' ) ? n : 1; + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_int ldvl_t = MAX(1,nrows_vl); + lapack_int ldvr_t = MAX(1,nrows_vr); + float* a_t = NULL; + float* b_t = NULL; + float* vl_t = NULL; + float* vr_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_sggev3_work", info ); + return info; + } + if( ldb < n ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_sggev3_work", info ); + return info; + } + if( ldvl < ncols_vl ) { + info = -13; + LAPACKE_xerbla( "LAPACKE_sggev3_work", info ); + return info; + } + if( ldvr < ncols_vr ) { + info = -15; + LAPACKE_xerbla( "LAPACKE_sggev3_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_sggev3( &jobvl, &jobvr, &n, a, &lda_t, b, &ldb_t, + alphar, alphai, beta, vl, &ldvl_t, vr, &ldvr_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,n) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + if( LAPACKE_lsame( jobvl, 'v' ) ) { + vl_t = (float*) + LAPACKE_malloc( sizeof(float) * ldvl_t * MAX(1,ncols_vl) ); + if( vl_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_2; + } + } + if( LAPACKE_lsame( jobvr, 'v' ) ) { + vr_t = (float*) + LAPACKE_malloc( sizeof(float) * ldvr_t * MAX(1,ncols_vr) ); + if( vr_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_3; + } + } + /* Transpose input matrices */ + LAPACKE_sge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + LAPACKE_sge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_sggev3( &jobvl, &jobvr, &n, a_t, &lda_t, b_t, &ldb_t, alphar, + alphai, beta, vl_t, &ldvl_t, vr_t, &ldvr_t, + work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, n, b_t, ldb_t, b, ldb ); + if( LAPACKE_lsame( jobvl, 'v' ) ) { + LAPACKE_sge_trans( LAPACK_COL_MAJOR, nrows_vl, ncols_vl, vl_t, + ldvl_t, vl, ldvl ); + } + if( LAPACKE_lsame( jobvr, 'v' ) ) { + LAPACKE_sge_trans( LAPACK_COL_MAJOR, nrows_vr, ncols_vr, vr_t, + ldvr_t, vr, ldvr ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobvr, 'v' ) ) { + LAPACKE_free( vr_t ); + } +exit_level_3: + if( LAPACKE_lsame( jobvl, 'v' ) ) { + LAPACKE_free( vl_t ); + } +exit_level_2: + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_sggev3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_sggev3_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_sgghd3.c b/LAPACKE/src/lapacke_sgghd3.c new file mode 100644 index 0000000..00a967c --- /dev/null +++ b/LAPACKE/src/lapacke_sgghd3.c @@ -0,0 +1,92 @@ +/***************************************************************************** + Copyright (c) 2015, 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 sgghd3 +* Author: Intel Corporation +* Generated January, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_sgghd3( int matrix_layout, char compq, char compz, + lapack_int n, lapack_int ilo, lapack_int ihi, + float* a, lapack_int lda, float* b, lapack_int ldb, + float* q, lapack_int ldq, float* z, lapack_int ldz ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_sgghd3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_sge_nancheck( matrix_layout, n, n, a, lda ) ) { + return -7; + } + if( LAPACKE_sge_nancheck( matrix_layout, n, n, b, ldb ) ) { + return -9; + } + if( LAPACKE_lsame( compq, 'i' ) || LAPACKE_lsame( compq, 'v' ) ) { + if( LAPACKE_sge_nancheck( matrix_layout, n, n, q, ldq ) ) { + return -11; + } + } + if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + if( LAPACKE_sge_nancheck( matrix_layout, n, n, z, ldz ) ) { + return -13; + } + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_sgghd3_work( matrix_layout, compq, compz, n, ilo, ihi, + a, lda, b, ldb, q, ldq, z, ldz, &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_sgghd3_work( matrix_layout, compq, compz, n, ilo, ihi, + a, lda, b, ldb, q, ldq, z, ldz, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_sgghd3", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_sgghd3_work.c b/LAPACKE/src/lapacke_sgghd3_work.c new file mode 100644 index 0000000..46de096 --- /dev/null +++ b/LAPACKE/src/lapacke_sgghd3_work.c @@ -0,0 +1,157 @@ +/***************************************************************************** + Copyright (c) 2015, 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 sgghd3 +* Author: Intel Corporation +* Generated January, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_sgghd3_work( int matrix_layout, char compq, char compz, + lapack_int n, lapack_int ilo, lapack_int ihi, + float* a, lapack_int lda, float* b, + lapack_int ldb, float* q, lapack_int ldq, + float* z, lapack_int ldz, float* work, + lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_sgghd3( &compq, &compz, &n, &ilo, &ihi, a, &lda, b, &ldb, q, + &ldq, z, &ldz, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_int ldq_t = MAX(1,n); + lapack_int ldz_t = MAX(1,n); + float* a_t = NULL; + float* b_t = NULL; + float* q_t = NULL; + float* z_t = NULL; + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_sgghd3( &compq, &compz, &n, &ilo, &ihi, a, &lda, b, &ldb, q, + &ldq, z, &ldz, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Check leading dimension(s) */ + if( lda < n ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_sgghd3_work", info ); + return info; + } + if( ldb < n ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_sgghd3_work", info ); + return info; + } + if( ldq < n ) { + info = -12; + LAPACKE_xerbla( "LAPACKE_sgghd3_work", info ); + return info; + } + if( ldz < n ) { + info = -14; + LAPACKE_xerbla( "LAPACKE_sgghd3_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 = (float*)LAPACKE_malloc( sizeof(float) * ldb_t * MAX(1,n) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + if( LAPACKE_lsame( compq, 'i' ) || LAPACKE_lsame( compq, 'v' ) ) { + q_t = (float*)LAPACKE_malloc( sizeof(float) * ldq_t * MAX(1,n) ); + if( q_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_2; + } + } + if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + z_t = (float*)LAPACKE_malloc( sizeof(float) * ldz_t * MAX(1,n) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_3; + } + } + /* Transpose input matrices */ + LAPACKE_sge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + LAPACKE_sge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + if( LAPACKE_lsame( compq, 'v' ) ) { + LAPACKE_sge_trans( matrix_layout, n, n, q, ldq, q_t, ldq_t ); + } + if( LAPACKE_lsame( compz, 'v' ) ) { + LAPACKE_sge_trans( matrix_layout, n, n, z, ldz, z_t, ldz_t ); + } + /* Call LAPACK function and adjust info */ + LAPACK_sgghd3( &compq, &compz, &n, &ilo, &ihi, a_t, &lda_t, b_t, &ldb_t, + q_t, &ldq_t, z_t, &ldz_t, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, n, b_t, ldb_t, b, ldb ); + if( LAPACKE_lsame( compq, 'i' ) || LAPACKE_lsame( compq, 'v' ) ) { + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, n, q_t, ldq_t, q, ldq ); + } + if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + LAPACKE_sge_trans( LAPACK_COL_MAJOR, n, n, z_t, ldz_t, z, ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + LAPACKE_free( z_t ); + } + exit_level_3: + if( LAPACKE_lsame( compq, 'i' ) || LAPACKE_lsame( compq, 'v' ) ) { + LAPACKE_free( q_t ); + } + exit_level_2: + LAPACKE_free( b_t ); + exit_level_1: + LAPACKE_free( a_t ); + exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_sgghd3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_sgghd3_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_zgges3.c b/LAPACKE/src/lapacke_zgges3.c new file mode 100644 index 0000000..fc9813c --- /dev/null +++ b/LAPACKE/src/lapacke_zgges3.c @@ -0,0 +1,110 @@ +/***************************************************************************** + Copyright (c) 2015, 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 zgges3 +* Author: Intel Corporation +* Generated February, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zgges3( int matrix_layout, char jobvsl, char jobvsr, + char sort, LAPACK_Z_SELECT2 selctg, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* b, lapack_int ldb, + lapack_int* sdim, lapack_complex_double* alpha, + lapack_complex_double* beta, + lapack_complex_double* vsl, lapack_int ldvsl, + lapack_complex_double* vsr, lapack_int ldvsr ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_logical* bwork = NULL; + double* rwork = NULL; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zgges3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zge_nancheck( matrix_layout, n, n, a, lda ) ) { + return -7; + } + if( LAPACKE_zge_nancheck( matrix_layout, n, n, b, ldb ) ) { + return -9; + } +#endif + /* Allocate memory for working array(s) */ + if( LAPACKE_lsame( sort, 's' ) ) { + bwork = (lapack_logical*) + LAPACKE_malloc( sizeof(lapack_logical) * MAX(1,n) ); + if( bwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + } + rwork = (double*)LAPACKE_malloc( sizeof(double) * MAX(1,8*n) ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Query optimal working array(s) size */ + info = LAPACKE_zgges3_work( matrix_layout, jobvsl, jobvsr, sort, selctg, n, + a, lda, b, ldb, sdim, alpha, beta, vsl, ldvsl, + vsr, ldvsr, &work_query, lwork, rwork, bwork ); + if( info != 0 ) { + goto exit_level_2; + } + 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_2; + } + /* Call middle-level interface */ + info = LAPACKE_zgges3_work( matrix_layout, jobvsl, jobvsr, sort, selctg, n, + a, lda, b, ldb, sdim, alpha, beta, vsl, ldvsl, + vsr, ldvsr, work, lwork, rwork, bwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_2: + LAPACKE_free( rwork ); +exit_level_1: + if( LAPACKE_lsame( sort, 's' ) ) { + LAPACKE_free( bwork ); + } +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zgges3", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_zgges3_work.c b/LAPACKE/src/lapacke_zgges3_work.c new file mode 100644 index 0000000..5a8e024 --- /dev/null +++ b/LAPACKE/src/lapacke_zgges3_work.c @@ -0,0 +1,167 @@ +/***************************************************************************** + Copyright (c) 2015, 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 zgges3 +* Author: Intel Corporation +* Generated February, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zgges3_work( int matrix_layout, char jobvsl, char jobvsr, + char sort, LAPACK_Z_SELECT2 selctg, + lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* b, lapack_int ldb, + lapack_int* sdim, lapack_complex_double* alpha, + lapack_complex_double* beta, + lapack_complex_double* vsl, lapack_int ldvsl, + lapack_complex_double* vsr, lapack_int ldvsr, + lapack_complex_double* work, lapack_int lwork, + double* rwork, lapack_logical* bwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zgges3( &jobvsl, &jobvsr, &sort, selctg, &n, a, &lda, b, &ldb, + sdim, alpha, beta, vsl, &ldvsl, vsr, &ldvsr, + work, &lwork, rwork, bwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_int ldvsl_t = MAX(1,n); + lapack_int ldvsr_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + lapack_complex_double* b_t = NULL; + lapack_complex_double* vsl_t = NULL; + lapack_complex_double* vsr_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_zgges3_work", info ); + return info; + } + if( ldb < n ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_zgges3_work", info ); + return info; + } + if( ldvsl < n ) { + info = -15; + LAPACKE_xerbla( "LAPACKE_zgges3_work", info ); + return info; + } + if( ldvsr < n ) { + info = -17; + LAPACKE_xerbla( "LAPACKE_zgges3_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_zgges3( &jobvsl, &jobvsr, &sort, selctg, &n, a, &lda_t, b, + &ldb_t, sdim, alpha, beta, vsl, &ldvsl_t, vsr, + &ldvsr_t, work, &lwork, rwork, bwork, &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,n) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + if( LAPACKE_lsame( jobvsl, 'v' ) ) { + vsl_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * + ldvsl_t * MAX(1,n) ); + if( vsl_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_2; + } + } + if( LAPACKE_lsame( jobvsr, 'v' ) ) { + vsr_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * + ldvsr_t * MAX(1,n) ); + if( vsr_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_3; + } + } + /* Transpose input matrices */ + LAPACKE_zge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + LAPACKE_zge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zgges3( &jobvsl, &jobvsr, &sort, selctg, &n, a_t, &lda_t, b_t, + &ldb_t, sdim, alpha, beta, vsl_t, &ldvsl_t, vsr_t, + &ldvsr_t, work, &lwork, rwork, bwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, n, b_t, ldb_t, b, ldb ); + if( LAPACKE_lsame( jobvsl, 'v' ) ) { + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, n, vsl_t, ldvsl_t, vsl, + ldvsl ); + } + if( LAPACKE_lsame( jobvsr, 'v' ) ) { + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, n, vsr_t, ldvsr_t, vsr, + ldvsr ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobvsr, 'v' ) ) { + LAPACKE_free( vsr_t ); + } +exit_level_3: + if( LAPACKE_lsame( jobvsl, 'v' ) ) { + LAPACKE_free( vsl_t ); + } +exit_level_2: + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zgges3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zgges3_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_zggev3.c b/LAPACKE/src/lapacke_zggev3.c new file mode 100644 index 0000000..bfac8fe --- /dev/null +++ b/LAPACKE/src/lapacke_zggev3.c @@ -0,0 +1,97 @@ +/***************************************************************************** + Copyright (c) 2015, 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 zggev3 +* Author: Intel Corporation +* Generated February, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zggev3( int matrix_layout, + char jobvl, char jobvr, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* alpha, + lapack_complex_double* beta, + lapack_complex_double* vl, lapack_int ldvl, + lapack_complex_double* vr, lapack_int ldvr ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* rwork = NULL; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zggev3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zge_nancheck( matrix_layout, n, n, a, lda ) ) { + return -5; + } + if( LAPACKE_zge_nancheck( matrix_layout, n, n, b, ldb ) ) { + return -7; + } +#endif + /* Allocate memory for working array(s) */ + rwork = (double*)LAPACKE_malloc( sizeof(double) * MAX(1,8*n) ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Query optimal working array(s) size */ + info = LAPACKE_zggev3_work( matrix_layout, jobvl, jobvr, n, a, lda, b, ldb, + alpha, beta, vl, ldvl, vr, ldvr, &work_query, + lwork, rwork ); + if( info != 0 ) { + goto exit_level_1; + } + 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_1; + } + /* Call middle-level interface */ + info = LAPACKE_zggev3_work( matrix_layout, jobvl, jobvr, n, a, lda, b, ldb, + alpha, beta, vl, ldvl, vr, ldvr, work, lwork, + rwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( rwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zggev3", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_zggev3_work.c b/LAPACKE/src/lapacke_zggev3_work.c new file mode 100644 index 0000000..e2ac2f0 --- /dev/null +++ b/LAPACKE/src/lapacke_zggev3_work.c @@ -0,0 +1,169 @@ +/***************************************************************************** + Copyright (c) 2015, 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 zggev3 +* Author: Intel Corporation +* Generated February, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zggev3_work( int matrix_layout, + char jobvl, char jobvr, lapack_int n, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* alpha, + lapack_complex_double* beta, + lapack_complex_double* vl, lapack_int ldvl, + lapack_complex_double* vr, lapack_int ldvr, + lapack_complex_double* work, lapack_int lwork, + double* rwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zggev3( &jobvl, &jobvr, &n, a, &lda, b, &ldb, alpha, beta, vl, + &ldvl, vr, &ldvr, work, &lwork, rwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int nrows_vl = LAPACKE_lsame( jobvl, 'v' ) ? n : 1; + lapack_int ncols_vl = LAPACKE_lsame( jobvl, 'v' ) ? n : 1; + lapack_int nrows_vr = LAPACKE_lsame( jobvr, 'v' ) ? n : 1; + lapack_int ncols_vr = LAPACKE_lsame( jobvr, 'v' ) ? n : 1; + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_int ldvl_t = MAX(1,nrows_vl); + lapack_int ldvr_t = MAX(1,nrows_vr); + lapack_complex_double* a_t = NULL; + lapack_complex_double* b_t = NULL; + lapack_complex_double* vl_t = NULL; + lapack_complex_double* vr_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + LAPACKE_xerbla( "LAPACKE_zggev3_work", info ); + return info; + } + if( ldb < n ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_zggev3_work", info ); + return info; + } + if( ldvl < ncols_vl ) { + info = -12; + LAPACKE_xerbla( "LAPACKE_zggev3_work", info ); + return info; + } + if( ldvr < ncols_vr ) { + info = -14; + LAPACKE_xerbla( "LAPACKE_zggev3_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_zggev3( &jobvl, &jobvr, &n, a, &lda_t, b, &ldb_t, + alpha, beta, vl, &ldvl_t, vr, &ldvr_t, + work, &lwork, rwork, &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,n) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + if( LAPACKE_lsame( jobvl, 'v' ) ) { + vl_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * + ldvl_t * MAX(1,ncols_vl) ); + if( vl_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_2; + } + } + if( LAPACKE_lsame( jobvr, 'v' ) ) { + vr_t = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * + ldvr_t * MAX(1,ncols_vr) ); + if( vr_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_3; + } + } + /* Transpose input matrices */ + LAPACKE_zge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + LAPACKE_zge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_zggev3( &jobvl, &jobvr, &n, a_t, &lda_t, b_t, &ldb_t, + alpha, beta, vl_t, &ldvl_t, vr_t, &ldvr_t, + work, &lwork, rwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, n, b_t, ldb_t, b, ldb ); + if( LAPACKE_lsame( jobvl, 'v' ) ) { + LAPACKE_zge_trans( LAPACK_COL_MAJOR, nrows_vl, ncols_vl, vl_t, + ldvl_t, vl, ldvl ); + } + if( LAPACKE_lsame( jobvr, 'v' ) ) { + LAPACKE_zge_trans( LAPACK_COL_MAJOR, nrows_vr, ncols_vr, vr_t, + ldvr_t, vr, ldvr ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( jobvr, 'v' ) ) { + LAPACKE_free( vr_t ); + } +exit_level_3: + if( LAPACKE_lsame( jobvl, 'v' ) ) { + LAPACKE_free( vl_t ); + } +exit_level_2: + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zggev3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zggev3_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_zgghd3.c b/LAPACKE/src/lapacke_zgghd3.c new file mode 100644 index 0000000..03becb8 --- /dev/null +++ b/LAPACKE/src/lapacke_zgghd3.c @@ -0,0 +1,97 @@ +/***************************************************************************** + Copyright (c) 2015, 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 zgghd3 +* Author: Intel Corporation +* Generated January, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zgghd3( int matrix_layout, char compq, char compz, + lapack_int n, lapack_int ilo, lapack_int ihi, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* q, lapack_int ldq, + lapack_complex_double* z, lapack_int ldz ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_complex_double* work = NULL; + lapack_complex_double work_query; + + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zgghd3", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zge_nancheck( matrix_layout, n, n, a, lda ) ) { + return -7; + } + if( LAPACKE_zge_nancheck( matrix_layout, n, n, b, ldb ) ) { + return -9; + } + if( LAPACKE_lsame( compq, 'i' ) || LAPACKE_lsame( compq, 'v' ) ) { + if( LAPACKE_zge_nancheck( matrix_layout, n, n, q, ldq ) ) { + return -11; + } + } + if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + if( LAPACKE_zge_nancheck( matrix_layout, n, n, z, ldz ) ) { + return -13; + } + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zgghd3_work( matrix_layout, compq, compz, n, ilo, ihi, + a, lda, b, ldb, q, ldq, z, ldz, &work_query, + lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_C2INT( 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_zgghd3_work( matrix_layout, compq, compz, n, ilo, ihi, + a, lda, b, ldb, q, ldq, z, ldz, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zgghd3", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_zgghd3_work.c b/LAPACKE/src/lapacke_zgghd3_work.c new file mode 100644 index 0000000..ec649dc --- /dev/null +++ b/LAPACKE/src/lapacke_zgghd3_work.c @@ -0,0 +1,159 @@ +/***************************************************************************** + Copyright (c) 2015, 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 zgghd3 +* Author: Intel Corporation +* Generated January, 2015 +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zgghd3_work( int matrix_layout, char compq, char compz, + lapack_int n, lapack_int ilo, lapack_int ihi, + lapack_complex_double* a, lapack_int lda, + lapack_complex_double* b, lapack_int ldb, + lapack_complex_double* q, lapack_int ldq, + lapack_complex_double* z, lapack_int ldz, + lapack_complex_double* work, + lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zgghd3( &compq, &compz, &n, &ilo, &ihi, a, &lda, b, &ldb, q, + &ldq, z, &ldz, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + lapack_int ldq_t = MAX(1,n); + lapack_int ldz_t = MAX(1,n); + lapack_complex_double* a_t = NULL; + lapack_complex_double* b_t = NULL; + lapack_complex_double* q_t = NULL; + lapack_complex_double* z_t = NULL; + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_zgghd3( &compq, &compz, &n, &ilo, &ihi, a, &lda, b, &ldb, q, + &ldq, z, &ldz, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Check leading dimension(s) */ + if( lda < n ) { + info = -8; + LAPACKE_xerbla( "LAPACKE_zgghd3_work", info ); + return info; + } + if( ldb < n ) { + info = -10; + LAPACKE_xerbla( "LAPACKE_zgghd3_work", info ); + return info; + } + if( ldq < n ) { + info = -12; + LAPACKE_xerbla( "LAPACKE_zgghd3_work", info ); + return info; + } + if( ldz < n ) { + info = -14; + LAPACKE_xerbla( "LAPACKE_zgghd3_work", info ); + return 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,n) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + if( LAPACKE_lsame( compq, 'i' ) || LAPACKE_lsame( compq, 'v' ) ) { + q_t = (lapack_complex_double*)LAPACKE_malloc( sizeof(lapack_complex_double) * ldq_t * MAX(1,n) ); + if( q_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_2; + } + } + if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + z_t = (lapack_complex_double*)LAPACKE_malloc( sizeof(lapack_complex_double) * ldz_t * MAX(1,n) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_3; + } + } + /* Transpose input matrices */ + LAPACKE_zge_trans( matrix_layout, n, n, a, lda, a_t, lda_t ); + LAPACKE_zge_trans( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + if( LAPACKE_lsame( compq, 'v' ) ) { + LAPACKE_zge_trans( matrix_layout, n, n, q, ldq, q_t, ldq_t ); + } + if( LAPACKE_lsame( compz, 'v' ) ) { + LAPACKE_zge_trans( matrix_layout, n, n, z, ldz, z_t, ldz_t ); + } + /* Call LAPACK function and adjust info */ + LAPACK_zgghd3( &compq, &compz, &n, &ilo, &ihi, a_t, &lda_t, b_t, &ldb_t, + q_t, &ldq_t, z_t, &ldz_t, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, n, b_t, ldb_t, b, ldb ); + if( LAPACKE_lsame( compq, 'i' ) || LAPACKE_lsame( compq, 'v' ) ) { + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, n, q_t, ldq_t, q, ldq ); + } + if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + LAPACKE_zge_trans( LAPACK_COL_MAJOR, n, n, z_t, ldz_t, z, ldz ); + } + /* Release memory and exit */ + if( LAPACKE_lsame( compz, 'i' ) || LAPACKE_lsame( compz, 'v' ) ) { + LAPACKE_free( z_t ); + } + exit_level_3: + if( LAPACKE_lsame( compq, 'i' ) || LAPACKE_lsame( compq, 'v' ) ) { + LAPACKE_free( q_t ); + } + exit_level_2: + LAPACKE_free( b_t ); + exit_level_1: + LAPACKE_free( a_t ); + exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zgghd3_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zgghd3_work", info ); + } + return info; +} diff --git a/SRC/CMakeLists.txt b/SRC/CMakeLists.txt index d618d6e..8ea4f5f 100644 --- a/SRC/CMakeLists.txt +++ b/SRC/CMakeLists.txt @@ -98,8 +98,9 @@ set(SLASRC sgeqp3.f sgeqpf.f sgeqr2.f sgeqr2p.f sgeqrf.f sgeqrfp.f sgerfs.f sgerq2.f sgerqf.f sgesc2.f sgesdd.f sgesv.f sgesvd.f sgesvx.f sgetc2.f sgetf2.f sgetrf.f sgetri.f - sgetrs.f sggbak.f sggbal.f sgges.f sggesx.f sggev.f sggevx.f - sggglm.f sgghrd.f sgglse.f sggqrf.f + sgetrs.f sggbak.f sggbal.f + sgges.f sgges3.f sggesx.f sggev.f sggev3.f sggevx.f + sggglm.f sgghrd.f sgghd3.f sgglse.f sggqrf.f sggrqf.f sggsvd.f sggsvp.f sgtcon.f sgtrfs.f sgtsv.f sgtsvx.f sgttrf.f sgttrs.f sgtts2.f shgeqz.f shsein.f shseqr.f slabrd.f slacon.f slacn2.f @@ -117,7 +118,7 @@ set(SLASRC 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 - sorgrq.f sorgtr.f sorm2l.f sorm2r.f + sorgrq.f sorgtr.f sorm2l.f sorm2r.f sorm22.f sormbr.f sormhr.f sorml2.f sormlq.f sormql.f sormqr.f sormr2.f sormr3.f sormrq.f sormrz.f sormtr.f spbcon.f spbequ.f spbrfs.f spbstf.f spbsv.f spbsvx.f @@ -171,8 +172,9 @@ set(CLASRC cgeqpf.f cgeqr2.f cgeqr2p.f cgeqrf.f cgeqrfp.f cgerfs.f cgerq2.f cgerqf.f cgesc2.f cgesdd.f cgesv.f cgesvd.f cgesvx.f cgetc2.f cgetf2.f cgetrf.f cgetri.f cgetrs.f - cggbak.f cggbal.f cgges.f cggesx.f cggev.f cggevx.f cggglm.f - cgghrd.f cgglse.f cggqrf.f cggrqf.f + cggbak.f cggbal.f + cgges.f cgges3.f cggesx.f cggev.f cggev3.f cggevx.f + cggglm.f cgghrd.f cgghd3.f cgglse.f cggqrf.f cggrqf.f cggsvd.f cggsvp.f cgtcon.f cgtrfs.f cgtsv.f cgtsvx.f cgttrf.f cgttrs.f cgtts2.f chbev.f chbevd.f chbevx.f chbgst.f chbgv.f chbgvd.f chbgvx.f chbtrd.f @@ -220,7 +222,7 @@ set(CLASRC ctptrs.f ctrcon.f ctrevc.f ctrexc.f ctrrfs.f ctrsen.f ctrsna.f ctrsyl.f ctrti2.f ctrtri.f ctrtrs.f ctzrqf.f ctzrzf.f cung2l.f cung2r.f cungbr.f cunghr.f cungl2.f cunglq.f cungql.f cungqr.f cungr2.f - cungrq.f cungtr.f cunm2l.f cunm2r.f cunmbr.f cunmhr.f cunml2.f + cungrq.f cungtr.f cunm2l.f cunm2r.f cunmbr.f cunmhr.f cunml2.f cunm22.f cunmlq.f cunmql.f cunmqr.f cunmr2.f cunmr3.f cunmrq.f cunmrz.f cunmtr.f cupgtr.f cupmtr.f icmax1.f scsum1.f cstemr.f chfrk.f ctfttp.f clanhf.f cpftrf.f cpftri.f cpftrs.f ctfsm.f ctftri.f @@ -254,8 +256,9 @@ set(DLASRC dgeqp3.f dgeqpf.f dgeqr2.f dgeqr2p.f dgeqrf.f dgeqrfp.f dgerfs.f dgerq2.f dgerqf.f dgesc2.f dgesdd.f dgesv.f dgesvd.f dgesvx.f dgetc2.f dgetf2.f dgetrf.f dgetri.f - dgetrs.f dggbak.f dggbal.f dgges.f dggesx.f dggev.f dggevx.f - dggglm.f dgghrd.f dgglse.f dggqrf.f + dgetrs.f dggbak.f dggbal.f + dgges.f dgges3.f dggesx.f dggev.f dggev3.f dggevx.f + dggglm.f dgghrd.f dgghd3.f dgglse.f dggqrf.f dggrqf.f dggsvd.f dggsvp.f dgtcon.f dgtrfs.f dgtsv.f dgtsvx.f dgttrf.f dgttrs.f dgtts2.f dhgeqz.f dhsein.f dhseqr.f dlabrd.f dlacon.f dlacn2.f @@ -273,7 +276,7 @@ set(DLASRC 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 - dorgrq.f dorgtr.f dorm2l.f dorm2r.f + dorgrq.f dorgtr.f dorm2l.f dorm2r.f dorm22.f dormbr.f dormhr.f dorml2.f dormlq.f dormql.f dormqr.f dormr2.f dormr3.f dormrq.f dormrz.f dormtr.f dpbcon.f dpbequ.f dpbrfs.f dpbstf.f dpbsv.f dpbsvx.f @@ -326,8 +329,9 @@ set(ZLASRC zgeqpf.f zgeqr2.f zgeqr2p.f zgeqrf.f zgeqrfp.f zgerfs.f zgerq2.f zgerqf.f zgesc2.f zgesdd.f zgesv.f zgesvd.f zgesvx.f zgetc2.f zgetf2.f zgetrf.f zgetri.f zgetrs.f - zggbak.f zggbal.f zgges.f zggesx.f zggev.f zggevx.f zggglm.f - zgghrd.f zgglse.f zggqrf.f zggrqf.f + zggbak.f zggbal.f + zgges.f zgges3.f zggesx.f zggev.f zggev3.f zggevx.f + zggglm.f zgghrd.f zgghd3.f zgglse.f zggqrf.f zggrqf.f zggsvd.f zggsvp.f zgtcon.f zgtrfs.f zgtsv.f zgtsvx.f zgttrf.f zgttrs.f zgtts2.f zhbev.f zhbevd.f zhbevx.f zhbgst.f zhbgv.f zhbgvd.f zhbgvx.f zhbtrd.f @@ -378,7 +382,7 @@ set(ZLASRC ztptrs.f ztrcon.f ztrevc.f ztrexc.f ztrrfs.f ztrsen.f ztrsna.f ztrsyl.f ztrti2.f ztrtri.f ztrtrs.f ztzrqf.f ztzrzf.f zung2l.f zung2r.f zungbr.f zunghr.f zungl2.f zunglq.f zungql.f zungqr.f zungr2.f - zungrq.f zungtr.f zunm2l.f zunm2r.f zunmbr.f zunmhr.f zunml2.f + zungrq.f zungtr.f zunm2l.f zunm2r.f zunmbr.f zunmhr.f zunml2.f zunm22.f zunmlq.f zunmql.f zunmqr.f zunmr2.f zunmr3.f zunmrq.f zunmrz.f zunmtr.f zupgtr.f zupmtr.f izmax1.f dzsum1.f zstemr.f diff --git a/SRC/Makefile b/SRC/Makefile index f3eaa53..30946da 100644 --- a/SRC/Makefile +++ b/SRC/Makefile @@ -103,8 +103,9 @@ SLASRC = \ sgeqp3.o sgeqpf.o sgeqr2.o sgeqr2p.o sgeqrf.o sgeqrfp.o sgerfs.o \ sgerq2.o sgerqf.o sgesc2.o sgesdd.o sgesv.o sgesvd.o sgesvx.o \ sgetc2.o sgetf2.o sgetri.o \ - sggbak.o sggbal.o sgges.o sggesx.o sggev.o sggevx.o \ - sggglm.o sgghrd.o sgglse.o sggqrf.o \ + sggbak.o sggbal.o sgges.o sgges3.o sggesx.o \ + sggev.o sggev3.o sggevx.o \ + sggglm.o sgghrd.o sgghd3.o sgglse.o sggqrf.o \ sggrqf.o sggsvd.o sggsvp.o sgtcon.o sgtrfs.o sgtsv.o \ sgtsvx.o sgttrf.o sgttrs.o sgtts2.o shgeqz.o \ shsein.o shseqr.o slabrd.o slacon.o slacn2.o \ @@ -122,7 +123,7 @@ SLASRC = \ slatbs.o slatdf.o slatps.o slatrd.o slatrs.o slatrz.o slatzm.o \ slauu2.o slauum.o sopgtr.o sopmtr.o sorg2l.o sorg2r.o \ sorgbr.o sorghr.o sorgl2.o sorglq.o sorgql.o sorgqr.o sorgr2.o \ - sorgrq.o sorgtr.o sorm2l.o sorm2r.o \ + sorgrq.o sorgtr.o sorm2l.o sorm2r.o sorm22.o \ sormbr.o sormhr.o sorml2.o sormlq.o sormql.o sormqr.o sormr2.o \ sormr3.o sormrq.o sormrz.o sormtr.o spbcon.o spbequ.o spbrfs.o \ spbstf.o spbsv.o spbsvx.o \ @@ -178,8 +179,9 @@ CLASRC = \ cgeqpf.o cgeqr2.o cgeqr2p.o cgeqrf.o cgeqrfp.o cgerfs.o \ cgerq2.o cgerqf.o cgesc2.o cgesdd.o cgesv.o cgesvd.o \ cgesvx.o cgetc2.o cgetf2.o cgetri.o \ - cggbak.o cggbal.o cgges.o cggesx.o cggev.o cggevx.o cggglm.o \ - cgghrd.o cgglse.o cggqrf.o cggrqf.o \ + cggbak.o cggbal.o cgges.o cgges3.o cggesx.o \ + cggev.o cggev3.o cggevx.o \ + cgghrd.o cgghd3.o cgglse.o cggqrf.o cggrqf.o \ cggsvd.o cggsvp.o \ cgtcon.o cgtrfs.o cgtsv.o cgtsvx.o cgttrf.o cgttrs.o cgtts2.o chbev.o \ chbevd.o chbevx.o chbgst.o chbgv.o chbgvd.o chbgvx.o chbtrd.o \ @@ -227,7 +229,7 @@ CLASRC = \ ctptrs.o ctrcon.o ctrevc.o ctrexc.o ctrrfs.o ctrsen.o ctrsna.o \ ctrsyl.o ctrti2.o ctrtri.o ctrtrs.o ctzrqf.o ctzrzf.o cung2l.o cung2r.o \ cungbr.o cunghr.o cungl2.o cunglq.o cungql.o cungqr.o cungr2.o \ - cungrq.o cungtr.o cunm2l.o cunm2r.o cunmbr.o cunmhr.o cunml2.o \ + cungrq.o cungtr.o cunm2l.o cunm2r.o cunmbr.o cunmhr.o cunml2.o cunm22.o \ cunmlq.o cunmql.o cunmqr.o cunmr2.o cunmr3.o cunmrq.o cunmrz.o \ cunmtr.o cupgtr.o cupmtr.o icmax1.o scsum1.o cstemr.o \ chfrk.o ctfttp.o clanhf.o cpftrf.o cpftri.o cpftrs.o ctfsm.o ctftri.o \ @@ -263,8 +265,9 @@ DLASRC = \ dgeqp3.o dgeqpf.o dgeqr2.o dgeqr2p.o dgeqrf.o dgeqrfp.o dgerfs.o \ dgerq2.o dgerqf.o dgesc2.o dgesdd.o dgesv.o dgesvd.o dgesvx.o \ dgetc2.o dgetf2.o dgetrf.o dgetri.o \ - dgetrs.o dggbak.o dggbal.o dgges.o dggesx.o dggev.o dggevx.o \ - dggglm.o dgghrd.o dgglse.o dggqrf.o \ + dgetrs.o dggbak.o dggbal.o dgges.o dgges3.o dggesx.o \ + dggev.o dggev3.o dggevx.o \ + dggglm.o dgghrd.o dgghd3.o dgglse.o dggqrf.o \ dggrqf.o dggsvd.o dggsvp.o dgtcon.o dgtrfs.o dgtsv.o \ dgtsvx.o dgttrf.o dgttrs.o dgtts2.o dhgeqz.o \ dhsein.o dhseqr.o dlabrd.o dlacon.o dlacn2.o \ @@ -282,7 +285,7 @@ DLASRC = \ dlatbs.o dlatdf.o dlatps.o dlatrd.o dlatrs.o dlatrz.o dlatzm.o dlauu2.o \ dlauum.o dopgtr.o dopmtr.o dorg2l.o dorg2r.o \ dorgbr.o dorghr.o dorgl2.o dorglq.o dorgql.o dorgqr.o dorgr2.o \ - dorgrq.o dorgtr.o dorm2l.o dorm2r.o \ + dorgrq.o dorgtr.o dorm2l.o dorm2r.o dorm22.o \ dormbr.o dormhr.o dorml2.o dormlq.o dormql.o dormqr.o dormr2.o \ dormr3.o dormrq.o dormrz.o dormtr.o dpbcon.o dpbequ.o dpbrfs.o \ dpbstf.o dpbsv.o dpbsvx.o \ @@ -337,8 +340,9 @@ ZLASRC = \ zgeqpf.o zgeqr2.o zgeqr2p.o zgeqrf.o zgeqrfp.o zgerfs.o zgerq2.o zgerqf.o \ zgesc2.o zgesdd.o zgesv.o zgesvd.o zgesvx.o zgetc2.o zgetf2.o zgetrf.o \ zgetri.o zgetrs.o \ - zggbak.o zggbal.o zgges.o zggesx.o zggev.o zggevx.o zggglm.o \ - zgghrd.o zgglse.o zggqrf.o zggrqf.o \ + zggbak.o zggbal.o zgges.o zgges3.o zggesx.o \ + zggev.o zggev3.o zggevx.o zggglm.o \ + zgghrd.o zgghd3.o zgglse.o zggqrf.o zggrqf.o \ zggsvd.o zggsvp.o \ zgtcon.o zgtrfs.o zgtsv.o zgtsvx.o zgttrf.o zgttrs.o zgtts2.o zhbev.o \ zhbevd.o zhbevx.o zhbgst.o zhbgv.o zhbgvd.o zhbgvx.o zhbtrd.o \ @@ -389,7 +393,7 @@ ZLASRC = \ ztptrs.o ztrcon.o ztrevc.o ztrexc.o ztrrfs.o ztrsen.o ztrsna.o \ ztrsyl.o ztrti2.o ztrtri.o ztrtrs.o ztzrqf.o ztzrzf.o zung2l.o \ zung2r.o zungbr.o zunghr.o zungl2.o zunglq.o zungql.o zungqr.o zungr2.o \ - zungrq.o zungtr.o zunm2l.o zunm2r.o zunmbr.o zunmhr.o zunml2.o \ + zungrq.o zungtr.o zunm2l.o zunm2r.o zunmbr.o zunmhr.o zunml2.o zunm22.o \ zunmlq.o zunmql.o zunmqr.o zunmr2.o zunmr3.o zunmrq.o zunmrz.o \ zunmtr.o zupgtr.o \ zupmtr.o izmax1.o dzsum1.o zstemr.o \ diff --git a/SRC/cgges3.f b/SRC/cgges3.f new file mode 100644 index 0000000..ab603de --- /dev/null +++ b/SRC/cgges3.f @@ -0,0 +1,597 @@ +*> \brief CGGES3 computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices (blocked algorithm) +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CGGES3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CGGES3( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, +* $ LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, +* $ WORK, LWORK, RWORK, BWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBVSL, JOBVSR, SORT +* INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM +* .. +* .. Array Arguments .. +* LOGICAL BWORK( * ) +* REAL RWORK( * ) +* COMPLEX A( LDA, * ), ALPHA( * ), B( LDB, * ), +* $ BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ), +* $ WORK( * ) +* .. +* .. Function Arguments .. +* LOGICAL SELCTG +* EXTERNAL SELCTG +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGGES3 computes for a pair of N-by-N complex nonsymmetric matrices +*> (A,B), the generalized eigenvalues, the generalized complex Schur +*> form (S, T), and optionally left and/or right Schur vectors (VSL +*> and VSR). This gives the generalized Schur factorization +*> +*> (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H ) +*> +*> where (VSR)**H is the conjugate-transpose of VSR. +*> +*> Optionally, it also orders the eigenvalues so that a selected cluster +*> of eigenvalues appears in the leading diagonal blocks of the upper +*> triangular matrix S and the upper triangular matrix T. The leading +*> columns of VSL and VSR then form an unitary basis for the +*> corresponding left and right eigenspaces (deflating subspaces). +*> +*> (If only the generalized eigenvalues are needed, use the driver +*> CGGEV instead, which is faster.) +*> +*> A generalized eigenvalue for a pair of matrices (A,B) is a scalar w +*> or a ratio alpha/beta = w, such that A - w*B is singular. It is +*> usually represented as the pair (alpha,beta), as there is a +*> reasonable interpretation for beta=0, and even for both being zero. +*> +*> A pair of matrices (S,T) is in generalized complex Schur form if S +*> and T are upper triangular and, in addition, the diagonal elements +*> of T are non-negative real numbers. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBVSL +*> \verbatim +*> JOBVSL is CHARACTER*1 +*> = 'N': do not compute the left Schur vectors; +*> = 'V': compute the left Schur vectors. +*> \endverbatim +*> +*> \param[in] JOBVSR +*> \verbatim +*> JOBVSR is CHARACTER*1 +*> = 'N': do not compute the right Schur vectors; +*> = 'V': compute the right Schur vectors. +*> \endverbatim +*> +*> \param[in] SORT +*> \verbatim +*> SORT is CHARACTER*1 +*> Specifies whether or not to order the eigenvalues on the +*> diagonal of the generalized Schur form. +*> = 'N': Eigenvalues are not ordered; +*> = 'S': Eigenvalues are ordered (see SELCTG). +*> \endverbatim +*> +*> \param[in] SELCTG +*> \verbatim +*> SELCTG is a LOGICAL FUNCTION of two COMPLEX arguments +*> SELCTG must be declared EXTERNAL in the calling subroutine. +*> If SORT = 'N', SELCTG is not referenced. +*> If SORT = 'S', SELCTG is used to select eigenvalues to sort +*> to the top left of the Schur form. +*> An eigenvalue ALPHA(j)/BETA(j) is selected if +*> SELCTG(ALPHA(j),BETA(j)) is true. +*> +*> Note that a selected complex eigenvalue may no longer satisfy +*> SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since +*> ordering may change the value of complex eigenvalues +*> (especially if the eigenvalue is ill-conditioned), in this +*> case INFO is set to N+2 (See INFO below). +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A, B, VSL, and VSR. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA, N) +*> On entry, the first of the pair of matrices. +*> On exit, A has been overwritten by its generalized Schur +*> form S. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension (LDB, N) +*> On entry, the second of the pair of matrices. +*> On exit, B has been overwritten by its generalized Schur +*> form T. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] SDIM +*> \verbatim +*> SDIM is INTEGER +*> If SORT = 'N', SDIM = 0. +*> If SORT = 'S', SDIM = number of eigenvalues (after sorting) +*> for which SELCTG is true. +*> \endverbatim +*> +*> \param[out] ALPHA +*> \verbatim +*> ALPHA is COMPLEX array, dimension (N) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is COMPLEX array, dimension (N) +*> On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the +*> generalized eigenvalues. ALPHA(j), j=1,...,N and BETA(j), +*> j=1,...,N are the diagonals of the complex Schur form (A,B) +*> output by CGGES3. The BETA(j) will be non-negative real. +*> +*> Note: the quotients ALPHA(j)/BETA(j) may easily over- or +*> underflow, and BETA(j) may even be zero. Thus, the user +*> should avoid naively computing the ratio alpha/beta. +*> However, ALPHA will be always less than and usually +*> comparable with norm(A) in magnitude, and BETA always less +*> than and usually comparable with norm(B). +*> \endverbatim +*> +*> \param[out] VSL +*> \verbatim +*> VSL is COMPLEX array, dimension (LDVSL,N) +*> If JOBVSL = 'V', VSL will contain the left Schur vectors. +*> Not referenced if JOBVSL = 'N'. +*> \endverbatim +*> +*> \param[in] LDVSL +*> \verbatim +*> LDVSL is INTEGER +*> The leading dimension of the matrix VSL. LDVSL >= 1, and +*> if JOBVSL = 'V', LDVSL >= N. +*> \endverbatim +*> +*> \param[out] VSR +*> \verbatim +*> VSR is COMPLEX array, dimension (LDVSR,N) +*> If JOBVSR = 'V', VSR will contain the right Schur vectors. +*> Not referenced if JOBVSR = 'N'. +*> \endverbatim +*> +*> \param[in] LDVSR +*> \verbatim +*> LDVSR is INTEGER +*> The leading dimension of the matrix VSR. LDVSR >= 1, and +*> if JOBVSR = 'V', LDVSR >= 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 dimension of the array WORK. +*> +*> 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 (8*N) +*> \endverbatim +*> +*> \param[out] BWORK +*> \verbatim +*> BWORK is LOGICAL array, dimension (N) +*> Not referenced if SORT = 'N'. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> =1,...,N: +*> The QZ iteration failed. (A,B) are not in Schur +*> form, but ALPHA(j) and BETA(j) should be correct for +*> j=INFO+1,...,N. +*> > N: =N+1: other than QZ iteration failed in CHGEQZ +*> =N+2: after reordering, roundoff changed values of +*> some complex eigenvalues so that leading +*> eigenvalues in the Generalized Schur form no +*> longer satisfy SELCTG=.TRUE. This could also +*> be caused due to scaling. +*> =N+3: reordering failed in CTGSEN. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date January 2015 +* +*> \ingroup complexGEeigen +* +* ===================================================================== + SUBROUTINE CGGES3( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, + $ LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, + $ WORK, LWORK, RWORK, BWORK, INFO ) +* +* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2015 +* +* .. Scalar Arguments .. + CHARACTER JOBVSL, JOBVSR, SORT + INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM +* .. +* .. Array Arguments .. + LOGICAL BWORK( * ) + REAL RWORK( * ) + COMPLEX A( LDA, * ), ALPHA( * ), B( LDB, * ), + $ BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ), + $ WORK( * ) +* .. +* .. Function Arguments .. + LOGICAL SELCTG + EXTERNAL SELCTG +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E0, 0.0E0 ), + $ CONE = ( 1.0E0, 0.0E0 ) ) +* .. +* .. Local Scalars .. + LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL, + $ LQUERY, WANTST + INTEGER I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, + $ ILO, IRIGHT, IROWS, IRWRK, ITAU, IWRK, LWKOPT + REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL, + $ PVSR, SMLNUM +* .. +* .. Local Arrays .. + INTEGER IDUM( 1 ) + REAL DIF( 2 ) +* .. +* .. External Subroutines .. + EXTERNAL CGEQRF, CGGBAK, CGGBAL, CGGHD3, CHGEQZ, CLACPY, + $ CLASCL, CLASET, CTGSEN, CUNGQR, CUNMQR, SLABAD, + $ XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + REAL CLANGE, SLAMCH + EXTERNAL LSAME, CLANGE, SLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Executable Statements .. +* +* Decode the input arguments +* + IF( LSAME( JOBVSL, 'N' ) ) THEN + IJOBVL = 1 + ILVSL = .FALSE. + ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN + IJOBVL = 2 + ILVSL = .TRUE. + ELSE + IJOBVL = -1 + ILVSL = .FALSE. + END IF +* + IF( LSAME( JOBVSR, 'N' ) ) THEN + IJOBVR = 1 + ILVSR = .FALSE. + ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN + IJOBVR = 2 + ILVSR = .TRUE. + ELSE + IJOBVR = -1 + ILVSR = .FALSE. + END IF +* + WANTST = LSAME( SORT, 'S' ) +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( IJOBVL.LE.0 ) THEN + INFO = -1 + ELSE IF( IJOBVR.LE.0 ) THEN + INFO = -2 + ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN + INFO = -14 + ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN + INFO = -16 + ELSE IF( LWORK.LT.MAX( 1, 2*N ) .AND. .NOT.LQUERY ) THEN + INFO = -18 + END IF +* +* Compute workspace +* + IF( INFO.EQ.0 ) THEN + CALL CGEQRF( N, N, B, LDB, WORK, WORK, -1, IERR ) + LWKOPT = MAX( 1, N + INT ( WORK( 1 ) ) ) + CALL CUNMQR( 'L', 'C', N, N, N, B, LDB, WORK, A, LDA, WORK, + $ -1, IERR ) + LWKOPT = MAX( LWKOPT, N + INT ( WORK( 1 ) ) ) + IF( ILVSL ) THEN + CALL CUNGQR( N, N, N, VSL, LDVSL, WORK, WORK, -1, + $ IERR ) + LWKOPT = MAX( LWKOPT, N + INT ( WORK( 1 ) ) ) + END IF + CALL CGGHD3( JOBVSL, JOBVSR, N, 1, N, A, LDA, B, LDB, VSL, + $ LDVSL, VSR, LDVSR, WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, N + INT ( WORK( 1 ) ) ) + CALL CHGEQZ( 'S', JOBVSL, JOBVSR, N, 1, N, A, LDA, B, LDB, + $ ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, -1, + $ WORK, IERR ) + LWKOPT = MAX( LWKOPT, INT ( WORK( 1 ) ) ) + IF( WANTST ) THEN + CALL CTGSEN( 0, ILVSL, ILVSR, WORK, N, A, LDA, B, LDB, + $ ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, SDIM, + $ PVSL, PVSR, DIF, WORK, -1, IDUM, 1, IERR ) + LWKOPT = MAX( LWKOPT, INT ( WORK( 1 ) ) ) + END IF + WORK( 1 ) = CMPLX( LWKOPT ) + END IF + +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CGGES3 ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + SDIM = 0 + RETURN + END IF +* +* Get machine constants +* + EPS = SLAMCH( 'P' ) + SMLNUM = SLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL SLABAD( SMLNUM, BIGNUM ) + SMLNUM = SQRT( SMLNUM ) / EPS + BIGNUM = ONE / SMLNUM +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = CLANGE( 'M', N, N, A, LDA, RWORK ) + ILASCL = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + ANRMTO = SMLNUM + ILASCL = .TRUE. + ELSE IF( ANRM.GT.BIGNUM ) THEN + ANRMTO = BIGNUM + ILASCL = .TRUE. + END IF +* + IF( ILASCL ) + $ CALL CLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR ) +* +* Scale B if max element outside range [SMLNUM,BIGNUM] +* + BNRM = CLANGE( 'M', N, N, B, LDB, RWORK ) + ILBSCL = .FALSE. + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN + BNRMTO = SMLNUM + ILBSCL = .TRUE. + ELSE IF( BNRM.GT.BIGNUM ) THEN + BNRMTO = BIGNUM + ILBSCL = .TRUE. + END IF +* + IF( ILBSCL ) + $ CALL CLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR ) +* +* Permute the matrix to make it more nearly triangular +* + ILEFT = 1 + IRIGHT = N + 1 + IRWRK = IRIGHT + N + CALL CGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, RWORK( ILEFT ), + $ RWORK( IRIGHT ), RWORK( IRWRK ), IERR ) +* +* Reduce B to triangular form (QR decomposition of B) +* + IROWS = IHI + 1 - ILO + ICOLS = N + 1 - ILO + ITAU = 1 + IWRK = ITAU + IROWS + CALL CGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) +* +* Apply the orthogonal transformation to matrix A +* + CALL CUNMQR( 'L', 'C', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, + $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), + $ LWORK+1-IWRK, IERR ) +* +* Initialize VSL +* + IF( ILVSL ) THEN + CALL CLASET( 'Full', N, N, CZERO, CONE, VSL, LDVSL ) + IF( IROWS.GT.1 ) THEN + CALL CLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, + $ VSL( ILO+1, ILO ), LDVSL ) + END IF + CALL CUNGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL, + $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR ) + END IF +* +* Initialize VSR +* + IF( ILVSR ) + $ CALL CLASET( 'Full', N, N, CZERO, CONE, VSR, LDVSR ) +* +* Reduce to generalized Hessenberg form +* + CALL CGGHD3( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, + $ LDVSL, VSR, LDVSR, WORK( IWRK ), LWORK+1-IWRK, IERR ) +* + SDIM = 0 +* +* Perform QZ algorithm, computing Schur vectors if desired +* + IWRK = ITAU + CALL CHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, + $ ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK( IWRK ), + $ LWORK+1-IWRK, RWORK( IRWRK ), IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.GT.0 .AND. IERR.LE.N ) THEN + INFO = IERR + ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN + INFO = IERR - N + ELSE + INFO = N + 1 + END IF + GO TO 30 + END IF +* +* Sort eigenvalues ALPHA/BETA if desired +* + IF( WANTST ) THEN +* +* Undo scaling on eigenvalues before selecting +* + IF( ILASCL ) + $ CALL CLASCL( 'G', 0, 0, ANRM, ANRMTO, N, 1, ALPHA, N, IERR ) + IF( ILBSCL ) + $ CALL CLASCL( 'G', 0, 0, BNRM, BNRMTO, N, 1, BETA, N, IERR ) +* +* Select eigenvalues +* + DO 10 I = 1, N + BWORK( I ) = SELCTG( ALPHA( I ), BETA( I ) ) + 10 CONTINUE +* + CALL CTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, ALPHA, + $ BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PVSL, PVSR, + $ DIF, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1, IERR ) + IF( IERR.EQ.1 ) + $ INFO = N + 3 +* + END IF +* +* Apply back-permutation to VSL and VSR +* + IF( ILVSL ) + $ CALL CGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ), + $ RWORK( IRIGHT ), N, VSL, LDVSL, IERR ) + IF( ILVSR ) + $ CALL CGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ), + $ RWORK( IRIGHT ), N, VSR, LDVSR, IERR ) +* +* Undo scaling +* + IF( ILASCL ) THEN + CALL CLASCL( 'U', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR ) + CALL CLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHA, N, IERR ) + END IF +* + IF( ILBSCL ) THEN + CALL CLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR ) + CALL CLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) + END IF +* + IF( WANTST ) THEN +* +* Check if reordering is correct +* + LASTSL = .TRUE. + SDIM = 0 + DO 20 I = 1, N + CURSL = SELCTG( ALPHA( I ), BETA( I ) ) + IF( CURSL ) + $ SDIM = SDIM + 1 + IF( CURSL .AND. .NOT.LASTSL ) + $ INFO = N + 2 + LASTSL = CURSL + 20 CONTINUE +* + END IF +* + 30 CONTINUE +* + WORK( 1 ) = CMPLX( LWKOPT ) +* + RETURN +* +* End of CGGES3 +* + END diff --git a/SRC/cggev3.f b/SRC/cggev3.f new file mode 100644 index 0000000..5d8c7f8 --- /dev/null +++ b/SRC/cggev3.f @@ -0,0 +1,560 @@ +*> \brief CGGEV3 computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices (blocked algorithm) +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CGGEV3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CGGEV3( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, +* $ VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBVL, JOBVR +* INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N +* .. +* .. Array Arguments .. +* REAL RWORK( * ) +* COMPLEX A( LDA, * ), ALPHA( * ), B( LDB, * ), +* $ BETA( * ), VL( LDVL, * ), VR( LDVR, * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGGEV3 computes for a pair of N-by-N complex nonsymmetric matrices +*> (A,B), the generalized eigenvalues, and optionally, the left and/or +*> right generalized eigenvectors. +*> +*> A generalized eigenvalue for a pair of matrices (A,B) is a scalar +*> lambda or a ratio alpha/beta = lambda, such that A - lambda*B is +*> singular. It is usually represented as the pair (alpha,beta), as +*> there is a reasonable interpretation for beta=0, and even for both +*> being zero. +*> +*> The right generalized eigenvector v(j) corresponding to the +*> generalized eigenvalue lambda(j) of (A,B) satisfies +*> +*> A * v(j) = lambda(j) * B * v(j). +*> +*> The left generalized eigenvector u(j) corresponding to the +*> generalized eigenvalues lambda(j) of (A,B) satisfies +*> +*> u(j)**H * A = lambda(j) * u(j)**H * B +*> +*> where u(j)**H is the conjugate-transpose of u(j). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBVL +*> \verbatim +*> JOBVL is CHARACTER*1 +*> = 'N': do not compute the left generalized eigenvectors; +*> = 'V': compute the left generalized eigenvectors. +*> \endverbatim +*> +*> \param[in] JOBVR +*> \verbatim +*> JOBVR is CHARACTER*1 +*> = 'N': do not compute the right generalized eigenvectors; +*> = 'V': compute the right generalized eigenvectors. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A, B, VL, and VR. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA, N) +*> On entry, the matrix A in the pair (A,B). +*> On exit, A has been overwritten. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension (LDB, N) +*> On entry, the matrix B in the pair (A,B). +*> On exit, B has been overwritten. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] ALPHA +*> \verbatim +*> ALPHA is COMPLEX array, dimension (N) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is COMPLEX array, dimension (N) +*> On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the +*> generalized eigenvalues. +*> +*> Note: the quotients ALPHA(j)/BETA(j) may easily over- or +*> underflow, and BETA(j) may even be zero. Thus, the user +*> should avoid naively computing the ratio alpha/beta. +*> However, ALPHA will be always less than and usually +*> comparable with norm(A) in magnitude, and BETA always less +*> than and usually comparable with norm(B). +*> \endverbatim +*> +*> \param[out] VL +*> \verbatim +*> VL is COMPLEX array, dimension (LDVL,N) +*> If JOBVL = 'V', the left generalized eigenvectors u(j) are +*> stored one after another in the columns of VL, in the same +*> order as their eigenvalues. +*> Each eigenvector is scaled so the largest component has +*> abs(real part) + abs(imag. part) = 1. +*> Not referenced if JOBVL = 'N'. +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of the matrix VL. LDVL >= 1, and +*> if JOBVL = 'V', LDVL >= N. +*> \endverbatim +*> +*> \param[out] VR +*> \verbatim +*> VR is COMPLEX array, dimension (LDVR,N) +*> If JOBVR = 'V', the right generalized eigenvectors v(j) are +*> stored one after another in the columns of VR, in the same +*> order as their eigenvalues. +*> Each eigenvector is scaled so the largest component has +*> abs(real part) + abs(imag. part) = 1. +*> Not referenced if JOBVR = 'N'. +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the matrix VR. LDVR >= 1, and +*> if JOBVR = 'V', LDVR >= 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 dimension of the array WORK. +*> +*> 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 (8*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> =1,...,N: +*> The QZ iteration failed. No eigenvectors have been +*> calculated, but ALPHA(j) and BETA(j) should be +*> correct for j=INFO+1,...,N. +*> > N: =N+1: other then QZ iteration failed in SHGEQZ, +*> =N+2: error return from STGEVC. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date January 2015 +* +*> \ingroup complexGEeigen +* +* ===================================================================== + SUBROUTINE CGGEV3( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, + $ VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) +* +* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2015 +* +* .. Scalar Arguments .. + CHARACTER JOBVL, JOBVR + INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N +* .. +* .. Array Arguments .. + REAL RWORK( * ) + COMPLEX A( LDA, * ), ALPHA( * ), B( LDB, * ), + $ BETA( * ), VL( LDVL, * ), VR( LDVR, * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E0, 0.0E0 ), + $ CONE = ( 1.0E0, 0.0E0 ) ) +* .. +* .. Local Scalars .. + LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY + CHARACTER CHTEMP + INTEGER ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO, + $ IN, IRIGHT, IROWS, IRWRK, ITAU, IWRK, JC, JR, + $ LWKMIN, LWKOPT + REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, + $ SMLNUM, TEMP + COMPLEX X +* .. +* .. Local Arrays .. + LOGICAL LDUMMA( 1 ) +* .. +* .. External Subroutines .. + EXTERNAL CGEQRF, CGGBAK, CGGBAL, CGGHD3, CHGEQZ, CLACPY, + $ CLASCL, CLASET, CTGEVC, CUNGQR, CUNMQR, SLABAD, + $ XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + REAL CLANGE, SLAMCH + EXTERNAL LSAME, CLANGE, SLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, AIMAG, MAX, REAL, SQRT +* .. +* .. Statement Functions .. + REAL ABS1 +* .. +* .. Statement Function definitions .. + ABS1( X ) = ABS( REAL( X ) ) + ABS( AIMAG( X ) ) +* .. +* .. Executable Statements .. +* +* Decode the input arguments +* + IF( LSAME( JOBVL, 'N' ) ) THEN + IJOBVL = 1 + ILVL = .FALSE. + ELSE IF( LSAME( JOBVL, 'V' ) ) THEN + IJOBVL = 2 + ILVL = .TRUE. + ELSE + IJOBVL = -1 + ILVL = .FALSE. + END IF +* + IF( LSAME( JOBVR, 'N' ) ) THEN + IJOBVR = 1 + ILVR = .FALSE. + ELSE IF( LSAME( JOBVR, 'V' ) ) THEN + IJOBVR = 2 + ILVR = .TRUE. + ELSE + IJOBVR = -1 + ILVR = .FALSE. + END IF + ILV = ILVL .OR. ILVR +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( IJOBVL.LE.0 ) THEN + INFO = -1 + ELSE IF( IJOBVR.LE.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN + INFO = -11 + ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN + INFO = -13 + ELSE IF( LWORK.LT.MAX( 1, 2*N ) .AND. .NOT.LQUERY ) THEN + INFO = -15 + END IF +* +* Compute workspace +* + IF( INFO.EQ.0 ) THEN + CALL CGEQRF( N, N, B, LDB, WORK, WORK, -1, IERR ) + LWKOPT = MAX( N, N+INT( WORK( 1 ) ) ) + CALL CUNMQR( 'L', 'C', N, N, N, B, LDB, WORK, A, LDA, WORK, + $ -1, IERR ) + LWKOPT = MAX( LWKOPT, N+INT( WORK( 1 ) ) ) + IF( ILVL ) THEN + CALL CUNGQR( N, N, N, VL, LDVL, WORK, WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, N+INT( WORK( 1 ) ) ) + END IF + IF( ILV ) THEN + CALL CGGHD3( JOBVL, JOBVR, N, 1, N, A, LDA, B, LDB, VL, + $ LDVL, VR, LDVR, WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, N+INT( WORK( 1 ) ) ) + CALL CHGEQZ( 'S', JOBVL, JOBVR, N, 1, N, A, LDA, B, LDB, + $ ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, + $ -1, WORK, IERR ) + LWKOPT = MAX( LWKOPT, N+INT( WORK( 1 ) ) ) + ELSE + CALL CGGHD3( 'N', 'N', N, 1, N, A, LDA, B, LDB, VL, LDVL, + $ VR, LDVR, WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, N+INT( WORK( 1 ) ) ) + CALL CHGEQZ( 'E', JOBVL, JOBVR, N, 1, N, A, LDA, B, LDB, + $ ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, + $ -1, WORK, IERR ) + LWKOPT = MAX( LWKOPT, N+INT( WORK( 1 ) ) ) + END IF + WORK( 1 ) = CMPLX( LWKOPT ) + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CGGEV3 ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Get machine constants +* + EPS = SLAMCH( 'E' )*SLAMCH( 'B' ) + SMLNUM = SLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL SLABAD( SMLNUM, BIGNUM ) + SMLNUM = SQRT( SMLNUM ) / EPS + BIGNUM = ONE / SMLNUM +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = CLANGE( 'M', N, N, A, LDA, RWORK ) + ILASCL = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + ANRMTO = SMLNUM + ILASCL = .TRUE. + ELSE IF( ANRM.GT.BIGNUM ) THEN + ANRMTO = BIGNUM + ILASCL = .TRUE. + END IF + IF( ILASCL ) + $ CALL CLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR ) +* +* Scale B if max element outside range [SMLNUM,BIGNUM] +* + BNRM = CLANGE( 'M', N, N, B, LDB, RWORK ) + ILBSCL = .FALSE. + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN + BNRMTO = SMLNUM + ILBSCL = .TRUE. + ELSE IF( BNRM.GT.BIGNUM ) THEN + BNRMTO = BIGNUM + ILBSCL = .TRUE. + END IF + IF( ILBSCL ) + $ CALL CLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR ) +* +* Permute the matrices A, B to isolate eigenvalues if possible +* + ILEFT = 1 + IRIGHT = N + 1 + IRWRK = IRIGHT + N + CALL CGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, RWORK( ILEFT ), + $ RWORK( IRIGHT ), RWORK( IRWRK ), IERR ) +* +* Reduce B to triangular form (QR decomposition of B) +* + IROWS = IHI + 1 - ILO + IF( ILV ) THEN + ICOLS = N + 1 - ILO + ELSE + ICOLS = IROWS + END IF + ITAU = 1 + IWRK = ITAU + IROWS + CALL CGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) +* +* Apply the orthogonal transformation to matrix A +* + CALL CUNMQR( 'L', 'C', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, + $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), + $ LWORK+1-IWRK, IERR ) +* +* Initialize VL +* + IF( ILVL ) THEN + CALL CLASET( 'Full', N, N, CZERO, CONE, VL, LDVL ) + IF( IROWS.GT.1 ) THEN + CALL CLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, + $ VL( ILO+1, ILO ), LDVL ) + END IF + CALL CUNGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL, + $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR ) + END IF +* +* Initialize VR +* + IF( ILVR ) + $ CALL CLASET( 'Full', N, N, CZERO, CONE, VR, LDVR ) +* +* Reduce to generalized Hessenberg form +* + IF( ILV ) THEN +* +* Eigenvectors requested -- work on whole matrix. +* + CALL CGGHD3( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL, + $ LDVL, VR, LDVR, WORK( IWRK ), LWORK+1-IWRK, + $ IERR ) + ELSE + CALL CGGHD3( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA, + $ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) + END IF +* +* Perform QZ algorithm (Compute eigenvalues, and optionally, the +* Schur form and Schur vectors) +* + IWRK = ITAU + IF( ILV ) THEN + CHTEMP = 'S' + ELSE + CHTEMP = 'E' + END IF + CALL CHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, + $ ALPHA, BETA, VL, LDVL, VR, LDVR, WORK( IWRK ), + $ LWORK+1-IWRK, RWORK( IRWRK ), IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.GT.0 .AND. IERR.LE.N ) THEN + INFO = IERR + ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN + INFO = IERR - N + ELSE + INFO = N + 1 + END IF + GO TO 70 + END IF +* +* Compute Eigenvectors +* + IF( ILV ) THEN + IF( ILVL ) THEN + IF( ILVR ) THEN + CHTEMP = 'B' + ELSE + CHTEMP = 'L' + END IF + ELSE + CHTEMP = 'R' + END IF +* + CALL CTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL, + $ VR, LDVR, N, IN, WORK( IWRK ), RWORK( IRWRK ), + $ IERR ) + IF( IERR.NE.0 ) THEN + INFO = N + 2 + GO TO 70 + END IF +* +* Undo balancing on VL and VR and normalization +* + IF( ILVL ) THEN + CALL CGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ), + $ RWORK( IRIGHT ), N, VL, LDVL, IERR ) + DO 30 JC = 1, N + TEMP = ZERO + DO 10 JR = 1, N + TEMP = MAX( TEMP, ABS1( VL( JR, JC ) ) ) + 10 CONTINUE + IF( TEMP.LT.SMLNUM ) + $ GO TO 30 + TEMP = ONE / TEMP + DO 20 JR = 1, N + VL( JR, JC ) = VL( JR, JC )*TEMP + 20 CONTINUE + 30 CONTINUE + END IF + IF( ILVR ) THEN + CALL CGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ), + $ RWORK( IRIGHT ), N, VR, LDVR, IERR ) + DO 60 JC = 1, N + TEMP = ZERO + DO 40 JR = 1, N + TEMP = MAX( TEMP, ABS1( VR( JR, JC ) ) ) + 40 CONTINUE + IF( TEMP.LT.SMLNUM ) + $ GO TO 60 + TEMP = ONE / TEMP + DO 50 JR = 1, N + VR( JR, JC ) = VR( JR, JC )*TEMP + 50 CONTINUE + 60 CONTINUE + END IF + END IF +* +* Undo scaling if necessary +* + 70 CONTINUE +* + IF( ILASCL ) + $ CALL CLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHA, N, IERR ) +* + IF( ILBSCL ) + $ CALL CLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) +* + WORK( 1 ) = CMPLX( LWKOPT ) + RETURN +* +* End of CGGEV3 +* + END diff --git a/SRC/cgghd3.f b/SRC/cgghd3.f new file mode 100644 index 0000000..347d799 --- /dev/null +++ b/SRC/cgghd3.f @@ -0,0 +1,901 @@ +*> \brief \b CGGHD3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CGGHD3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CGGHD3( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, +* $ LDQ, Z, LDZ, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER COMPQ, COMPZ +* INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N, LWORK +* .. +* .. Array Arguments .. +* COMPLEX A( LDA, * ), B( LDB, * ), Q( LDQ, * ), +* $ Z( LDZ, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> +*> CGGHD3 reduces a pair of complex matrices (A,B) to generalized upper +*> Hessenberg form using unitary transformations, where A is a +*> general matrix and B is upper triangular. The form of the +*> generalized eigenvalue problem is +*> A*x = lambda*B*x, +*> and B is typically made upper triangular by computing its QR +*> factorization and moving the unitary matrix Q to the left side +*> of the equation. +*> +*> This subroutine simultaneously reduces A to a Hessenberg matrix H: +*> Q**H*A*Z = H +*> and transforms B to another upper triangular matrix T: +*> Q**H*B*Z = T +*> in order to reduce the problem to its standard form +*> H*y = lambda*T*y +*> where y = Z**H*x. +*> +*> The unitary matrices Q and Z are determined as products of Givens +*> rotations. They may either be formed explicitly, or they may be +*> postmultiplied into input matrices Q1 and Z1, so that +*> +*> Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H +*> +*> Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H +*> +*> If Q1 is the unitary matrix from the QR factorization of B in the +*> original equation A*x = lambda*B*x, then CGGHD3 reduces the original +*> problem to generalized Hessenberg form. +*> +*> This is a blocked variant of CGGHRD, using matrix-matrix +*> multiplications for parts of the computation to enhance performance. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] COMPQ +*> \verbatim +*> COMPQ is CHARACTER*1 +*> = 'N': do not compute Q; +*> = 'I': Q is initialized to the unit matrix, and the +*> unitary matrix Q is returned; +*> = 'V': Q must contain a unitary matrix Q1 on entry, +*> and the product Q1*Q is returned. +*> \endverbatim +*> +*> \param[in] COMPZ +*> \verbatim +*> COMPZ is CHARACTER*1 +*> = 'N': do not compute Z; +*> = 'I': Z is initialized to the unit matrix, and the +*> unitary matrix Z is returned; +*> = 'V': Z must contain a unitary matrix Z1 on entry, +*> and the product Z1*Z is returned. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> +*> ILO and IHI mark the rows and columns of A which are to be +*> reduced. It is assumed that A is already upper triangular +*> in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are +*> normally set by a previous call to CGGBAL; otherwise they +*> should be set to 1 and N respectively. +*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA, N) +*> On entry, the N-by-N general matrix to be reduced. +*> On exit, the upper triangle and the first subdiagonal of A +*> are overwritten with the upper Hessenberg matrix H, and the +*> rest is set to zero. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension (LDB, N) +*> On entry, the N-by-N upper triangular matrix B. +*> On exit, the upper triangular matrix T = Q**H B Z. The +*> elements below the diagonal are set to zero. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] Q +*> \verbatim +*> Q is COMPLEX array, dimension (LDQ, N) +*> On entry, if COMPQ = 'V', the unitary matrix Q1, typically +*> from the QR factorization of B. +*> On exit, if COMPQ='I', the unitary matrix Q, and if +*> COMPQ = 'V', the product Q1*Q. +*> Not referenced if COMPQ='N'. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. +*> LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is COMPLEX array, dimension (LDZ, N) +*> On entry, if COMPZ = 'V', the unitary matrix Z1. +*> On exit, if COMPZ='I', the unitary matrix Z, and if +*> COMPZ = 'V', the product Z1*Z. +*> Not referenced if COMPZ='N'. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. +*> LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (LWORK) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1. +*> For optimum performance LWORK >= 6*N*NB, where NB is the +*> optimal blocksize. +*> +*> 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 January 2015 +* +*> \ingroup complexOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> This routine reduces A to Hessenberg form and maintains B in +*> using a blocked variant of Moler and Stewart's original algorithm, +*> as described by Kagstrom, Kressner, Quintana-Orti, and Quintana-Orti +*> (BIT 2008). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CGGHD3( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, + $ LDQ, Z, LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2015 +* +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ + INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N, LWORK +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), B( LDB, * ), Q( LDQ, * ), + $ Z( LDZ, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX CONE, CZERO + PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ), + $ CZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL BLK22, INITQ, INITZ, LQUERY, WANTQ, WANTZ + CHARACTER*1 COMPQ2, COMPZ2 + INTEGER COLA, I, IERR, J, J0, JCOL, JJ, JROW, K, + $ KACC22, LEN, LWKOPT, N2NB, NB, NBLST, NBMIN, + $ NH, NNB, NX, PPW, PPWO, PW, TOP, TOPQ + REAL C + COMPLEX C1, C2, CTEMP, S, S1, S2, TEMP, TEMP1, TEMP2, + $ TEMP3 +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +* .. +* .. External Subroutines .. + EXTERNAL CGGHRD, CLARTG, CLASET, CUNM22, CROT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, CMPLX, CONJG, MAX +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters. +* + INFO = 0 + NB = ILAENV( 1, 'CGGHD3', ' ', N, ILO, IHI, -1 ) + LWKOPT = 6*N*NB + WORK( 1 ) = CMPLX( LWKOPT ) + INITQ = LSAME( COMPQ, 'I' ) + WANTQ = INITQ .OR. LSAME( COMPQ, 'V' ) + INITZ = LSAME( COMPZ, 'I' ) + WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) + LQUERY = ( LWORK.EQ.-1 ) +* + IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( ILO.LT.1 ) THEN + INFO = -4 + ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( ( WANTQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN + INFO = -11 + ELSE IF( ( WANTZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN + INFO = -13 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -15 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CGGHD3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Initialize Q and Z if desired. +* + IF( INITQ ) + $ CALL CLASET( 'All', N, N, CZERO, CONE, Q, LDQ ) + IF( INITZ ) + $ CALL CLASET( 'All', N, N, CZERO, CONE, Z, LDZ ) +* +* Zero out lower triangle of B. +* + IF( N.GT.1 ) + $ CALL CLASET( 'Lower', N-1, N-1, CZERO, CZERO, B(2, 1), LDB ) +* +* Quick return if possible +* + NH = IHI - ILO + 1 + IF( NH.LE.1 ) THEN + WORK( 1 ) = CONE + RETURN + END IF +* +* Determine the blocksize. +* + NBMIN = ILAENV( 2, 'CGGHD3', ' ', N, ILO, IHI, -1 ) + IF( NB.GT.1 .AND. NB.LT.NH ) THEN +* +* Determine when to use unblocked instead of blocked code. +* + NX = MAX( NB, ILAENV( 3, 'CGGHD3', ' ', N, ILO, IHI, -1 ) ) + IF( NX.LT.NH ) THEN +* +* Determine if workspace is large enough for blocked code. +* + IF( LWORK.LT.LWKOPT ) THEN +* +* Not enough workspace to use optimal NB: determine the +* minimum value of NB, and reduce NB or force use of +* unblocked code. +* + NBMIN = MAX( 2, ILAENV( 2, 'CGGHD3', ' ', N, ILO, IHI, + $ -1 ) ) + IF( LWORK.GE.6*N*NBMIN ) THEN + NB = LWORK / ( 6*N ) + ELSE + NB = 1 + END IF + END IF + END IF + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN +* +* Use unblocked code below +* + JCOL = ILO +* + ELSE +* +* Use blocked code +* + KACC22 = ILAENV( 16, 'CGGHD3', ' ', N, ILO, IHI, -1 ) + BLK22 = KACC22.EQ.2 + DO JCOL = ILO, IHI-2, NB + NNB = MIN( NB, IHI-JCOL-1 ) +* +* Initialize small unitary factors that will hold the +* accumulated Givens rotations in workspace. +* N2NB denotes the number of 2*NNB-by-2*NNB factors +* NBLST denotes the (possibly smaller) order of the last +* factor. +* + N2NB = ( IHI-JCOL-1 ) / NNB - 1 + NBLST = IHI - JCOL - N2NB*NNB + CALL CLASET( 'All', NBLST, NBLST, CZERO, CONE, WORK, NBLST ) + PW = NBLST * NBLST + 1 + DO I = 1, N2NB + CALL CLASET( 'All', 2*NNB, 2*NNB, CZERO, CONE, + $ WORK( PW ), 2*NNB ) + PW = PW + 4*NNB*NNB + END DO +* +* Reduce columns JCOL:JCOL+NNB-1 of A to Hessenberg form. +* + DO J = JCOL, JCOL+NNB-1 +* +* Reduce Jth column of A. Store cosines and sines in Jth +* column of A and B, respectively. +* + DO I = IHI, J+2, -1 + TEMP = A( I-1, J ) + CALL CLARTG( TEMP, A( I, J ), C, S, A( I-1, J ) ) + A( I, J ) = CMPLX( C ) + B( I, J ) = S + END DO +* +* Accumulate Givens rotations into workspace array. +* + PPW = ( NBLST + 1 )*( NBLST - 2 ) - J + JCOL + 1 + LEN = 2 + J - JCOL + JROW = J + N2NB*NNB + 2 + DO I = IHI, JROW, -1 + CTEMP = A( I, J ) + S = B( I, J ) + DO JJ = PPW, PPW+LEN-1 + TEMP = WORK( JJ + NBLST ) + WORK( JJ + NBLST ) = CTEMP*TEMP - S*WORK( JJ ) + WORK( JJ ) = CONJG( S )*TEMP + CTEMP*WORK( JJ ) + END DO + LEN = LEN + 1 + PPW = PPW - NBLST - 1 + END DO +* + PPWO = NBLST*NBLST + ( NNB+J-JCOL-1 )*2*NNB + NNB + J0 = JROW - NNB + DO JROW = J0, J+2, -NNB + PPW = PPWO + LEN = 2 + J - JCOL + DO I = JROW+NNB-1, JROW, -1 + CTEMP = A( I, J ) + S = B( I, J ) + DO JJ = PPW, PPW+LEN-1 + TEMP = WORK( JJ + 2*NNB ) + WORK( JJ + 2*NNB ) = CTEMP*TEMP - S*WORK( JJ ) + WORK( JJ ) = CONJG( S )*TEMP + CTEMP*WORK( JJ ) + END DO + LEN = LEN + 1 + PPW = PPW - 2*NNB - 1 + END DO + PPWO = PPWO + 4*NNB*NNB + END DO +* +* TOP denotes the number of top rows in A and B that will +* not be updated during the next steps. +* + IF( JCOL.LE.2 ) THEN + TOP = 0 + ELSE + TOP = JCOL + END IF +* +* Propagate transformations through B and replace stored +* left sines/cosines by right sines/cosines. +* + DO JJ = N, J+1, -1 +* +* Update JJth column of B. +* + DO I = MIN( JJ+1, IHI ), J+2, -1 + CTEMP = A( I, J ) + S = B( I, J ) + TEMP = B( I, JJ ) + B( I, JJ ) = CTEMP*TEMP - CONJG( S )*B( I-1, JJ ) + B( I-1, JJ ) = S*TEMP + CTEMP*B( I-1, JJ ) + END DO +* +* Annihilate B( JJ+1, JJ ). +* + IF( JJ.LT.IHI ) THEN + TEMP = B( JJ+1, JJ+1 ) + CALL CLARTG( TEMP, B( JJ+1, JJ ), C, S, + $ B( JJ+1, JJ+1 ) ) + B( JJ+1, JJ ) = CZERO + CALL CROT( JJ-TOP, B( TOP+1, JJ+1 ), 1, + $ B( TOP+1, JJ ), 1, C, S ) + A( JJ+1, J ) = CMPLX( C ) + B( JJ+1, J ) = -CONJG( S ) + END IF + END DO +* +* Update A by transformations from right. +* + JJ = MOD( IHI-J-1, 3 ) + DO I = IHI-J-3, JJ+1, -3 + CTEMP = A( J+1+I, J ) + S = -B( J+1+I, J ) + C1 = A( J+2+I, J ) + S1 = -B( J+2+I, J ) + C2 = A( J+3+I, J ) + S2 = -B( J+3+I, J ) +* + DO K = TOP+1, IHI + TEMP = A( K, J+I ) + TEMP1 = A( K, J+I+1 ) + TEMP2 = A( K, J+I+2 ) + TEMP3 = A( K, J+I+3 ) + A( K, J+I+3 ) = C2*TEMP3 + CONJG( S2 )*TEMP2 + TEMP2 = -S2*TEMP3 + C2*TEMP2 + A( K, J+I+2 ) = C1*TEMP2 + CONJG( S1 )*TEMP1 + TEMP1 = -S1*TEMP2 + C1*TEMP1 + A( K, J+I+1 ) = CTEMP*TEMP1 + CONJG( S )*TEMP + A( K, J+I ) = -S*TEMP1 + CTEMP*TEMP + END DO + END DO +* + IF( JJ.GT.0 ) THEN + DO I = JJ, 1, -1 + C = DBLE( A( J+1+I, J ) ) + CALL CROT( IHI-TOP, A( TOP+1, J+I+1 ), 1, + $ A( TOP+1, J+I ), 1, C, + $ -CONJG( B( J+1+I, J ) ) ) + END DO + END IF +* +* Update (J+1)th column of A by transformations from left. +* + IF ( J .LT. JCOL + NNB - 1 ) THEN + LEN = 1 + J - JCOL +* +* Multiply with the trailing accumulated unitary +* matrix, which takes the form +* +* [ U11 U12 ] +* U = [ ], +* [ U21 U22 ] +* +* where U21 is a LEN-by-LEN matrix and U12 is lower +* triangular. +* + JROW = IHI - NBLST + 1 + CALL CGEMV( 'Conjugate', NBLST, LEN, CONE, WORK, + $ NBLST, A( JROW, J+1 ), 1, CZERO, + $ WORK( PW ), 1 ) + PPW = PW + LEN + DO I = JROW, JROW+NBLST-LEN-1 + WORK( PPW ) = A( I, J+1 ) + PPW = PPW + 1 + END DO + CALL CTRMV( 'Lower', 'Conjugate', 'Non-unit', + $ NBLST-LEN, WORK( LEN*NBLST + 1 ), NBLST, + $ WORK( PW+LEN ), 1 ) + CALL CGEMV( 'Conjugate', LEN, NBLST-LEN, CONE, + $ WORK( (LEN+1)*NBLST - LEN + 1 ), NBLST, + $ A( JROW+NBLST-LEN, J+1 ), 1, CONE, + $ WORK( PW+LEN ), 1 ) + PPW = PW + DO I = JROW, JROW+NBLST-1 + A( I, J+1 ) = WORK( PPW ) + PPW = PPW + 1 + END DO +* +* Multiply with the other accumulated unitary +* matrices, which take the form +* +* [ U11 U12 0 ] +* [ ] +* U = [ U21 U22 0 ], +* [ ] +* [ 0 0 I ] +* +* where I denotes the (NNB-LEN)-by-(NNB-LEN) identity +* matrix, U21 is a LEN-by-LEN upper triangular matrix +* and U12 is an NNB-by-NNB lower triangular matrix. +* + PPWO = 1 + NBLST*NBLST + J0 = JROW - NNB + DO JROW = J0, JCOL+1, -NNB + PPW = PW + LEN + DO I = JROW, JROW+NNB-1 + WORK( PPW ) = A( I, J+1 ) + PPW = PPW + 1 + END DO + PPW = PW + DO I = JROW+NNB, JROW+NNB+LEN-1 + WORK( PPW ) = A( I, J+1 ) + PPW = PPW + 1 + END DO + CALL CTRMV( 'Upper', 'Conjugate', 'Non-unit', LEN, + $ WORK( PPWO + NNB ), 2*NNB, WORK( PW ), + $ 1 ) + CALL CTRMV( 'Lower', 'Conjugate', 'Non-unit', NNB, + $ WORK( PPWO + 2*LEN*NNB ), + $ 2*NNB, WORK( PW + LEN ), 1 ) + CALL CGEMV( 'Conjugate', NNB, LEN, CONE, + $ WORK( PPWO ), 2*NNB, A( JROW, J+1 ), 1, + $ CONE, WORK( PW ), 1 ) + CALL CGEMV( 'Conjugate', LEN, NNB, CONE, + $ WORK( PPWO + 2*LEN*NNB + NNB ), 2*NNB, + $ A( JROW+NNB, J+1 ), 1, CONE, + $ WORK( PW+LEN ), 1 ) + PPW = PW + DO I = JROW, JROW+LEN+NNB-1 + A( I, J+1 ) = WORK( PPW ) + PPW = PPW + 1 + END DO + PPWO = PPWO + 4*NNB*NNB + END DO + END IF + END DO +* +* Apply accumulated unitary matrices to A. +* + COLA = N - JCOL - NNB + 1 + J = IHI - NBLST + 1 + CALL CGEMM( 'Conjugate', 'No Transpose', NBLST, + $ COLA, NBLST, CONE, WORK, NBLST, + $ A( J, JCOL+NNB ), LDA, CZERO, WORK( PW ), + $ NBLST ) + CALL CLACPY( 'All', NBLST, COLA, WORK( PW ), NBLST, + $ A( J, JCOL+NNB ), LDA ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( BLK22 ) THEN +* +* Exploit the structure of +* +* [ U11 U12 ] +* U = [ ] +* [ U21 U22 ], +* +* where all blocks are NNB-by-NNB, U21 is upper +* triangular and U12 is lower triangular. +* + CALL CUNM22( 'Left', 'Conjugate', 2*NNB, COLA, NNB, + $ NNB, WORK( PPWO ), 2*NNB, + $ A( J, JCOL+NNB ), LDA, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL CGEMM( 'Conjugate', 'No Transpose', 2*NNB, + $ COLA, 2*NNB, CONE, WORK( PPWO ), 2*NNB, + $ A( J, JCOL+NNB ), LDA, CZERO, WORK( PW ), + $ 2*NNB ) + CALL CLACPY( 'All', 2*NNB, COLA, WORK( PW ), 2*NNB, + $ A( J, JCOL+NNB ), LDA ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO +* +* Apply accumulated unitary matrices to Q. +* + IF( WANTQ ) THEN + J = IHI - NBLST + 1 + IF ( INITQ ) THEN + TOPQ = MAX( 2, J - JCOL + 1 ) + NH = IHI - TOPQ + 1 + ELSE + TOPQ = 1 + NH = N + END IF + CALL CGEMM( 'No Transpose', 'No Transpose', NH, + $ NBLST, NBLST, CONE, Q( TOPQ, J ), LDQ, + $ WORK, NBLST, CZERO, WORK( PW ), NH ) + CALL CLACPY( 'All', NH, NBLST, WORK( PW ), NH, + $ Q( TOPQ, J ), LDQ ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( INITQ ) THEN + TOPQ = MAX( 2, J - JCOL + 1 ) + NH = IHI - TOPQ + 1 + END IF + IF ( BLK22 ) THEN +* +* Exploit the structure of U. +* + CALL CUNM22( 'Right', 'No Transpose', NH, 2*NNB, + $ NNB, NNB, WORK( PPWO ), 2*NNB, + $ Q( TOPQ, J ), LDQ, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL CGEMM( 'No Transpose', 'No Transpose', NH, + $ 2*NNB, 2*NNB, CONE, Q( TOPQ, J ), LDQ, + $ WORK( PPWO ), 2*NNB, CZERO, WORK( PW ), + $ NH ) + CALL CLACPY( 'All', NH, 2*NNB, WORK( PW ), NH, + $ Q( TOPQ, J ), LDQ ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO + END IF +* +* Accumulate right Givens rotations if required. +* + IF ( WANTZ .OR. TOP.GT.0 ) THEN +* +* Initialize small unitary factors that will hold the +* accumulated Givens rotations in workspace. +* + CALL CLASET( 'All', NBLST, NBLST, CZERO, CONE, WORK, + $ NBLST ) + PW = NBLST * NBLST + 1 + DO I = 1, N2NB + CALL CLASET( 'All', 2*NNB, 2*NNB, CZERO, CONE, + $ WORK( PW ), 2*NNB ) + PW = PW + 4*NNB*NNB + END DO +* +* Accumulate Givens rotations into workspace array. +* + DO J = JCOL, JCOL+NNB-1 + PPW = ( NBLST + 1 )*( NBLST - 2 ) - J + JCOL + 1 + LEN = 2 + J - JCOL + JROW = J + N2NB*NNB + 2 + DO I = IHI, JROW, -1 + CTEMP = A( I, J ) + A( I, J ) = CZERO + S = B( I, J ) + B( I, J ) = CZERO + DO JJ = PPW, PPW+LEN-1 + TEMP = WORK( JJ + NBLST ) + WORK( JJ + NBLST ) = CTEMP*TEMP - + $ CONJG( S )*WORK( JJ ) + WORK( JJ ) = S*TEMP + CTEMP*WORK( JJ ) + END DO + LEN = LEN + 1 + PPW = PPW - NBLST - 1 + END DO +* + PPWO = NBLST*NBLST + ( NNB+J-JCOL-1 )*2*NNB + NNB + J0 = JROW - NNB + DO JROW = J0, J+2, -NNB + PPW = PPWO + LEN = 2 + J - JCOL + DO I = JROW+NNB-1, JROW, -1 + CTEMP = A( I, J ) + A( I, J ) = CZERO + S = B( I, J ) + B( I, J ) = CZERO + DO JJ = PPW, PPW+LEN-1 + TEMP = WORK( JJ + 2*NNB ) + WORK( JJ + 2*NNB ) = CTEMP*TEMP - + $ CONJG( S )*WORK( JJ ) + WORK( JJ ) = S*TEMP + CTEMP*WORK( JJ ) + END DO + LEN = LEN + 1 + PPW = PPW - 2*NNB - 1 + END DO + PPWO = PPWO + 4*NNB*NNB + END DO + END DO + ELSE + + DO J = ILO, ILO+NNB + DO I = J+2, IHI + A( I, J ) = CZERO + B( I, J ) = CZERO + END DO + END DO + END IF +* +* Apply accumulated unitary matrices to A and B. +* + IF ( TOP.GT.0 ) THEN + J = IHI - NBLST + 1 + CALL CGEMM( 'No Transpose', 'No Transpose', TOP, + $ NBLST, NBLST, CONE, A( 1, J ), LDA, + $ WORK, NBLST, CZERO, WORK( PW ), TOP ) + CALL CLACPY( 'All', TOP, NBLST, WORK( PW ), TOP, + $ A( 1, J ), LDA ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( BLK22 ) THEN +* +* Exploit the structure of U. +* + CALL CUNM22( 'Right', 'No Transpose', TOP, 2*NNB, + $ NNB, NNB, WORK( PPWO ), 2*NNB, + $ A( 1, J ), LDA, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL CGEMM( 'No Transpose', 'No Transpose', TOP, + $ 2*NNB, 2*NNB, CONE, A( 1, J ), LDA, + $ WORK( PPWO ), 2*NNB, CZERO, + $ WORK( PW ), TOP ) + CALL CLACPY( 'All', TOP, 2*NNB, WORK( PW ), TOP, + $ A( 1, J ), LDA ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO +* + J = IHI - NBLST + 1 + CALL CGEMM( 'No Transpose', 'No Transpose', TOP, + $ NBLST, NBLST, CONE, B( 1, J ), LDB, + $ WORK, NBLST, CZERO, WORK( PW ), TOP ) + CALL CLACPY( 'All', TOP, NBLST, WORK( PW ), TOP, + $ B( 1, J ), LDB ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( BLK22 ) THEN +* +* Exploit the structure of U. +* + CALL CUNM22( 'Right', 'No Transpose', TOP, 2*NNB, + $ NNB, NNB, WORK( PPWO ), 2*NNB, + $ B( 1, J ), LDA, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL CGEMM( 'No Transpose', 'No Transpose', TOP, + $ 2*NNB, 2*NNB, CONE, B( 1, J ), LDB, + $ WORK( PPWO ), 2*NNB, CZERO, + $ WORK( PW ), TOP ) + CALL CLACPY( 'All', TOP, 2*NNB, WORK( PW ), TOP, + $ B( 1, J ), LDB ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO + END IF +* +* Apply accumulated unitary matrices to Z. +* + IF( WANTZ ) THEN + J = IHI - NBLST + 1 + IF ( INITQ ) THEN + TOPQ = MAX( 2, J - JCOL + 1 ) + NH = IHI - TOPQ + 1 + ELSE + TOPQ = 1 + NH = N + END IF + CALL CGEMM( 'No Transpose', 'No Transpose', NH, + $ NBLST, NBLST, CONE, Z( TOPQ, J ), LDZ, + $ WORK, NBLST, CZERO, WORK( PW ), NH ) + CALL CLACPY( 'All', NH, NBLST, WORK( PW ), NH, + $ Z( TOPQ, J ), LDZ ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( INITQ ) THEN + TOPQ = MAX( 2, J - JCOL + 1 ) + NH = IHI - TOPQ + 1 + END IF + IF ( BLK22 ) THEN +* +* Exploit the structure of U. +* + CALL CUNM22( 'Right', 'No Transpose', NH, 2*NNB, + $ NNB, NNB, WORK( PPWO ), 2*NNB, + $ Z( TOPQ, J ), LDZ, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL CGEMM( 'No Transpose', 'No Transpose', NH, + $ 2*NNB, 2*NNB, CONE, Z( TOPQ, J ), LDZ, + $ WORK( PPWO ), 2*NNB, CZERO, WORK( PW ), + $ NH ) + CALL CLACPY( 'All', NH, 2*NNB, WORK( PW ), NH, + $ Z( TOPQ, J ), LDZ ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO + END IF + END DO + END IF +* +* Use unblocked code to reduce the rest of the matrix +* Avoid re-initialization of modified Q and Z. +* + COMPQ2 = COMPQ + COMPZ2 = COMPZ + IF ( JCOL.NE.ILO ) THEN + IF ( WANTQ ) + $ COMPQ2 = 'V' + IF ( WANTZ ) + $ COMPZ2 = 'V' + END IF +* + IF ( JCOL.LT.IHI ) + $ CALL CGGHRD( COMPQ2, COMPZ2, N, JCOL, IHI, A, LDA, B, LDB, Q, + $ LDQ, Z, LDZ, IERR ) + WORK( 1 ) = CMPLX( LWKOPT ) +* + RETURN +* +* End of CGGHD3 +* + END diff --git a/SRC/cunm22.f b/SRC/cunm22.f new file mode 100644 index 0000000..85c2269 --- /dev/null +++ b/SRC/cunm22.f @@ -0,0 +1,440 @@ +*> \brief \b CUNM22 multiplies a general matrix by a banded unitary matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CUNM22 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CUNM22( SIDE, TRANS, M, N, N1, N2, Q, LDQ, C, LDC, +* $ WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER M, N, N1, N2, LDQ, LDC, LWORK, INFO +* .. +* .. Array Arguments .. +* COMPLEX Q( LDQ, * ), C( LDC, * ), WORK( * ) +* .. +* +*> \par Purpose +* ============ +*> +*> \verbatim +*> +*> CUNM22 overwrites the general complex M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'C': Q**H * C C * Q**H +*> +*> where Q is a complex unitary matrix of order NQ, with NQ = M if +*> SIDE = 'L' and NQ = N if SIDE = 'R'. +*> The unitary matrix Q processes a 2-by-2 block structure +*> +*> [ Q11 Q12 ] +*> Q = [ ] +*> [ Q21 Q22 ], +*> +*> where Q12 is an N1-by-N1 lower triangular matrix and Q21 is an +*> N2-by-N2 upper triangular matrix. +*> \endverbatim +* +* Arguments +* ========= +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**H from the Left; +*> = 'R': apply Q or Q**H from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply Q (No transpose); +*> = 'C': apply Q**H (Conjugate transpose). +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] N1 +*> \param[in] N2 +*> \verbatim +*> N1 is INTEGER +*> N2 is INTEGER +*> The dimension of Q12 and Q21, respectively. N1, N2 >= 0. +*> The following requirement must be satisfied: +*> N1 + N2 = M if SIDE = 'L' and N1 + N2 = N if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is COMPLEX array, dimension +*> (LDQ,M) if SIDE = 'L' +*> (LDQ,N) if SIDE = 'R' +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. +*> LDQ >= max(1,M) if SIDE = 'L'; LDQ >= max(1,N) if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \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 dimension of the array WORK. +*> If SIDE = 'L', LWORK >= max(1,N); +*> if SIDE = 'R', LWORK >= max(1,M). +*> For optimum performance LWORK >= M*N. +*> +*> 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 January 2015 +* +*> \ingroup complexOTHERcomputational +* +* ===================================================================== + SUBROUTINE CUNM22( SIDE, TRANS, M, N, N1, N2, Q, LDQ, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2015 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER M, N, N1, N2, LDQ, LDC, LWORK, INFO +* .. +* .. Array Arguments .. + COMPLEX Q( LDQ, * ), C( LDC, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ONE + PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) +* +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + INTEGER I, LDWORK, LEN, LWKOPT, NB, NQ, NW +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CGEMM, CLACPY, CTRMM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CMPLX, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q; +* NW is the minimum dimension of WORK. +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + NW = NQ + IF( N1.EQ.0 .OR. N2.EQ.0 ) NW = 1 + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) + $ THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( N1.LT.0 .OR. N1+N2.NE.NQ ) THEN + INFO = -5 + ELSE IF( N2.LT.0 ) THEN + INFO = -6 + ELSE IF( LDQ.LT.MAX( 1, NQ ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN + LWKOPT = M*N + WORK( 1 ) = CMPLX( LWKOPT ) + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CUNM22', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* Degenerate cases (N1 = 0 or N2 = 0) are handled using CTRMM. +* + IF( N1.EQ.0 ) THEN + CALL CTRMM( SIDE, 'Upper', TRANS, 'Non-Unit', M, N, ONE, + $ Q, LDQ, C, LDC ) + WORK( 1 ) = ONE + RETURN + ELSE IF( N2.EQ.0 ) THEN + CALL CTRMM( SIDE, 'Lower', TRANS, 'Non-Unit', M, N, ONE, + $ Q, LDQ, C, LDC ) + WORK( 1 ) = ONE + RETURN + END IF +* +* Compute the largest chunk size available from the workspace. +* + NB = MAX( 1, MIN( LWORK, LWKOPT ) / NQ ) +* + IF( LEFT ) THEN + IF( NOTRAN ) THEN + DO I = 1, N, NB + LEN = MIN( NB, N-I+1 ) + LDWORK = M +* +* Multiply bottom part of C by Q12. +* + CALL CLACPY( 'All', N1, LEN, C( N2+1, I ), LDC, WORK, + $ LDWORK ) + CALL CTRMM( 'Left', 'Lower', 'No Transpose', 'Non-Unit', + $ N1, LEN, ONE, Q( 1, N2+1 ), LDQ, WORK, + $ LDWORK ) +* +* Multiply top part of C by Q11. +* + CALL CGEMM( 'No Transpose', 'No Transpose', N1, LEN, N2, + $ ONE, Q, LDQ, C( 1, I ), LDC, ONE, WORK, + $ LDWORK ) +* +* Multiply top part of C by Q21. +* + CALL CLACPY( 'All', N2, LEN, C( 1, I ), LDC, + $ WORK( N1+1 ), LDWORK ) + CALL CTRMM( 'Left', 'Upper', 'No Transpose', 'Non-Unit', + $ N2, LEN, ONE, Q( N1+1, 1 ), LDQ, + $ WORK( N1+1 ), LDWORK ) +* +* Multiply bottom part of C by Q22. +* + CALL CGEMM( 'No Transpose', 'No Transpose', N2, LEN, N1, + $ ONE, Q( N1+1, N2+1 ), LDQ, C( N2+1, I ), LDC, + $ ONE, WORK( N1+1 ), LDWORK ) +* +* Copy everything back. +* + CALL CLACPY( 'All', M, LEN, WORK, LDWORK, C( 1, I ), + $ LDC ) + END DO + ELSE + DO I = 1, N, NB + LEN = MIN( NB, N-I+1 ) + LDWORK = M +* +* Multiply bottom part of C by Q21**H. +* + CALL CLACPY( 'All', N2, LEN, C( N1+1, I ), LDC, WORK, + $ LDWORK ) + CALL CTRMM( 'Left', 'Upper', 'Conjugate', 'Non-Unit', + $ N2, LEN, ONE, Q( N1+1, 1 ), LDQ, WORK, + $ LDWORK ) +* +* Multiply top part of C by Q11**H. +* + CALL CGEMM( 'Conjugate', 'No Transpose', N2, LEN, N1, + $ ONE, Q, LDQ, C( 1, I ), LDC, ONE, WORK, + $ LDWORK ) +* +* Multiply top part of C by Q12**H. +* + CALL CLACPY( 'All', N1, LEN, C( 1, I ), LDC, + $ WORK( N2+1 ), LDWORK ) + CALL CTRMM( 'Left', 'Lower', 'Conjugate', 'Non-Unit', + $ N1, LEN, ONE, Q( 1, N2+1 ), LDQ, + $ WORK( N2+1 ), LDWORK ) +* +* Multiply bottom part of C by Q22**H. +* + CALL CGEMM( 'Conjugate', 'No Transpose', N1, LEN, N2, + $ ONE, Q( N1+1, N2+1 ), LDQ, C( N1+1, I ), LDC, + $ ONE, WORK( N2+1 ), LDWORK ) +* +* Copy everything back. +* + CALL CLACPY( 'All', M, LEN, WORK, LDWORK, C( 1, I ), + $ LDC ) + END DO + END IF + ELSE + IF( NOTRAN ) THEN + DO I = 1, M, NB + LEN = MIN( NB, M-I+1 ) + LDWORK = LEN +* +* Multiply right part of C by Q21. +* + CALL CLACPY( 'All', LEN, N2, C( I, N1+1 ), LDC, WORK, + $ LDWORK ) + CALL CTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', + $ LEN, N2, ONE, Q( N1+1, 1 ), LDQ, WORK, + $ LDWORK ) +* +* Multiply left part of C by Q11. +* + CALL CGEMM( 'No Transpose', 'No Transpose', LEN, N2, N1, + $ ONE, C( I, 1 ), LDC, Q, LDQ, ONE, WORK, + $ LDWORK ) +* +* Multiply left part of C by Q12. +* + CALL CLACPY( 'All', LEN, N1, C( I, 1 ), LDC, + $ WORK( 1 + N2*LDWORK ), LDWORK ) + CALL CTRMM( 'Right', 'Lower', 'No Transpose', 'Non-Unit', + $ LEN, N1, ONE, Q( 1, N2+1 ), LDQ, + $ WORK( 1 + N2*LDWORK ), LDWORK ) +* +* Multiply right part of C by Q22. +* + CALL CGEMM( 'No Transpose', 'No Transpose', LEN, N1, N2, + $ ONE, C( I, N1+1 ), LDC, Q( N1+1, N2+1 ), LDQ, + $ ONE, WORK( 1 + N2*LDWORK ), LDWORK ) +* +* Copy everything back. +* + CALL CLACPY( 'All', LEN, N, WORK, LDWORK, C( I, 1 ), + $ LDC ) + END DO + ELSE + DO I = 1, M, NB + LEN = MIN( NB, M-I+1 ) + LDWORK = LEN +* +* Multiply right part of C by Q12**H. +* + CALL CLACPY( 'All', LEN, N1, C( I, N2+1 ), LDC, WORK, + $ LDWORK ) + CALL CTRMM( 'Right', 'Lower', 'Conjugate', 'Non-Unit', + $ LEN, N1, ONE, Q( 1, N2+1 ), LDQ, WORK, + $ LDWORK ) +* +* Multiply left part of C by Q11**H. +* + CALL CGEMM( 'No Transpose', 'Conjugate', LEN, N1, N2, + $ ONE, C( I, 1 ), LDC, Q, LDQ, ONE, WORK, + $ LDWORK ) +* +* Multiply left part of C by Q21**H. +* + CALL CLACPY( 'All', LEN, N2, C( I, 1 ), LDC, + $ WORK( 1 + N1*LDWORK ), LDWORK ) + CALL CTRMM( 'Right', 'Upper', 'Conjugate', 'Non-Unit', + $ LEN, N2, ONE, Q( N1+1, 1 ), LDQ, + $ WORK( 1 + N1*LDWORK ), LDWORK ) +* +* Multiply right part of C by Q22**H. +* + CALL CGEMM( 'No Transpose', 'Conjugate', LEN, N2, N1, + $ ONE, C( I, N2+1 ), LDC, Q( N1+1, N2+1 ), LDQ, + $ ONE, WORK( 1 + N1*LDWORK ), LDWORK ) +* +* Copy everything back. +* + CALL CLACPY( 'All', LEN, N, WORK, LDWORK, C( I, 1 ), + $ LDC ) + END DO + END IF + END IF +* + WORK( 1 ) = CMPLX( LWKOPT ) + RETURN +* +* End of CUNM22 +* + END diff --git a/SRC/dgges3.f b/SRC/dgges3.f new file mode 100644 index 0000000..41d2ea0 --- /dev/null +++ b/SRC/dgges3.f @@ -0,0 +1,674 @@ +*> \brief DGGES3 computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices (blocked algorithm) +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGGES3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGGES3( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, +* SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, +* LDVSR, WORK, LWORK, BWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBVSL, JOBVSR, SORT +* INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM +* .. +* .. Array Arguments .. +* LOGICAL BWORK( * ) +* DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), +* $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), +* $ VSR( LDVSR, * ), WORK( * ) +* .. +* .. Function Arguments .. +* LOGICAL SELCTG +* EXTERNAL SELCTG +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGGES3 computes for a pair of N-by-N real nonsymmetric matrices (A,B), +*> the generalized eigenvalues, the generalized real Schur form (S,T), +*> optionally, the left and/or right matrices of Schur vectors (VSL and +*> VSR). This gives the generalized Schur factorization +*> +*> (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T ) +*> +*> Optionally, it also orders the eigenvalues so that a selected cluster +*> of eigenvalues appears in the leading diagonal blocks of the upper +*> quasi-triangular matrix S and the upper triangular matrix T.The +*> leading columns of VSL and VSR then form an orthonormal basis for the +*> corresponding left and right eigenspaces (deflating subspaces). +*> +*> (If only the generalized eigenvalues are needed, use the driver +*> DGGEV instead, which is faster.) +*> +*> A generalized eigenvalue for a pair of matrices (A,B) is a scalar w +*> or a ratio alpha/beta = w, such that A - w*B is singular. It is +*> usually represented as the pair (alpha,beta), as there is a +*> reasonable interpretation for beta=0 or both being zero. +*> +*> A pair of matrices (S,T) is in generalized real Schur form if T is +*> upper triangular with non-negative diagonal and S is block upper +*> triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond +*> to real generalized eigenvalues, while 2-by-2 blocks of S will be +*> "standardized" by making the corresponding elements of T have the +*> form: +*> [ a 0 ] +*> [ 0 b ] +*> +*> and the pair of corresponding 2-by-2 blocks in S and T will have a +*> complex conjugate pair of generalized eigenvalues. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBVSL +*> \verbatim +*> JOBVSL is CHARACTER*1 +*> = 'N': do not compute the left Schur vectors; +*> = 'V': compute the left Schur vectors. +*> \endverbatim +*> +*> \param[in] JOBVSR +*> \verbatim +*> JOBVSR is CHARACTER*1 +*> = 'N': do not compute the right Schur vectors; +*> = 'V': compute the right Schur vectors. +*> \endverbatim +*> +*> \param[in] SORT +*> \verbatim +*> SORT is CHARACTER*1 +*> Specifies whether or not to order the eigenvalues on the +*> diagonal of the generalized Schur form. +*> = 'N': Eigenvalues are not ordered; +*> = 'S': Eigenvalues are ordered (see SELCTG); +*> \endverbatim +*> +*> \param[in] SELCTG +*> \verbatim +*> SELCTG is a LOGICAL FUNCTION of three DOUBLE PRECISION arguments +*> SELCTG must be declared EXTERNAL in the calling subroutine. +*> If SORT = 'N', SELCTG is not referenced. +*> If SORT = 'S', SELCTG is used to select eigenvalues to sort +*> to the top left of the Schur form. +*> An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if +*> SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either +*> one of a complex conjugate pair of eigenvalues is selected, +*> then both complex eigenvalues are selected. +*> +*> Note that in the ill-conditioned case, a selected complex +*> eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j), +*> BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2 +*> in this case. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A, B, VSL, and VSR. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the first of the pair of matrices. +*> On exit, A has been overwritten by its generalized Schur +*> form S. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB, N) +*> On entry, the second of the pair of matrices. +*> On exit, B has been overwritten by its generalized Schur +*> form T. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] SDIM +*> \verbatim +*> SDIM is INTEGER +*> If SORT = 'N', SDIM = 0. +*> If SORT = 'S', SDIM = number of eigenvalues (after sorting) +*> for which SELCTG is true. (Complex conjugate pairs for which +*> SELCTG is true for either eigenvalue count as 2.) +*> \endverbatim +*> +*> \param[out] ALPHAR +*> \verbatim +*> ALPHAR is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] ALPHAI +*> \verbatim +*> ALPHAI is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION array, dimension (N) +*> On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will +*> be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i, +*> and BETA(j),j=1,...,N are the diagonals of the complex Schur +*> form (S,T) that would result if the 2-by-2 diagonal blocks of +*> the real Schur form of (A,B) were further reduced to +*> triangular form using 2-by-2 complex unitary transformations. +*> If ALPHAI(j) is zero, then the j-th eigenvalue is real; if +*> positive, then the j-th and (j+1)-st eigenvalues are a +*> complex conjugate pair, with ALPHAI(j+1) negative. +*> +*> Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) +*> may easily over- or underflow, and BETA(j) may even be zero. +*> Thus, the user should avoid naively computing the ratio. +*> However, ALPHAR and ALPHAI will be always less than and +*> usually comparable with norm(A) in magnitude, and BETA always +*> less than and usually comparable with norm(B). +*> \endverbatim +*> +*> \param[out] VSL +*> \verbatim +*> VSL is DOUBLE PRECISION array, dimension (LDVSL,N) +*> If JOBVSL = 'V', VSL will contain the left Schur vectors. +*> Not referenced if JOBVSL = 'N'. +*> \endverbatim +*> +*> \param[in] LDVSL +*> \verbatim +*> LDVSL is INTEGER +*> The leading dimension of the matrix VSL. LDVSL >=1, and +*> if JOBVSL = 'V', LDVSL >= N. +*> \endverbatim +*> +*> \param[out] VSR +*> \verbatim +*> VSR is DOUBLE PRECISION array, dimension (LDVSR,N) +*> If JOBVSR = 'V', VSR will contain the right Schur vectors. +*> Not referenced if JOBVSR = 'N'. +*> \endverbatim +*> +*> \param[in] LDVSR +*> \verbatim +*> LDVSR is INTEGER +*> The leading dimension of the matrix VSR. LDVSR >= 1, and +*> if JOBVSR = 'V', LDVSR >= 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 dimension of the array WORK. +*> +*> 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] BWORK +*> \verbatim +*> BWORK is LOGICAL array, dimension (N) +*> Not referenced if SORT = 'N'. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> = 1,...,N: +*> The QZ iteration failed. (A,B) are not in Schur +*> form, but ALPHAR(j), ALPHAI(j), and BETA(j) should +*> be correct for j=INFO+1,...,N. +*> > N: =N+1: other than QZ iteration failed in DHGEQZ. +*> =N+2: after reordering, roundoff changed values of +*> some complex eigenvalues so that leading +*> eigenvalues in the Generalized Schur form no +*> longer satisfy SELCTG=.TRUE. This could also +*> be caused due to scaling. +*> =N+3: reordering failed in DTGSEN. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date January 2015 +* +*> \ingroup doubleGEeigen +* +* ===================================================================== + SUBROUTINE DGGES3( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, + $ LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, + $ VSR, LDVSR, WORK, LWORK, BWORK, INFO ) +* +* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2015 +* +* .. Scalar Arguments .. + CHARACTER JOBVSL, JOBVSR, SORT + INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM +* .. +* .. Array Arguments .. + LOGICAL BWORK( * ) + DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), + $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), + $ VSR( LDVSR, * ), WORK( * ) +* .. +* .. Function Arguments .. + LOGICAL SELCTG + EXTERNAL SELCTG +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL, + $ LQUERY, LST2SL, WANTST + INTEGER I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, + $ ILO, IP, IRIGHT, IROWS, ITAU, IWRK, LWKOPT + DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL, + $ PVSR, SAFMAX, SAFMIN, SMLNUM +* .. +* .. Local Arrays .. + INTEGER IDUM( 1 ) + DOUBLE PRECISION DIF( 2 ) +* .. +* .. External Subroutines .. + EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHD3, DHGEQZ, DLABAD, + $ DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGSEN, + $ XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL LSAME, DLAMCH, DLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Decode the input arguments +* + IF( LSAME( JOBVSL, 'N' ) ) THEN + IJOBVL = 1 + ILVSL = .FALSE. + ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN + IJOBVL = 2 + ILVSL = .TRUE. + ELSE + IJOBVL = -1 + ILVSL = .FALSE. + END IF +* + IF( LSAME( JOBVSR, 'N' ) ) THEN + IJOBVR = 1 + ILVSR = .FALSE. + ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN + IJOBVR = 2 + ILVSR = .TRUE. + ELSE + IJOBVR = -1 + ILVSR = .FALSE. + END IF +* + WANTST = LSAME( SORT, 'S' ) +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( IJOBVL.LE.0 ) THEN + INFO = -1 + ELSE IF( IJOBVR.LE.0 ) THEN + INFO = -2 + ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN + INFO = -15 + ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN + INFO = -17 + ELSE IF( LWORK.LT.6*N+16 .AND. .NOT.LQUERY ) THEN + INFO = -19 + END IF +* +* Compute workspace +* + IF( INFO.EQ.0 ) THEN + CALL DGEQRF( N, N, B, LDB, WORK, WORK, -1, IERR ) + LWKOPT = MAX( 6*N+16, 3*N+INT( WORK ( 1 ) ) ) + CALL DORMQR( 'L', 'T', N, N, N, B, LDB, WORK, A, LDA, WORK, + $ -1, IERR ) + LWKOPT = MAX( LWKOPT, 3*N+INT( WORK ( 1 ) ) ) + IF( ILVSL ) THEN + CALL DORGQR( N, N, N, VSL, LDVSL, WORK, WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, 3*N+INT( WORK ( 1 ) ) ) + END IF + CALL DGGHD3( JOBVSL, JOBVSR, N, 1, N, A, LDA, B, LDB, VSL, + $ LDVSL, VSR, LDVSR, WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, 3*N+INT( WORK ( 1 ) ) ) + CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, 1, N, A, LDA, B, LDB, + $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, + $ WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, 2*N+INT( WORK ( 1 ) ) ) + IF( WANTST ) THEN + CALL DTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, + $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, + $ SDIM, PVSL, PVSR, DIF, WORK, -1, IDUM, 1, + $ IERR ) + LWKOPT = MAX( LWKOPT, 2*N+INT( WORK ( 1 ) ) ) + END IF + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGGES3 ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + SDIM = 0 + RETURN + END IF +* +* Get machine constants +* + EPS = DLAMCH( 'P' ) + SAFMIN = DLAMCH( 'S' ) + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + SMLNUM = SQRT( SAFMIN ) / EPS + BIGNUM = ONE / SMLNUM +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = DLANGE( 'M', N, N, A, LDA, WORK ) + ILASCL = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + ANRMTO = SMLNUM + ILASCL = .TRUE. + ELSE IF( ANRM.GT.BIGNUM ) THEN + ANRMTO = BIGNUM + ILASCL = .TRUE. + END IF + IF( ILASCL ) + $ CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR ) +* +* Scale B if max element outside range [SMLNUM,BIGNUM] +* + BNRM = DLANGE( 'M', N, N, B, LDB, WORK ) + ILBSCL = .FALSE. + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN + BNRMTO = SMLNUM + ILBSCL = .TRUE. + ELSE IF( BNRM.GT.BIGNUM ) THEN + BNRMTO = BIGNUM + ILBSCL = .TRUE. + END IF + IF( ILBSCL ) + $ CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR ) +* +* Permute the matrix to make it more nearly triangular +* + ILEFT = 1 + IRIGHT = N + 1 + IWRK = IRIGHT + N + CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ), + $ WORK( IRIGHT ), WORK( IWRK ), IERR ) +* +* Reduce B to triangular form (QR decomposition of B) +* + IROWS = IHI + 1 - ILO + ICOLS = N + 1 - ILO + ITAU = IWRK + IWRK = ITAU + IROWS + CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) +* +* Apply the orthogonal transformation to matrix A +* + CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, + $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), + $ LWORK+1-IWRK, IERR ) +* +* Initialize VSL +* + IF( ILVSL ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL ) + IF( IROWS.GT.1 ) THEN + CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, + $ VSL( ILO+1, ILO ), LDVSL ) + END IF + CALL DORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL, + $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR ) + END IF +* +* Initialize VSR +* + IF( ILVSR ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR ) +* +* Reduce to generalized Hessenberg form +* + CALL DGGHD3( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, + $ LDVSL, VSR, LDVSR, WORK( IWRK ), LWORK+1-IWRK, + $ IERR ) +* +* Perform QZ algorithm, computing Schur vectors if desired +* + IWRK = ITAU + CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, + $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.GT.0 .AND. IERR.LE.N ) THEN + INFO = IERR + ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN + INFO = IERR - N + ELSE + INFO = N + 1 + END IF + GO TO 50 + END IF +* +* Sort eigenvalues ALPHA/BETA if desired +* + SDIM = 0 + IF( WANTST ) THEN +* +* Undo scaling on eigenvalues before SELCTGing +* + IF( ILASCL ) THEN + CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, + $ IERR ) + CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, + $ IERR ) + END IF + IF( ILBSCL ) + $ CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) +* +* Select eigenvalues +* + DO 10 I = 1, N + BWORK( I ) = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) ) + 10 CONTINUE +* + CALL DTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, ALPHAR, + $ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PVSL, + $ PVSR, DIF, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1, + $ IERR ) + IF( IERR.EQ.1 ) + $ INFO = N + 3 +* + END IF +* +* Apply back-permutation to VSL and VSR +* + IF( ILVSL ) + $ CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ), + $ WORK( IRIGHT ), N, VSL, LDVSL, IERR ) +* + IF( ILVSR ) + $ CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ), + $ WORK( IRIGHT ), N, VSR, LDVSR, IERR ) +* +* Check if unscaling would cause over/underflow, if so, rescale +* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of +* B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I) +* + IF( ILASCL ) THEN + DO 20 I = 1, N + IF( ALPHAI( I ).NE.ZERO ) THEN + IF( ( ALPHAR( I ) / SAFMAX ).GT.( ANRMTO / ANRM ) .OR. + $ ( SAFMIN / ALPHAR( I ) ).GT.( ANRM / ANRMTO ) ) THEN + WORK( 1 ) = ABS( A( I, I ) / ALPHAR( I ) ) + BETA( I ) = BETA( I )*WORK( 1 ) + ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) + ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) + ELSE IF( ( ALPHAI( I ) / SAFMAX ).GT. + $ ( ANRMTO / ANRM ) .OR. + $ ( SAFMIN / ALPHAI( I ) ).GT.( ANRM / ANRMTO ) ) + $ THEN + WORK( 1 ) = ABS( A( I, I+1 ) / ALPHAI( I ) ) + BETA( I ) = BETA( I )*WORK( 1 ) + ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) + ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) + END IF + END IF + 20 CONTINUE + END IF +* + IF( ILBSCL ) THEN + DO 30 I = 1, N + IF( ALPHAI( I ).NE.ZERO ) THEN + IF( ( BETA( I ) / SAFMAX ).GT.( BNRMTO / BNRM ) .OR. + $ ( SAFMIN / BETA( I ) ).GT.( BNRM / BNRMTO ) ) THEN + WORK( 1 ) = ABS( B( I, I ) / BETA( I ) ) + BETA( I ) = BETA( I )*WORK( 1 ) + ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) + ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) + END IF + END IF + 30 CONTINUE + END IF +* +* Undo scaling +* + IF( ILASCL ) THEN + CALL DLASCL( 'H', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR ) + CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR ) + CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR ) + END IF +* + IF( ILBSCL ) THEN + CALL DLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR ) + CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) + END IF +* + IF( WANTST ) THEN +* +* Check if reordering is correct +* + LASTSL = .TRUE. + LST2SL = .TRUE. + SDIM = 0 + IP = 0 + DO 40 I = 1, N + CURSL = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) ) + IF( ALPHAI( I ).EQ.ZERO ) THEN + IF( CURSL ) + $ SDIM = SDIM + 1 + IP = 0 + IF( CURSL .AND. .NOT.LASTSL ) + $ INFO = N + 2 + ELSE + IF( IP.EQ.1 ) THEN +* +* Last eigenvalue of conjugate pair +* + CURSL = CURSL .OR. LASTSL + LASTSL = CURSL + IF( CURSL ) + $ SDIM = SDIM + 2 + IP = -1 + IF( CURSL .AND. .NOT.LST2SL ) + $ INFO = N + 2 + ELSE +* +* First eigenvalue of conjugate pair +* + IP = 1 + END IF + END IF + LST2SL = LASTSL + LASTSL = CURSL + 40 CONTINUE +* + END IF +* + 50 CONTINUE +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DGGES3 +* + END diff --git a/SRC/dggev3.f b/SRC/dggev3.f new file mode 100644 index 0000000..43a853d --- /dev/null +++ b/SRC/dggev3.f @@ -0,0 +1,594 @@ +*> \brief DGGEV3 computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices (blocked algorithm) +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGGEV3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGGEV3( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, +* $ ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, +* $ INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBVL, JOBVR +* INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), +* $ B( LDB, * ), BETA( * ), VL( LDVL, * ), +* $ VR( LDVR, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGGEV3 computes for a pair of N-by-N real nonsymmetric matrices (A,B) +*> the generalized eigenvalues, and optionally, the left and/or right +*> generalized eigenvectors. +*> +*> A generalized eigenvalue for a pair of matrices (A,B) is a scalar +*> lambda or a ratio alpha/beta = lambda, such that A - lambda*B is +*> singular. It is usually represented as the pair (alpha,beta), as +*> there is a reasonable interpretation for beta=0, and even for both +*> being zero. +*> +*> The right eigenvector v(j) corresponding to the eigenvalue lambda(j) +*> of (A,B) satisfies +*> +*> A * v(j) = lambda(j) * B * v(j). +*> +*> The left eigenvector u(j) corresponding to the eigenvalue lambda(j) +*> of (A,B) satisfies +*> +*> u(j)**H * A = lambda(j) * u(j)**H * B . +*> +*> where u(j)**H is the conjugate-transpose of u(j). +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBVL +*> \verbatim +*> JOBVL is CHARACTER*1 +*> = 'N': do not compute the left generalized eigenvectors; +*> = 'V': compute the left generalized eigenvectors. +*> \endverbatim +*> +*> \param[in] JOBVR +*> \verbatim +*> JOBVR is CHARACTER*1 +*> = 'N': do not compute the right generalized eigenvectors; +*> = 'V': compute the right generalized eigenvectors. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A, B, VL, and VR. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the matrix A in the pair (A,B). +*> On exit, A has been overwritten. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB, N) +*> On entry, the matrix B in the pair (A,B). +*> On exit, B has been overwritten. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] ALPHAR +*> \verbatim +*> ALPHAR is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] ALPHAI +*> \verbatim +*> ALPHAI is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION array, dimension (N) +*> On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will +*> be the generalized eigenvalues. If ALPHAI(j) is zero, then +*> the j-th eigenvalue is real; if positive, then the j-th and +*> (j+1)-st eigenvalues are a complex conjugate pair, with +*> ALPHAI(j+1) negative. +*> +*> Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) +*> may easily over- or underflow, and BETA(j) may even be zero. +*> Thus, the user should avoid naively computing the ratio +*> alpha/beta. However, ALPHAR and ALPHAI will be always less +*> than and usually comparable with norm(A) in magnitude, and +*> BETA always less than and usually comparable with norm(B). +*> \endverbatim +*> +*> \param[out] VL +*> \verbatim +*> VL is DOUBLE PRECISION array, dimension (LDVL,N) +*> If JOBVL = 'V', the left eigenvectors u(j) are stored one +*> after another in the columns of VL, in the same order as +*> their eigenvalues. If the j-th eigenvalue is real, then +*> u(j) = VL(:,j), the j-th column of VL. If the j-th and +*> (j+1)-th eigenvalues form a complex conjugate pair, then +*> u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1). +*> Each eigenvector is scaled so the largest component has +*> abs(real part)+abs(imag. part)=1. +*> Not referenced if JOBVL = 'N'. +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of the matrix VL. LDVL >= 1, and +*> if JOBVL = 'V', LDVL >= N. +*> \endverbatim +*> +*> \param[out] VR +*> \verbatim +*> VR is DOUBLE PRECISION array, dimension (LDVR,N) +*> If JOBVR = 'V', the right eigenvectors v(j) are stored one +*> after another in the columns of VR, in the same order as +*> their eigenvalues. If the j-th eigenvalue is real, then +*> v(j) = VR(:,j), the j-th column of VR. If the j-th and +*> (j+1)-th eigenvalues form a complex conjugate pair, then +*> v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1). +*> Each eigenvector is scaled so the largest component has +*> abs(real part)+abs(imag. part)=1. +*> Not referenced if JOBVR = 'N'. +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the matrix VR. LDVR >= 1, and +*> if JOBVR = 'V', LDVR >= 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 +*> +*> 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. +*> = 1,...,N: +*> The QZ iteration failed. No eigenvectors have been +*> calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) +*> should be correct for j=INFO+1,...,N. +*> > N: =N+1: other than QZ iteration failed in DHGEQZ. +*> =N+2: error return from DTGEVC. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date January 2015 +* +*> \ingroup doubleGEeigen +* +* ===================================================================== + SUBROUTINE DGGEV3( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, + $ ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, + $ INFO ) +* +* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2015 +* +* .. Scalar Arguments .. + CHARACTER JOBVL, JOBVR + INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), + $ B( LDB, * ), BETA( * ), VL( LDVL, * ), + $ VR( LDVR, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY + CHARACTER CHTEMP + INTEGER ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO, + $ IN, IRIGHT, IROWS, ITAU, IWRK, JC, JR, LWKOPT + DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, + $ SMLNUM, TEMP +* .. +* .. Local Arrays .. + LOGICAL LDUMMA( 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHD3, DHGEQZ, DLABAD, + $ DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGEVC, + $ XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL LSAME, DLAMCH, DLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Decode the input arguments +* + IF( LSAME( JOBVL, 'N' ) ) THEN + IJOBVL = 1 + ILVL = .FALSE. + ELSE IF( LSAME( JOBVL, 'V' ) ) THEN + IJOBVL = 2 + ILVL = .TRUE. + ELSE + IJOBVL = -1 + ILVL = .FALSE. + END IF +* + IF( LSAME( JOBVR, 'N' ) ) THEN + IJOBVR = 1 + ILVR = .FALSE. + ELSE IF( LSAME( JOBVR, 'V' ) ) THEN + IJOBVR = 2 + ILVR = .TRUE. + ELSE + IJOBVR = -1 + ILVR = .FALSE. + END IF + ILV = ILVL .OR. ILVR +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( IJOBVL.LE.0 ) THEN + INFO = -1 + ELSE IF( IJOBVR.LE.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN + INFO = -12 + ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN + INFO = -14 + ELSE IF( LWORK.LT.MAX( 1, 8*N ) .AND. .NOT.LQUERY ) THEN + INFO = -16 + END IF +* +* Compute workspace +* + IF( INFO.EQ.0 ) THEN + CALL DGEQRF( N, N, B, LDB, WORK, WORK, -1, IERR ) + LWKOPT = MAX(1, 8*N, 3*N+INT( WORK( 1 ) ) ) + CALL DORMQR( 'L', 'T', N, N, N, B, LDB, WORK, A, LDA, WORK, -1, + $ IERR ) + LWKOPT = MAX( LWKOPT, 3*N+INT( WORK ( 1 ) ) ) + IF( ILVL ) THEN + CALL DORGQR( N, N, N, VL, LDVL, WORK, WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, 3*N+INT( WORK ( 1 ) ) ) + END IF + IF( ILV ) THEN + CALL DGGHD3( JOBVL, JOBVR, N, 1, N, A, LDA, B, LDB, VL, + $ LDVL, VR, LDVR, WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, 3*N+INT( WORK ( 1 ) ) ) + CALL DHGEQZ( 'S', JOBVL, JOBVR, N, 1, N, A, LDA, B, LDB, + $ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, + $ WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, 2*N+INT( WORK ( 1 ) ) ) + ELSE + CALL DGGHD3( 'N', 'N', N, 1, N, A, LDA, B, LDB, VL, LDVL, + $ VR, LDVR, WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, 3*N+INT( WORK ( 1 ) ) ) + CALL DHGEQZ( 'E', JOBVL, JOBVR, N, 1, N, A, LDA, B, LDB, + $ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, + $ WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, 2*N+INT( WORK ( 1 ) ) ) + END IF + + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGGEV3 ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Get machine constants +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SQRT( SMLNUM ) / EPS + BIGNUM = ONE / SMLNUM +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = DLANGE( 'M', N, N, A, LDA, WORK ) + ILASCL = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + ANRMTO = SMLNUM + ILASCL = .TRUE. + ELSE IF( ANRM.GT.BIGNUM ) THEN + ANRMTO = BIGNUM + ILASCL = .TRUE. + END IF + IF( ILASCL ) + $ CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR ) +* +* Scale B if max element outside range [SMLNUM,BIGNUM] +* + BNRM = DLANGE( 'M', N, N, B, LDB, WORK ) + ILBSCL = .FALSE. + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN + BNRMTO = SMLNUM + ILBSCL = .TRUE. + ELSE IF( BNRM.GT.BIGNUM ) THEN + BNRMTO = BIGNUM + ILBSCL = .TRUE. + END IF + IF( ILBSCL ) + $ CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR ) +* +* Permute the matrices A, B to isolate eigenvalues if possible +* + ILEFT = 1 + IRIGHT = N + 1 + IWRK = IRIGHT + N + CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ), + $ WORK( IRIGHT ), WORK( IWRK ), IERR ) +* +* Reduce B to triangular form (QR decomposition of B) +* + IROWS = IHI + 1 - ILO + IF( ILV ) THEN + ICOLS = N + 1 - ILO + ELSE + ICOLS = IROWS + END IF + ITAU = IWRK + IWRK = ITAU + IROWS + CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) +* +* Apply the orthogonal transformation to matrix A +* + CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, + $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), + $ LWORK+1-IWRK, IERR ) +* +* Initialize VL +* + IF( ILVL ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, VL, LDVL ) + IF( IROWS.GT.1 ) THEN + CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, + $ VL( ILO+1, ILO ), LDVL ) + END IF + CALL DORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL, + $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR ) + END IF +* +* Initialize VR +* + IF( ILVR ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, VR, LDVR ) +* +* Reduce to generalized Hessenberg form +* + IF( ILV ) THEN +* +* Eigenvectors requested -- work on whole matrix. +* + CALL DGGHD3( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL, + $ LDVL, VR, LDVR, WORK( IWRK ), LWORK+1-IWRK, IERR ) + ELSE + CALL DGGHD3( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA, + $ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) + END IF +* +* Perform QZ algorithm (Compute eigenvalues, and optionally, the +* Schur forms and Schur vectors) +* + IWRK = ITAU + IF( ILV ) THEN + CHTEMP = 'S' + ELSE + CHTEMP = 'E' + END IF + CALL DHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, + $ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.GT.0 .AND. IERR.LE.N ) THEN + INFO = IERR + ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN + INFO = IERR - N + ELSE + INFO = N + 1 + END IF + GO TO 110 + END IF +* +* Compute Eigenvectors +* + IF( ILV ) THEN + IF( ILVL ) THEN + IF( ILVR ) THEN + CHTEMP = 'B' + ELSE + CHTEMP = 'L' + END IF + ELSE + CHTEMP = 'R' + END IF + CALL DTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL, + $ VR, LDVR, N, IN, WORK( IWRK ), IERR ) + IF( IERR.NE.0 ) THEN + INFO = N + 2 + GO TO 110 + END IF +* +* Undo balancing on VL and VR and normalization +* + IF( ILVL ) THEN + CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ), + $ WORK( IRIGHT ), N, VL, LDVL, IERR ) + DO 50 JC = 1, N + IF( ALPHAI( JC ).LT.ZERO ) + $ GO TO 50 + TEMP = ZERO + IF( ALPHAI( JC ).EQ.ZERO ) THEN + DO 10 JR = 1, N + TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) ) + 10 CONTINUE + ELSE + DO 20 JR = 1, N + TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+ + $ ABS( VL( JR, JC+1 ) ) ) + 20 CONTINUE + END IF + IF( TEMP.LT.SMLNUM ) + $ GO TO 50 + TEMP = ONE / TEMP + IF( ALPHAI( JC ).EQ.ZERO ) THEN + DO 30 JR = 1, N + VL( JR, JC ) = VL( JR, JC )*TEMP + 30 CONTINUE + ELSE + DO 40 JR = 1, N + VL( JR, JC ) = VL( JR, JC )*TEMP + VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP + 40 CONTINUE + END IF + 50 CONTINUE + END IF + IF( ILVR ) THEN + CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ), + $ WORK( IRIGHT ), N, VR, LDVR, IERR ) + DO 100 JC = 1, N + IF( ALPHAI( JC ).LT.ZERO ) + $ GO TO 100 + TEMP = ZERO + IF( ALPHAI( JC ).EQ.ZERO ) THEN + DO 60 JR = 1, N + TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) ) + 60 CONTINUE + ELSE + DO 70 JR = 1, N + TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+ + $ ABS( VR( JR, JC+1 ) ) ) + 70 CONTINUE + END IF + IF( TEMP.LT.SMLNUM ) + $ GO TO 100 + TEMP = ONE / TEMP + IF( ALPHAI( JC ).EQ.ZERO ) THEN + DO 80 JR = 1, N + VR( JR, JC ) = VR( JR, JC )*TEMP + 80 CONTINUE + ELSE + DO 90 JR = 1, N + VR( JR, JC ) = VR( JR, JC )*TEMP + VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP + 90 CONTINUE + END IF + 100 CONTINUE + END IF +* +* End of eigenvector calculation +* + END IF +* +* Undo scaling if necessary +* + 110 CONTINUE +* + IF( ILASCL ) THEN + CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR ) + CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR ) + END IF +* + IF( ILBSCL ) THEN + CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) + END IF +* + WORK( 1 ) = LWKOPT + RETURN +* +* End of DGGEV3 +* + END diff --git a/SRC/dgghd3.f b/SRC/dgghd3.f new file mode 100644 index 0000000..7bed5cc --- /dev/null +++ b/SRC/dgghd3.f @@ -0,0 +1,898 @@ +*> \brief \b DGGHD3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGGHD3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGGHD3( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, +* LDQ, Z, LDZ, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER COMPQ, COMPZ +* INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N, LWORK +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), +* $ Z( LDZ, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGGHD3 reduces a pair of real matrices (A,B) to generalized upper +*> Hessenberg form using orthogonal transformations, where A is a +*> general matrix and B is upper triangular. The form of the +*> generalized eigenvalue problem is +*> A*x = lambda*B*x, +*> and B is typically made upper triangular by computing its QR +*> factorization and moving the orthogonal matrix Q to the left side +*> of the equation. +*> +*> This subroutine simultaneously reduces A to a Hessenberg matrix H: +*> Q**T*A*Z = H +*> and transforms B to another upper triangular matrix T: +*> Q**T*B*Z = T +*> in order to reduce the problem to its standard form +*> H*y = lambda*T*y +*> where y = Z**T*x. +*> +*> The orthogonal matrices Q and Z are determined as products of Givens +*> rotations. They may either be formed explicitly, or they may be +*> postmultiplied into input matrices Q1 and Z1, so that +*> +*> Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T +*> +*> Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T +*> +*> If Q1 is the orthogonal matrix from the QR factorization of B in the +*> original equation A*x = lambda*B*x, then DGGHD3 reduces the original +*> problem to generalized Hessenberg form. +*> +*> This is a blocked variant of DGGHRD, using matrix-matrix +*> multiplications for parts of the computation to enhance performance. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] COMPQ +*> \verbatim +*> COMPQ is CHARACTER*1 +*> = 'N': do not compute Q; +*> = 'I': Q is initialized to the unit matrix, and the +*> orthogonal matrix Q is returned; +*> = 'V': Q must contain an orthogonal matrix Q1 on entry, +*> and the product Q1*Q is returned. +*> \endverbatim +*> +*> \param[in] COMPZ +*> \verbatim +*> COMPZ is CHARACTER*1 +*> = 'N': do not compute Z; +*> = 'I': Z is initialized to the unit matrix, and the +*> orthogonal matrix Z is returned; +*> = 'V': Z must contain an orthogonal matrix Z1 on entry, +*> and the product Z1*Z is returned. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> +*> ILO and IHI mark the rows and columns of A which are to be +*> reduced. It is assumed that A is already upper triangular +*> in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are +*> normally set by a previous call to DGGBAL; otherwise they +*> should be set to 1 and N respectively. +*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the N-by-N general matrix to be reduced. +*> On exit, the upper triangle and the first subdiagonal of A +*> are overwritten with the upper Hessenberg matrix H, and the +*> rest is set to zero. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB, N) +*> On entry, the N-by-N upper triangular matrix B. +*> On exit, the upper triangular matrix T = Q**T B Z. The +*> elements below the diagonal are set to zero. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ, N) +*> On entry, if COMPQ = 'V', the orthogonal matrix Q1, +*> typically from the QR factorization of B. +*> On exit, if COMPQ='I', the orthogonal matrix Q, and if +*> COMPQ = 'V', the product Q1*Q. +*> Not referenced if COMPQ='N'. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. +*> LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, N) +*> On entry, if COMPZ = 'V', the orthogonal matrix Z1. +*> On exit, if COMPZ='I', the orthogonal matrix Z, and if +*> COMPZ = 'V', the product Z1*Z. +*> Not referenced if COMPZ='N'. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. +*> LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1. +*> For optimum performance LWORK >= 6*N*NB, where NB is the +*> optimal blocksize. +*> +*> 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 January 2015 +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> This routine reduces A to Hessenberg form and maintains B in +*> using a blocked variant of Moler and Stewart's original algorithm, +*> as described by Kagstrom, Kressner, Quintana-Orti, and Quintana-Orti +*> (BIT 2008). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGGHD3( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, + $ LDQ, Z, LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2015 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ + INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N, LWORK +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), + $ Z( LDZ, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL BLK22, INITQ, INITZ, LQUERY, WANTQ, WANTZ + CHARACTER*1 COMPQ2, COMPZ2 + INTEGER COLA, I, IERR, J, J0, JCOL, JJ, JROW, K, + $ KACC22, LEN, LWKOPT, N2NB, NB, NBLST, NBMIN, + $ NH, NNB, NX, PPW, PPWO, PW, TOP, TOPQ + DOUBLE PRECISION C, C1, C2, S, S1, S2, TEMP, TEMP1, TEMP2, TEMP3 +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGGHRD, DLARTG, DLASET, DORM22, DROT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters. +* + INFO = 0 + NB = ILAENV( 1, 'DGGHD3', ' ', N, ILO, IHI, -1 ) + LWKOPT = 6*N*NB + WORK( 1 ) = DBLE( LWKOPT ) + INITQ = LSAME( COMPQ, 'I' ) + WANTQ = INITQ .OR. LSAME( COMPQ, 'V' ) + INITZ = LSAME( COMPZ, 'I' ) + WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) + LQUERY = ( LWORK.EQ.-1 ) +* + IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( ILO.LT.1 ) THEN + INFO = -4 + ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( ( WANTQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN + INFO = -11 + ELSE IF( ( WANTZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN + INFO = -13 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -15 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGGHD3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Initialize Q and Z if desired. +* + IF( INITQ ) + $ CALL DLASET( 'All', N, N, ZERO, ONE, Q, LDQ ) + IF( INITZ ) + $ CALL DLASET( 'All', N, N, ZERO, ONE, Z, LDZ ) +* +* Zero out lower triangle of B. +* + IF( N.GT.1 ) + $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, B(2, 1), LDB ) +* +* Quick return if possible +* + NH = IHI - ILO + 1 + IF( NH.LE.1 ) THEN + WORK( 1 ) = ONE + RETURN + END IF +* +* Determine the blocksize. +* + NBMIN = ILAENV( 2, 'DGGHD3', ' ', N, ILO, IHI, -1 ) + IF( NB.GT.1 .AND. NB.LT.NH ) THEN +* +* Determine when to use unblocked instead of blocked code. +* + NX = MAX( NB, ILAENV( 3, 'DGGHD3', ' ', N, ILO, IHI, -1 ) ) + IF( NX.LT.NH ) THEN +* +* Determine if workspace is large enough for blocked code. +* + IF( LWORK.LT.LWKOPT ) THEN +* +* Not enough workspace to use optimal NB: determine the +* minimum value of NB, and reduce NB or force use of +* unblocked code. +* + NBMIN = MAX( 2, ILAENV( 2, 'DGGHD3', ' ', N, ILO, IHI, + $ -1 ) ) + IF( LWORK.GE.6*N*NBMIN ) THEN + NB = LWORK / ( 6*N ) + ELSE + NB = 1 + END IF + END IF + END IF + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN +* +* Use unblocked code below +* + JCOL = ILO +* + ELSE +* +* Use blocked code +* + KACC22 = ILAENV( 16, 'DGGHD3', ' ', N, ILO, IHI, -1 ) + BLK22 = KACC22.EQ.2 + DO JCOL = ILO, IHI-2, NB + NNB = MIN( NB, IHI-JCOL-1 ) +* +* Initialize small orthogonal factors that will hold the +* accumulated Givens rotations in workspace. +* N2NB denotes the number of 2*NNB-by-2*NNB factors +* NBLST denotes the (possibly smaller) order of the last +* factor. +* + N2NB = ( IHI-JCOL-1 ) / NNB - 1 + NBLST = IHI - JCOL - N2NB*NNB + CALL DLASET( 'All', NBLST, NBLST, ZERO, ONE, WORK, NBLST ) + PW = NBLST * NBLST + 1 + DO I = 1, N2NB + CALL DLASET( 'All', 2*NNB, 2*NNB, ZERO, ONE, + $ WORK( PW ), 2*NNB ) + PW = PW + 4*NNB*NNB + END DO +* +* Reduce columns JCOL:JCOL+NNB-1 of A to Hessenberg form. +* + DO J = JCOL, JCOL+NNB-1 +* +* Reduce Jth column of A. Store cosines and sines in Jth +* column of A and B, respectively. +* + DO I = IHI, J+2, -1 + TEMP = A( I-1, J ) + CALL DLARTG( TEMP, A( I, J ), C, S, A( I-1, J ) ) + A( I, J ) = C + B( I, J ) = S + END DO +* +* Accumulate Givens rotations into workspace array. +* + PPW = ( NBLST + 1 )*( NBLST - 2 ) - J + JCOL + 1 + LEN = 2 + J - JCOL + JROW = J + N2NB*NNB + 2 + DO I = IHI, JROW, -1 + C = A( I, J ) + S = B( I, J ) + DO JJ = PPW, PPW+LEN-1 + TEMP = WORK( JJ + NBLST ) + WORK( JJ + NBLST ) = C*TEMP - S*WORK( JJ ) + WORK( JJ ) = S*TEMP + C*WORK( JJ ) + END DO + LEN = LEN + 1 + PPW = PPW - NBLST - 1 + END DO +* + PPWO = NBLST*NBLST + ( NNB+J-JCOL-1 )*2*NNB + NNB + J0 = JROW - NNB + DO JROW = J0, J+2, -NNB + PPW = PPWO + LEN = 2 + J - JCOL + DO I = JROW+NNB-1, JROW, -1 + C = A( I, J ) + S = B( I, J ) + DO JJ = PPW, PPW+LEN-1 + TEMP = WORK( JJ + 2*NNB ) + WORK( JJ + 2*NNB ) = C*TEMP - S*WORK( JJ ) + WORK( JJ ) = S*TEMP + C*WORK( JJ ) + END DO + LEN = LEN + 1 + PPW = PPW - 2*NNB - 1 + END DO + PPWO = PPWO + 4*NNB*NNB + END DO +* +* TOP denotes the number of top rows in A and B that will +* not be updated during the next steps. +* + IF( JCOL.LE.2 ) THEN + TOP = 0 + ELSE + TOP = JCOL + END IF +* +* Propagate transformations through B and replace stored +* left sines/cosines by right sines/cosines. +* + DO JJ = N, J+1, -1 +* +* Update JJth column of B. +* + DO I = MIN( JJ+1, IHI ), J+2, -1 + C = A( I, J ) + S = B( I, J ) + TEMP = B( I, JJ ) + B( I, JJ ) = C*TEMP - S*B( I-1, JJ ) + B( I-1, JJ ) = S*TEMP + C*B( I-1, JJ ) + END DO +* +* Annihilate B( JJ+1, JJ ). +* + IF( JJ.LT.IHI ) THEN + TEMP = B( JJ+1, JJ+1 ) + CALL DLARTG( TEMP, B( JJ+1, JJ ), C, S, + $ B( JJ+1, JJ+1 ) ) + B( JJ+1, JJ ) = ZERO + CALL DROT( JJ-TOP, B( TOP+1, JJ+1 ), 1, + $ B( TOP+1, JJ ), 1, C, S ) + A( JJ+1, J ) = C + B( JJ+1, J ) = -S + END IF + END DO +* +* Update A by transformations from right. +* Explicit loop unrolling provides better performance +* compared to DLASR. +* CALL DLASR( 'Right', 'Variable', 'Backward', IHI-TOP, +* $ IHI-J, A( J+2, J ), B( J+2, J ), +* $ A( TOP+1, J+1 ), LDA ) +* + JJ = MOD( IHI-J-1, 3 ) + DO I = IHI-J-3, JJ+1, -3 + C = A( J+1+I, J ) + S = -B( J+1+I, J ) + C1 = A( J+2+I, J ) + S1 = -B( J+2+I, J ) + C2 = A( J+3+I, J ) + S2 = -B( J+3+I, J ) +* + DO K = TOP+1, IHI + TEMP = A( K, J+I ) + TEMP1 = A( K, J+I+1 ) + TEMP2 = A( K, J+I+2 ) + TEMP3 = A( K, J+I+3 ) + A( K, J+I+3 ) = C2*TEMP3 + S2*TEMP2 + TEMP2 = -S2*TEMP3 + C2*TEMP2 + A( K, J+I+2 ) = C1*TEMP2 + S1*TEMP1 + TEMP1 = -S1*TEMP2 + C1*TEMP1 + A( K, J+I+1 ) = C*TEMP1 + S*TEMP + A( K, J+I ) = -S*TEMP1 + C*TEMP + END DO + END DO +* + IF( JJ.GT.0 ) THEN + DO I = JJ, 1, -1 + CALL DROT( IHI-TOP, A( TOP+1, J+I+1 ), 1, + $ A( TOP+1, J+I ), 1, A( J+1+I, J ), + $ -B( J+1+I, J ) ) + END DO + END IF +* +* Update (J+1)th column of A by transformations from left. +* + IF ( J .LT. JCOL + NNB - 1 ) THEN + LEN = 1 + J - JCOL +* +* Multiply with the trailing accumulated orthogonal +* matrix, which takes the form +* +* [ U11 U12 ] +* U = [ ], +* [ U21 U22 ] +* +* where U21 is a LEN-by-LEN matrix and U12 is lower +* triangular. +* + JROW = IHI - NBLST + 1 + CALL DGEMV( 'Transpose', NBLST, LEN, ONE, WORK, + $ NBLST, A( JROW, J+1 ), 1, ZERO, + $ WORK( PW ), 1 ) + PPW = PW + LEN + DO I = JROW, JROW+NBLST-LEN-1 + WORK( PPW ) = A( I, J+1 ) + PPW = PPW + 1 + END DO + CALL DTRMV( 'Lower', 'Transpose', 'Non-unit', + $ NBLST-LEN, WORK( LEN*NBLST + 1 ), NBLST, + $ WORK( PW+LEN ), 1 ) + CALL DGEMV( 'Transpose', LEN, NBLST-LEN, ONE, + $ WORK( (LEN+1)*NBLST - LEN + 1 ), NBLST, + $ A( JROW+NBLST-LEN, J+1 ), 1, ONE, + $ WORK( PW+LEN ), 1 ) + PPW = PW + DO I = JROW, JROW+NBLST-1 + A( I, J+1 ) = WORK( PPW ) + PPW = PPW + 1 + END DO +* +* Multiply with the other accumulated orthogonal +* matrices, which take the form +* +* [ U11 U12 0 ] +* [ ] +* U = [ U21 U22 0 ], +* [ ] +* [ 0 0 I ] +* +* where I denotes the (NNB-LEN)-by-(NNB-LEN) identity +* matrix, U21 is a LEN-by-LEN upper triangular matrix +* and U12 is an NNB-by-NNB lower triangular matrix. +* + PPWO = 1 + NBLST*NBLST + J0 = JROW - NNB + DO JROW = J0, JCOL+1, -NNB + PPW = PW + LEN + DO I = JROW, JROW+NNB-1 + WORK( PPW ) = A( I, J+1 ) + PPW = PPW + 1 + END DO + PPW = PW + DO I = JROW+NNB, JROW+NNB+LEN-1 + WORK( PPW ) = A( I, J+1 ) + PPW = PPW + 1 + END DO + CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', LEN, + $ WORK( PPWO + NNB ), 2*NNB, WORK( PW ), + $ 1 ) + CALL DTRMV( 'Lower', 'Transpose', 'Non-unit', NNB, + $ WORK( PPWO + 2*LEN*NNB ), + $ 2*NNB, WORK( PW + LEN ), 1 ) + CALL DGEMV( 'Transpose', NNB, LEN, ONE, + $ WORK( PPWO ), 2*NNB, A( JROW, J+1 ), 1, + $ ONE, WORK( PW ), 1 ) + CALL DGEMV( 'Transpose', LEN, NNB, ONE, + $ WORK( PPWO + 2*LEN*NNB + NNB ), 2*NNB, + $ A( JROW+NNB, J+1 ), 1, ONE, + $ WORK( PW+LEN ), 1 ) + PPW = PW + DO I = JROW, JROW+LEN+NNB-1 + A( I, J+1 ) = WORK( PPW ) + PPW = PPW + 1 + END DO + PPWO = PPWO + 4*NNB*NNB + END DO + END IF + END DO +* +* Apply accumulated orthogonal matrices to A. +* + COLA = N - JCOL - NNB + 1 + J = IHI - NBLST + 1 + CALL DGEMM( 'Transpose', 'No Transpose', NBLST, + $ COLA, NBLST, ONE, WORK, NBLST, + $ A( J, JCOL+NNB ), LDA, ZERO, WORK( PW ), + $ NBLST ) + CALL DLACPY( 'All', NBLST, COLA, WORK( PW ), NBLST, + $ A( J, JCOL+NNB ), LDA ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( BLK22 ) THEN +* +* Exploit the structure of +* +* [ U11 U12 ] +* U = [ ] +* [ U21 U22 ], +* +* where all blocks are NNB-by-NNB, U21 is upper +* triangular and U12 is lower triangular. +* + CALL DORM22( 'Left', 'Transpose', 2*NNB, COLA, NNB, + $ NNB, WORK( PPWO ), 2*NNB, + $ A( J, JCOL+NNB ), LDA, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL DGEMM( 'Transpose', 'No Transpose', 2*NNB, + $ COLA, 2*NNB, ONE, WORK( PPWO ), 2*NNB, + $ A( J, JCOL+NNB ), LDA, ZERO, WORK( PW ), + $ 2*NNB ) + CALL DLACPY( 'All', 2*NNB, COLA, WORK( PW ), 2*NNB, + $ A( J, JCOL+NNB ), LDA ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO +* +* Apply accumulated orthogonal matrices to Q. +* + IF( WANTQ ) THEN + J = IHI - NBLST + 1 + IF ( INITQ ) THEN + TOPQ = MAX( 2, J - JCOL + 1 ) + NH = IHI - TOPQ + 1 + ELSE + TOPQ = 1 + NH = N + END IF + CALL DGEMM( 'No Transpose', 'No Transpose', NH, + $ NBLST, NBLST, ONE, Q( TOPQ, J ), LDQ, + $ WORK, NBLST, ZERO, WORK( PW ), NH ) + CALL DLACPY( 'All', NH, NBLST, WORK( PW ), NH, + $ Q( TOPQ, J ), LDQ ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( INITQ ) THEN + TOPQ = MAX( 2, J - JCOL + 1 ) + NH = IHI - TOPQ + 1 + END IF + IF ( BLK22 ) THEN +* +* Exploit the structure of U. +* + CALL DORM22( 'Right', 'No Transpose', NH, 2*NNB, + $ NNB, NNB, WORK( PPWO ), 2*NNB, + $ Q( TOPQ, J ), LDQ, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL DGEMM( 'No Transpose', 'No Transpose', NH, + $ 2*NNB, 2*NNB, ONE, Q( TOPQ, J ), LDQ, + $ WORK( PPWO ), 2*NNB, ZERO, WORK( PW ), + $ NH ) + CALL DLACPY( 'All', NH, 2*NNB, WORK( PW ), NH, + $ Q( TOPQ, J ), LDQ ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO + END IF +* +* Accumulate right Givens rotations if required. +* + IF ( WANTZ .OR. TOP.GT.0 ) THEN +* +* Initialize small orthogonal factors that will hold the +* accumulated Givens rotations in workspace. +* + CALL DLASET( 'All', NBLST, NBLST, ZERO, ONE, WORK, + $ NBLST ) + PW = NBLST * NBLST + 1 + DO I = 1, N2NB + CALL DLASET( 'All', 2*NNB, 2*NNB, ZERO, ONE, + $ WORK( PW ), 2*NNB ) + PW = PW + 4*NNB*NNB + END DO +* +* Accumulate Givens rotations into workspace array. +* + DO J = JCOL, JCOL+NNB-1 + PPW = ( NBLST + 1 )*( NBLST - 2 ) - J + JCOL + 1 + LEN = 2 + J - JCOL + JROW = J + N2NB*NNB + 2 + DO I = IHI, JROW, -1 + C = A( I, J ) + A( I, J ) = ZERO + S = B( I, J ) + B( I, J ) = ZERO + DO JJ = PPW, PPW+LEN-1 + TEMP = WORK( JJ + NBLST ) + WORK( JJ + NBLST ) = C*TEMP - S*WORK( JJ ) + WORK( JJ ) = S*TEMP + C*WORK( JJ ) + END DO + LEN = LEN + 1 + PPW = PPW - NBLST - 1 + END DO +* + PPWO = NBLST*NBLST + ( NNB+J-JCOL-1 )*2*NNB + NNB + J0 = JROW - NNB + DO JROW = J0, J+2, -NNB + PPW = PPWO + LEN = 2 + J - JCOL + DO I = JROW+NNB-1, JROW, -1 + C = A( I, J ) + A( I, J ) = ZERO + S = B( I, J ) + B( I, J ) = ZERO + DO JJ = PPW, PPW+LEN-1 + TEMP = WORK( JJ + 2*NNB ) + WORK( JJ + 2*NNB ) = C*TEMP - S*WORK( JJ ) + WORK( JJ ) = S*TEMP + C*WORK( JJ ) + END DO + LEN = LEN + 1 + PPW = PPW - 2*NNB - 1 + END DO + PPWO = PPWO + 4*NNB*NNB + END DO + END DO + ELSE + + DO J = ILO, ILO+NNB + DO I = J+2, IHI + A( I, J ) = ZERO + B( I, J ) = ZERO + END DO + END DO + END IF +* +* Apply accumulated orthogonal matrices to A and B. +* + IF ( TOP.GT.0 ) THEN + J = IHI - NBLST + 1 + CALL DGEMM( 'No Transpose', 'No Transpose', TOP, + $ NBLST, NBLST, ONE, A( 1, J ), LDA, + $ WORK, NBLST, ZERO, WORK( PW ), TOP ) + CALL DLACPY( 'All', TOP, NBLST, WORK( PW ), TOP, + $ A( 1, J ), LDA ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( BLK22 ) THEN +* +* Exploit the structure of U. +* + CALL DORM22( 'Right', 'No Transpose', TOP, 2*NNB, + $ NNB, NNB, WORK( PPWO ), 2*NNB, + $ A( 1, J ), LDA, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL DGEMM( 'No Transpose', 'No Transpose', TOP, + $ 2*NNB, 2*NNB, ONE, A( 1, J ), LDA, + $ WORK( PPWO ), 2*NNB, ZERO, + $ WORK( PW ), TOP ) + CALL DLACPY( 'All', TOP, 2*NNB, WORK( PW ), TOP, + $ A( 1, J ), LDA ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO +* + J = IHI - NBLST + 1 + CALL DGEMM( 'No Transpose', 'No Transpose', TOP, + $ NBLST, NBLST, ONE, B( 1, J ), LDB, + $ WORK, NBLST, ZERO, WORK( PW ), TOP ) + CALL DLACPY( 'All', TOP, NBLST, WORK( PW ), TOP, + $ B( 1, J ), LDB ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( BLK22 ) THEN +* +* Exploit the structure of U. +* + CALL DORM22( 'Right', 'No Transpose', TOP, 2*NNB, + $ NNB, NNB, WORK( PPWO ), 2*NNB, + $ B( 1, J ), LDA, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL DGEMM( 'No Transpose', 'No Transpose', TOP, + $ 2*NNB, 2*NNB, ONE, B( 1, J ), LDB, + $ WORK( PPWO ), 2*NNB, ZERO, + $ WORK( PW ), TOP ) + CALL DLACPY( 'All', TOP, 2*NNB, WORK( PW ), TOP, + $ B( 1, J ), LDB ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO + END IF +* +* Apply accumulated orthogonal matrices to Z. +* + IF( WANTZ ) THEN + J = IHI - NBLST + 1 + IF ( INITQ ) THEN + TOPQ = MAX( 2, J - JCOL + 1 ) + NH = IHI - TOPQ + 1 + ELSE + TOPQ = 1 + NH = N + END IF + CALL DGEMM( 'No Transpose', 'No Transpose', NH, + $ NBLST, NBLST, ONE, Z( TOPQ, J ), LDZ, + $ WORK, NBLST, ZERO, WORK( PW ), NH ) + CALL DLACPY( 'All', NH, NBLST, WORK( PW ), NH, + $ Z( TOPQ, J ), LDZ ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( INITQ ) THEN + TOPQ = MAX( 2, J - JCOL + 1 ) + NH = IHI - TOPQ + 1 + END IF + IF ( BLK22 ) THEN +* +* Exploit the structure of U. +* + CALL DORM22( 'Right', 'No Transpose', NH, 2*NNB, + $ NNB, NNB, WORK( PPWO ), 2*NNB, + $ Z( TOPQ, J ), LDZ, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL DGEMM( 'No Transpose', 'No Transpose', NH, + $ 2*NNB, 2*NNB, ONE, Z( TOPQ, J ), LDZ, + $ WORK( PPWO ), 2*NNB, ZERO, WORK( PW ), + $ NH ) + CALL DLACPY( 'All', NH, 2*NNB, WORK( PW ), NH, + $ Z( TOPQ, J ), LDZ ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO + END IF + END DO + END IF +* +* Use unblocked code to reduce the rest of the matrix +* Avoid re-initialization of modified Q and Z. +* + COMPQ2 = COMPQ + COMPZ2 = COMPZ + IF ( JCOL.NE.ILO ) THEN + IF ( WANTQ ) + $ COMPQ2 = 'V' + IF ( WANTZ ) + $ COMPZ2 = 'V' + END IF +* + IF ( JCOL.LT.IHI ) + $ CALL DGGHRD( COMPQ2, COMPZ2, N, JCOL, IHI, A, LDA, B, LDB, Q, + $ LDQ, Z, LDZ, IERR ) + WORK( 1 ) = DBLE( LWKOPT ) +* + RETURN +* +* End of DGGHD3 +* + END diff --git a/SRC/dorm22.f b/SRC/dorm22.f new file mode 100644 index 0000000..ac79e1e --- /dev/null +++ b/SRC/dorm22.f @@ -0,0 +1,441 @@ +*> \brief \b DORM22 multiplies a general matrix by a banded orthogonal matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DORM22 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DORM22( SIDE, TRANS, M, N, N1, N2, Q, LDQ, C, LDC, +* $ WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER M, N, N1, N2, LDQ, LDC, LWORK, INFO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION Q( LDQ, * ), C( LDC, * ), WORK( * ) +* .. +* +*> \par Purpose +* ============ +*> +*> \verbatim +*> +*> +*> DORM22 overwrites the general real M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'T': Q**T * C C * Q**T +*> +*> where Q is a real orthogonal matrix of order NQ, with NQ = M if +*> SIDE = 'L' and NQ = N if SIDE = 'R'. +*> The orthogonal matrix Q processes a 2-by-2 block structure +*> +*> [ Q11 Q12 ] +*> Q = [ ] +*> [ Q21 Q22 ], +*> +*> where Q12 is an N1-by-N1 lower triangular matrix and Q21 is an +*> N2-by-N2 upper triangular matrix. +*> \endverbatim +* +* Arguments +* ========= +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply Q (No transpose); +*> = 'C': apply Q**T (Conjugate transpose). +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] N1 +*> \param[in] N2 +*> \verbatim +*> N1 is INTEGER +*> N2 is INTEGER +*> The dimension of Q12 and Q21, respectively. N1, N2 >= 0. +*> The following requirement must be satisfied: +*> N1 + N2 = M if SIDE = 'L' and N1 + N2 = N if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension +*> (LDQ,M) if SIDE = 'L' +*> (LDQ,N) if SIDE = 'R' +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. +*> LDQ >= max(1,M) if SIDE = 'L'; LDQ >= max(1,N) if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \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 dimension of the array WORK. +*> If SIDE = 'L', LWORK >= max(1,N); +*> if SIDE = 'R', LWORK >= max(1,M). +*> For optimum performance LWORK >= M*N. +*> +*> 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 January 2015 +* +*> \ingroup complexOTHERcomputational +* +* ===================================================================== + SUBROUTINE DORM22( SIDE, TRANS, M, N, N1, N2, Q, LDQ, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2015 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER M, N, N1, N2, LDQ, LDC, LWORK, INFO +* .. +* .. Array Arguments .. + DOUBLE PRECISION Q( LDQ, * ), C( LDC, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + INTEGER I, LDWORK, LEN, LWKOPT, NB, NQ, NW +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DTRMM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q; +* NW is the minimum dimension of WORK. +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + NW = NQ + IF( N1.EQ.0 .OR. N2.EQ.0 ) NW = 1 + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) ) + $ THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( N1.LT.0 .OR. N1+N2.NE.NQ ) THEN + INFO = -5 + ELSE IF( N2.LT.0 ) THEN + INFO = -6 + ELSE IF( LDQ.LT.MAX( 1, NQ ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN + LWKOPT = M*N + WORK( 1 ) = DBLE( LWKOPT ) + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORM22', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* Degenerate cases (N1 = 0 or N2 = 0) are handled using DTRMM. +* + IF( N1.EQ.0 ) THEN + CALL DTRMM( SIDE, 'Upper', TRANS, 'Non-Unit', M, N, ONE, + $ Q, LDQ, C, LDC ) + WORK( 1 ) = ONE + RETURN + ELSE IF( N2.EQ.0 ) THEN + CALL DTRMM( SIDE, 'Lower', TRANS, 'Non-Unit', M, N, ONE, + $ Q, LDQ, C, LDC ) + WORK( 1 ) = ONE + RETURN + END IF +* +* Compute the largest chunk size available from the workspace. +* + NB = MAX( 1, MIN( LWORK, LWKOPT ) / NQ ) +* + IF( LEFT ) THEN + IF( NOTRAN ) THEN + DO I = 1, N, NB + LEN = MIN( NB, N-I+1 ) + LDWORK = M +* +* Multiply bottom part of C by Q12. +* + CALL DLACPY( 'All', N1, LEN, C( N2+1, I ), LDC, WORK, + $ LDWORK ) + CALL DTRMM( 'Left', 'Lower', 'No Transpose', 'Non-Unit', + $ N1, LEN, ONE, Q( 1, N2+1 ), LDQ, WORK, + $ LDWORK ) +* +* Multiply top part of C by Q11. +* + CALL DGEMM( 'No Transpose', 'No Transpose', N1, LEN, N2, + $ ONE, Q, LDQ, C( 1, I ), LDC, ONE, WORK, + $ LDWORK ) +* +* Multiply top part of C by Q21. +* + CALL DLACPY( 'All', N2, LEN, C( 1, I ), LDC, + $ WORK( N1+1 ), LDWORK ) + CALL DTRMM( 'Left', 'Upper', 'No Transpose', 'Non-Unit', + $ N2, LEN, ONE, Q( N1+1, 1 ), LDQ, + $ WORK( N1+1 ), LDWORK ) +* +* Multiply bottom part of C by Q22. +* + CALL DGEMM( 'No Transpose', 'No Transpose', N2, LEN, N1, + $ ONE, Q( N1+1, N2+1 ), LDQ, C( N2+1, I ), LDC, + $ ONE, WORK( N1+1 ), LDWORK ) +* +* Copy everything back. +* + CALL DLACPY( 'All', M, LEN, WORK, LDWORK, C( 1, I ), + $ LDC ) + END DO + ELSE + DO I = 1, N, NB + LEN = MIN( NB, N-I+1 ) + LDWORK = M +* +* Multiply bottom part of C by Q21**T. +* + CALL DLACPY( 'All', N2, LEN, C( N1+1, I ), LDC, WORK, + $ LDWORK ) + CALL DTRMM( 'Left', 'Upper', 'Transpose', 'Non-Unit', + $ N2, LEN, ONE, Q( N1+1, 1 ), LDQ, WORK, + $ LDWORK ) +* +* Multiply top part of C by Q11**T. +* + CALL DGEMM( 'Transpose', 'No Transpose', N2, LEN, N1, + $ ONE, Q, LDQ, C( 1, I ), LDC, ONE, WORK, + $ LDWORK ) +* +* Multiply top part of C by Q12**T. +* + CALL DLACPY( 'All', N1, LEN, C( 1, I ), LDC, + $ WORK( N2+1 ), LDWORK ) + CALL DTRMM( 'Left', 'Lower', 'Transpose', 'Non-Unit', + $ N1, LEN, ONE, Q( 1, N2+1 ), LDQ, + $ WORK( N2+1 ), LDWORK ) +* +* Multiply bottom part of C by Q22**T. +* + CALL DGEMM( 'Transpose', 'No Transpose', N1, LEN, N2, + $ ONE, Q( N1+1, N2+1 ), LDQ, C( N1+1, I ), LDC, + $ ONE, WORK( N2+1 ), LDWORK ) +* +* Copy everything back. +* + CALL DLACPY( 'All', M, LEN, WORK, LDWORK, C( 1, I ), + $ LDC ) + END DO + END IF + ELSE + IF( NOTRAN ) THEN + DO I = 1, M, NB + LEN = MIN( NB, M-I+1 ) + LDWORK = LEN +* +* Multiply right part of C by Q21. +* + CALL DLACPY( 'All', LEN, N2, C( I, N1+1 ), LDC, WORK, + $ LDWORK ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', + $ LEN, N2, ONE, Q( N1+1, 1 ), LDQ, WORK, + $ LDWORK ) +* +* Multiply left part of C by Q11. +* + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, N2, N1, + $ ONE, C( I, 1 ), LDC, Q, LDQ, ONE, WORK, + $ LDWORK ) +* +* Multiply left part of C by Q12. +* + CALL DLACPY( 'All', LEN, N1, C( I, 1 ), LDC, + $ WORK( 1 + N2*LDWORK ), LDWORK ) + CALL DTRMM( 'Right', 'Lower', 'No Transpose', 'Non-Unit', + $ LEN, N1, ONE, Q( 1, N2+1 ), LDQ, + $ WORK( 1 + N2*LDWORK ), LDWORK ) +* +* Multiply right part of C by Q22. +* + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, N1, N2, + $ ONE, C( I, N1+1 ), LDC, Q( N1+1, N2+1 ), LDQ, + $ ONE, WORK( 1 + N2*LDWORK ), LDWORK ) +* +* Copy everything back. +* + CALL DLACPY( 'All', LEN, N, WORK, LDWORK, C( I, 1 ), + $ LDC ) + END DO + ELSE + DO I = 1, M, NB + LEN = MIN( NB, M-I+1 ) + LDWORK = LEN +* +* Multiply right part of C by Q12**T. +* + CALL DLACPY( 'All', LEN, N1, C( I, N2+1 ), LDC, WORK, + $ LDWORK ) + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Non-Unit', + $ LEN, N1, ONE, Q( 1, N2+1 ), LDQ, WORK, + $ LDWORK ) +* +* Multiply left part of C by Q11**T. +* + CALL DGEMM( 'No Transpose', 'Transpose', LEN, N1, N2, + $ ONE, C( I, 1 ), LDC, Q, LDQ, ONE, WORK, + $ LDWORK ) +* +* Multiply left part of C by Q21**T. +* + CALL DLACPY( 'All', LEN, N2, C( I, 1 ), LDC, + $ WORK( 1 + N1*LDWORK ), LDWORK ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', + $ LEN, N2, ONE, Q( N1+1, 1 ), LDQ, + $ WORK( 1 + N1*LDWORK ), LDWORK ) +* +* Multiply right part of C by Q22**T. +* + CALL DGEMM( 'No Transpose', 'Transpose', LEN, N2, N1, + $ ONE, C( I, N2+1 ), LDC, Q( N1+1, N2+1 ), LDQ, + $ ONE, WORK( 1 + N1*LDWORK ), LDWORK ) +* +* Copy everything back. +* + CALL DLACPY( 'All', LEN, N, WORK, LDWORK, C( I, 1 ), + $ LDC ) + END DO + END IF + END IF +* + WORK( 1 ) = DBLE( LWKOPT ) + RETURN +* +* End of DORM22 +* + END diff --git a/SRC/ilaenv.f b/SRC/ilaenv.f index 867464d..010b5ed 100644 --- a/SRC/ilaenv.f +++ b/SRC/ilaenv.f @@ -82,7 +82,7 @@ *> =10: ieee NaN arithmetic can be trusted not to trap *> =11: infinity arithmetic can be trusted not to trap *> 12 <= ISPEC <= 16: -*> xHSEQR or one of its subroutines, +*> xHSEQR or related subroutines, *> see IPARMQ for detailed explanation *> \endverbatim *> @@ -410,6 +410,15 @@ IF( C3.EQ.'EBZ' ) THEN NB = 1 END IF + ELSE IF( C2.EQ.'GG' ) THEN + NB = 32 + IF( C3.EQ.'HD3' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + END IF END IF ILAENV = NB RETURN @@ -488,6 +497,11 @@ NBMIN = 2 END IF END IF + ELSE IF( C2.EQ.'GG' ) THEN + NBMIN = 2 + IF( C3.EQ.'HD3' ) THEN + NBMIN = 2 + END IF END IF ILAENV = NBMIN RETURN @@ -542,6 +556,11 @@ NX = 128 END IF END IF + ELSE IF( C2.EQ.'GG' ) THEN + NX = 128 + IF( C3.EQ.'HD3' ) THEN + NX = 128 + END IF END IF ILAENV = NX RETURN @@ -614,7 +633,7 @@ * 160 CONTINUE * -* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines. +* 12 <= ISPEC <= 16: xHSEQR or related subroutines. * ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) RETURN diff --git a/SRC/iparmq.f b/SRC/iparmq.f index bd5bd7a..581e1cb 100644 --- a/SRC/iparmq.f +++ b/SRC/iparmq.f @@ -31,7 +31,8 @@ *> \verbatim *> *> This program sets problem and machine dependent parameters -*> useful for xHSEQR and its subroutines. It is called whenever +*> useful for xHSEQR and related subroutines for eigenvalue +*> problems. It is called whenever *> ILAENV is called with 12 <= ISPEC <= 16 *> \endverbatim * @@ -75,19 +76,26 @@ *> *> ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the *> following meanings. -*> 0: During the multi-shift QR sweep, -*> xLAQR5 does not accumulate reflections and -*> does not use matrix-matrix multiply to -*> update the far-from-diagonal matrix -*> entries. -*> 1: During the multi-shift QR sweep, -*> xLAQR5 and/or xLAQRaccumulates reflections and uses -*> matrix-matrix multiply to update the +*> 0: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are not +*> accumulated when updating the *> far-from-diagonal matrix entries. -*> 2: During the multi-shift QR sweep. -*> xLAQR5 accumulates reflections and takes -*> advantage of 2-by-2 block structure during -*> matrix-matrix multiplies. +*> 1: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are +*> accumulated, and matrix-matrix +*> multiplication is used to update the +*> far-from-diagonal matrix entries. +*> 2: During the multi-shift QR/QZ sweep, +*> blocked eigenvalue reordering, blocked +*> Hessenberg-triangular reduction, +*> reflections and/or rotations are +*> accumulated, and 2-by-2 block structure +*> is exploited during matrix-matrix +*> multiplies. *> (If xTRMM is slower than xGEMM, then *> IPARMQ(ISPEC=16)=1 may be more efficient than *> IPARMQ(ISPEC=16)=2 despite the greater level of @@ -236,6 +244,8 @@ * .. * .. Local Scalars .. INTEGER NH, NS + INTEGER I, IC, IZ + CHARACTER SUBNAM*6 * .. * .. Intrinsic Functions .. INTRINSIC LOG, MAX, MOD, NINT, REAL @@ -305,11 +315,74 @@ * . by making this choice dependent also upon the * . NH=IHI-ILO+1. * - IPARMQ = 0 - IF( NS.GE.KACMIN ) - $ IPARMQ = 1 - IF( NS.GE.K22MIN ) - $ IPARMQ = 2 +* +* Convert NAME to upper case if the first character is lower case. +* + ILAENV = 0 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1: 1 ) ) + IZ = ICHAR( 'Z' ) + IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +* +* ASCII character set +* + IF( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + END DO + END IF +* + ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1: 1 ) = CHAR( IC+64 ) + DO I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: + $ I ) = CHAR( IC+64 ) + END DO + END IF +* + ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + END DO + END IF + END IF +* + IF( SUBNAM( 2:6 ).EQ.'GGHRD' .OR. + $ SUBNAM( 2:6 ).EQ.'GGHD3' ) THEN + IPARMQ = 1 + IF( NH.GE.K22MIN ) + $ IPARMQ = 2 + ELSE IF ( SUBNAM( 4:6 ).EQ.'EXC' ) THEN + IF( NH.GE.KACMIN ) + $ IPARMQ = 1 + IF( NH.GE.K22MIN ) + $ IPARMQ = 2 + ELSE IF ( SUBNAM( 2:6 ).EQ.'HSEQR' .OR. + $ SUBNAM( 2:5 ).EQ.'LAQR' ) THEN + IF( NS.GE.KACMIN ) + $ IPARMQ = 1 + IF( NS.GE.K22MIN ) + $ IPARMQ = 2 + END IF * ELSE * ===== invalid value of ispec ===== diff --git a/SRC/sgges3.f b/SRC/sgges3.f new file mode 100644 index 0000000..81ab96c --- /dev/null +++ b/SRC/sgges3.f @@ -0,0 +1,671 @@ +*> \brief SGGES3 computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices (blocked algorithm) +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SGGES3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SGGES3( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, +* $ LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, +* $ VSR, LDVSR, WORK, LWORK, BWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBVSL, JOBVSR, SORT +* INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM +* .. +* .. Array Arguments .. +* LOGICAL BWORK( * ) +* REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ), +* $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), +* $ VSR( LDVSR, * ), WORK( * ) +* .. +* .. Function Arguments .. +* LOGICAL SELCTG +* EXTERNAL SELCTG +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SGGES3 computes for a pair of N-by-N real nonsymmetric matrices (A,B), +*> the generalized eigenvalues, the generalized real Schur form (S,T), +*> optionally, the left and/or right matrices of Schur vectors (VSL and +*> VSR). This gives the generalized Schur factorization +*> +*> (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T ) +*> +*> Optionally, it also orders the eigenvalues so that a selected cluster +*> of eigenvalues appears in the leading diagonal blocks of the upper +*> quasi-triangular matrix S and the upper triangular matrix T.The +*> leading columns of VSL and VSR then form an orthonormal basis for the +*> corresponding left and right eigenspaces (deflating subspaces). +*> +*> (If only the generalized eigenvalues are needed, use the driver +*> SGGEV instead, which is faster.) +*> +*> A generalized eigenvalue for a pair of matrices (A,B) is a scalar w +*> or a ratio alpha/beta = w, such that A - w*B is singular. It is +*> usually represented as the pair (alpha,beta), as there is a +*> reasonable interpretation for beta=0 or both being zero. +*> +*> A pair of matrices (S,T) is in generalized real Schur form if T is +*> upper triangular with non-negative diagonal and S is block upper +*> triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond +*> to real generalized eigenvalues, while 2-by-2 blocks of S will be +*> "standardized" by making the corresponding elements of T have the +*> form: +*> [ a 0 ] +*> [ 0 b ] +*> +*> and the pair of corresponding 2-by-2 blocks in S and T will have a +*> complex conjugate pair of generalized eigenvalues. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBVSL +*> \verbatim +*> JOBVSL is CHARACTER*1 +*> = 'N': do not compute the left Schur vectors; +*> = 'V': compute the left Schur vectors. +*> \endverbatim +*> +*> \param[in] JOBVSR +*> \verbatim +*> JOBVSR is CHARACTER*1 +*> = 'N': do not compute the right Schur vectors; +*> = 'V': compute the right Schur vectors. +*> \endverbatim +*> +*> \param[in] SORT +*> \verbatim +*> SORT is CHARACTER*1 +*> Specifies whether or not to order the eigenvalues on the +*> diagonal of the generalized Schur form. +*> = 'N': Eigenvalues are not ordered; +*> = 'S': Eigenvalues are ordered (see SELCTG); +*> \endverbatim +*> +*> \param[in] SELCTG +*> \verbatim +*> SELCTG is a LOGICAL FUNCTION of three REAL arguments +*> SELCTG must be declared EXTERNAL in the calling subroutine. +*> If SORT = 'N', SELCTG is not referenced. +*> If SORT = 'S', SELCTG is used to select eigenvalues to sort +*> to the top left of the Schur form. +*> An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if +*> SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either +*> one of a complex conjugate pair of eigenvalues is selected, +*> then both complex eigenvalues are selected. +*> +*> Note that in the ill-conditioned case, a selected complex +*> eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j), +*> BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2 +*> in this case. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A, B, VSL, and VSR. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA, N) +*> On entry, the first of the pair of matrices. +*> On exit, A has been overwritten by its generalized Schur +*> form S. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB, N) +*> On entry, the second of the pair of matrices. +*> On exit, B has been overwritten by its generalized Schur +*> form T. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] SDIM +*> \verbatim +*> SDIM is INTEGER +*> If SORT = 'N', SDIM = 0. +*> If SORT = 'S', SDIM = number of eigenvalues (after sorting) +*> for which SELCTG is true. (Complex conjugate pairs for which +*> SELCTG is true for either eigenvalue count as 2.) +*> \endverbatim +*> +*> \param[out] ALPHAR +*> \verbatim +*> ALPHAR is REAL array, dimension (N) +*> \endverbatim +*> +*> \param[out] ALPHAI +*> \verbatim +*> ALPHAI is REAL array, dimension (N) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is REAL array, dimension (N) +*> On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will +*> be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i, +*> and BETA(j),j=1,...,N are the diagonals of the complex Schur +*> form (S,T) that would result if the 2-by-2 diagonal blocks of +*> the real Schur form of (A,B) were further reduced to +*> triangular form using 2-by-2 complex unitary transformations. +*> If ALPHAI(j) is zero, then the j-th eigenvalue is real; if +*> positive, then the j-th and (j+1)-st eigenvalues are a +*> complex conjugate pair, with ALPHAI(j+1) negative. +*> +*> Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) +*> may easily over- or underflow, and BETA(j) may even be zero. +*> Thus, the user should avoid naively computing the ratio. +*> However, ALPHAR and ALPHAI will be always less than and +*> usually comparable with norm(A) in magnitude, and BETA always +*> less than and usually comparable with norm(B). +*> \endverbatim +*> +*> \param[out] VSL +*> \verbatim +*> VSL is REAL array, dimension (LDVSL,N) +*> If JOBVSL = 'V', VSL will contain the left Schur vectors. +*> Not referenced if JOBVSL = 'N'. +*> \endverbatim +*> +*> \param[in] LDVSL +*> \verbatim +*> LDVSL is INTEGER +*> The leading dimension of the matrix VSL. LDVSL >=1, and +*> if JOBVSL = 'V', LDVSL >= N. +*> \endverbatim +*> +*> \param[out] VSR +*> \verbatim +*> VSR is REAL array, dimension (LDVSR,N) +*> If JOBVSR = 'V', VSR will contain the right Schur vectors. +*> Not referenced if JOBVSR = 'N'. +*> \endverbatim +*> +*> \param[in] LDVSR +*> \verbatim +*> LDVSR is INTEGER +*> The leading dimension of the matrix VSR. LDVSR >= 1, and +*> if JOBVSR = 'V', LDVSR >= 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 dimension of the array WORK. +*> +*> 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] BWORK +*> \verbatim +*> BWORK is LOGICAL array, dimension (N) +*> Not referenced if SORT = 'N'. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> = 1,...,N: +*> The QZ iteration failed. (A,B) are not in Schur +*> form, but ALPHAR(j), ALPHAI(j), and BETA(j) should +*> be correct for j=INFO+1,...,N. +*> > N: =N+1: other than QZ iteration failed in SHGEQZ. +*> =N+2: after reordering, roundoff changed values of +*> some complex eigenvalues so that leading +*> eigenvalues in the Generalized Schur form no +*> longer satisfy SELCTG=.TRUE. This could also +*> be caused due to scaling. +*> =N+3: reordering failed in STGSEN. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date January 2015 +* +*> \ingroup realGEeigen +* +* ===================================================================== + SUBROUTINE SGGES3( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, + $ LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, + $ VSR, LDVSR, WORK, LWORK, BWORK, INFO ) +* +* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2015 +* +* .. Scalar Arguments .. + CHARACTER JOBVSL, JOBVSR, SORT + INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM +* .. +* .. Array Arguments .. + LOGICAL BWORK( * ) + REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ), + $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), + $ VSR( LDVSR, * ), WORK( * ) +* .. +* .. Function Arguments .. + LOGICAL SELCTG + EXTERNAL SELCTG +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL, + $ LQUERY, LST2SL, WANTST + INTEGER I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, + $ ILO, IP, IRIGHT, IROWS, ITAU, IWRK, LWKOPT + REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL, + $ PVSR, SAFMAX, SAFMIN, SMLNUM +* .. +* .. Local Arrays .. + INTEGER IDUM( 1 ) + REAL DIF( 2 ) +* .. +* .. External Subroutines .. + EXTERNAL SGEQRF, SGGBAK, SGGBAL, SGGHD3, SHGEQZ, SLABAD, + $ SLACPY, SLASCL, SLASET, SORGQR, SORMQR, STGSEN, + $ XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SLAMCH, SLANGE + EXTERNAL LSAME, SLAMCH, SLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Decode the input arguments +* + IF( LSAME( JOBVSL, 'N' ) ) THEN + IJOBVL = 1 + ILVSL = .FALSE. + ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN + IJOBVL = 2 + ILVSL = .TRUE. + ELSE + IJOBVL = -1 + ILVSL = .FALSE. + END IF +* + IF( LSAME( JOBVSR, 'N' ) ) THEN + IJOBVR = 1 + ILVSR = .FALSE. + ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN + IJOBVR = 2 + ILVSR = .TRUE. + ELSE + IJOBVR = -1 + ILVSR = .FALSE. + END IF +* + WANTST = LSAME( SORT, 'S' ) +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( IJOBVL.LE.0 ) THEN + INFO = -1 + ELSE IF( IJOBVR.LE.0 ) THEN + INFO = -2 + ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN + INFO = -15 + ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN + INFO = -17 + ELSE IF( LWORK.LT.6*N+16 .AND. .NOT.LQUERY ) THEN + INFO = -19 + END IF +* +* Compute workspace +* + IF( INFO.EQ.0 ) THEN + CALL SGEQRF( N, N, B, LDB, WORK, WORK, -1, IERR ) + LWKOPT = MAX( 6*N+16, 3*N+INT( WORK( 1 ) ) ) + CALL SORMQR( 'L', 'T', N, N, N, B, LDB, WORK, A, LDA, WORK, + $ -1, IERR ) + LWKOPT = MAX( LWKOPT, 3*N+INT( WORK( 1 ) ) ) + IF( ILVSL ) THEN + CALL SORGQR( N, N, N, VSL, LDVSL, WORK, WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, 3*N+INT( WORK( 1 ) ) ) + END IF + CALL SGGHD3( JOBVSL, JOBVSR, N, 1, N, A, LDA, B, LDB, VSL, + $ LDVSL, VSR, LDVSR, WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, 3*N+INT( WORK( 1 ) ) ) + CALL SHGEQZ( 'S', JOBVSL, JOBVSR, N, 1, N, A, LDA, B, LDB, + $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, + $ WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, 2*N+INT( WORK( 1 ) ) ) + IF( WANTST ) THEN + CALL STGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, + $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, + $ SDIM, PVSL, PVSR, DIF, WORK, -1, IDUM, 1, + $ IERR ) + LWKOPT = MAX( LWKOPT, 2*N+INT( WORK( 1 ) ) ) + END IF + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SGGES3 ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + SDIM = 0 + RETURN + END IF +* +* Get machine constants +* + EPS = SLAMCH( 'P' ) + SAFMIN = SLAMCH( 'S' ) + SAFMAX = ONE / SAFMIN + CALL SLABAD( SAFMIN, SAFMAX ) + SMLNUM = SQRT( SAFMIN ) / EPS + BIGNUM = ONE / SMLNUM +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = SLANGE( 'M', N, N, A, LDA, WORK ) + ILASCL = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + ANRMTO = SMLNUM + ILASCL = .TRUE. + ELSE IF( ANRM.GT.BIGNUM ) THEN + ANRMTO = BIGNUM + ILASCL = .TRUE. + END IF + IF( ILASCL ) + $ CALL SLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR ) +* +* Scale B if max element outside range [SMLNUM,BIGNUM] +* + BNRM = SLANGE( 'M', N, N, B, LDB, WORK ) + ILBSCL = .FALSE. + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN + BNRMTO = SMLNUM + ILBSCL = .TRUE. + ELSE IF( BNRM.GT.BIGNUM ) THEN + BNRMTO = BIGNUM + ILBSCL = .TRUE. + END IF + IF( ILBSCL ) + $ CALL SLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR ) +* +* Permute the matrix to make it more nearly triangular +* + ILEFT = 1 + IRIGHT = N + 1 + IWRK = IRIGHT + N + CALL SGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ), + $ WORK( IRIGHT ), WORK( IWRK ), IERR ) +* +* Reduce B to triangular form (QR decomposition of B) +* + IROWS = IHI + 1 - ILO + ICOLS = N + 1 - ILO + ITAU = IWRK + IWRK = ITAU + IROWS + CALL SGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) +* +* Apply the orthogonal transformation to matrix A +* + CALL SORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, + $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), + $ LWORK+1-IWRK, IERR ) +* +* Initialize VSL +* + IF( ILVSL ) THEN + CALL SLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL ) + IF( IROWS.GT.1 ) THEN + CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, + $ VSL( ILO+1, ILO ), LDVSL ) + END IF + CALL SORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL, + $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR ) + END IF +* +* Initialize VSR +* + IF( ILVSR ) + $ CALL SLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR ) +* +* Reduce to generalized Hessenberg form +* + CALL SGGHD3( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, + $ LDVSL, VSR, LDVSR, WORK( IWRK ), LWORK+1-IWRK, IERR ) +* +* Perform QZ algorithm, computing Schur vectors if desired +* + IWRK = ITAU + CALL SHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, + $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.GT.0 .AND. IERR.LE.N ) THEN + INFO = IERR + ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN + INFO = IERR - N + ELSE + INFO = N + 1 + END IF + GO TO 40 + END IF +* +* Sort eigenvalues ALPHA/BETA if desired +* + SDIM = 0 + IF( WANTST ) THEN +* +* Undo scaling on eigenvalues before SELCTGing +* + IF( ILASCL ) THEN + CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, + $ IERR ) + CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, + $ IERR ) + END IF + IF( ILBSCL ) + $ CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) +* +* Select eigenvalues +* + DO 10 I = 1, N + BWORK( I ) = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) ) + 10 CONTINUE +* + CALL STGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, ALPHAR, + $ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PVSL, + $ PVSR, DIF, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1, + $ IERR ) + IF( IERR.EQ.1 ) + $ INFO = N + 3 +* + END IF +* +* Apply back-permutation to VSL and VSR +* + IF( ILVSL ) + $ CALL SGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ), + $ WORK( IRIGHT ), N, VSL, LDVSL, IERR ) +* + IF( ILVSR ) + $ CALL SGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ), + $ WORK( IRIGHT ), N, VSR, LDVSR, IERR ) +* +* Check if unscaling would cause over/underflow, if so, rescale +* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of +* B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I) +* + IF( ILASCL )THEN + DO 50 I = 1, N + IF( ALPHAI( I ).NE.ZERO ) THEN + IF( ( ALPHAR( I )/SAFMAX ).GT.( ANRMTO/ANRM ) .OR. + $ ( SAFMIN/ALPHAR( I ) ).GT.( ANRM/ANRMTO ) ) THEN + WORK( 1 ) = ABS( A( I, I )/ALPHAR( I ) ) + BETA( I ) = BETA( I )*WORK( 1 ) + ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) + ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) + ELSE IF( ( ALPHAI( I )/SAFMAX ).GT.( ANRMTO/ANRM ) .OR. + $ ( SAFMIN/ALPHAI( I ) ).GT.( ANRM/ANRMTO ) ) THEN + WORK( 1 ) = ABS( A( I, I+1 )/ALPHAI( I ) ) + BETA( I ) = BETA( I )*WORK( 1 ) + ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) + ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) + END IF + END IF + 50 CONTINUE + END IF +* + IF( ILBSCL )THEN + DO 60 I = 1, N + IF( ALPHAI( I ).NE.ZERO ) THEN + IF( ( BETA( I )/SAFMAX ).GT.( BNRMTO/BNRM ) .OR. + $ ( SAFMIN/BETA( I ) ).GT.( BNRM/BNRMTO ) ) THEN + WORK( 1 ) = ABS(B( I, I )/BETA( I )) + BETA( I ) = BETA( I )*WORK( 1 ) + ALPHAR( I ) = ALPHAR( I )*WORK( 1 ) + ALPHAI( I ) = ALPHAI( I )*WORK( 1 ) + END IF + END IF + 60 CONTINUE + END IF +* +* Undo scaling +* + IF( ILASCL ) THEN + CALL SLASCL( 'H', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR ) + CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR ) + CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR ) + END IF +* + IF( ILBSCL ) THEN + CALL SLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR ) + CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) + END IF +* + IF( WANTST ) THEN +* +* Check if reordering is correct +* + LASTSL = .TRUE. + LST2SL = .TRUE. + SDIM = 0 + IP = 0 + DO 30 I = 1, N + CURSL = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) ) + IF( ALPHAI( I ).EQ.ZERO ) THEN + IF( CURSL ) + $ SDIM = SDIM + 1 + IP = 0 + IF( CURSL .AND. .NOT.LASTSL ) + $ INFO = N + 2 + ELSE + IF( IP.EQ.1 ) THEN +* +* Last eigenvalue of conjugate pair +* + CURSL = CURSL .OR. LASTSL + LASTSL = CURSL + IF( CURSL ) + $ SDIM = SDIM + 2 + IP = -1 + IF( CURSL .AND. .NOT.LST2SL ) + $ INFO = N + 2 + ELSE +* +* First eigenvalue of conjugate pair +* + IP = 1 + END IF + END IF + LST2SL = LASTSL + LASTSL = CURSL + 30 CONTINUE +* + END IF +* + 40 CONTINUE +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of SGGES3 +* + END diff --git a/SRC/sggev3.f b/SRC/sggev3.f new file mode 100644 index 0000000..7a253ad --- /dev/null +++ b/SRC/sggev3.f @@ -0,0 +1,589 @@ +*> \brief SGGEV3 computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices (blocked algorithm) +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SGGEV3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SGGEV3( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, +* $ ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, +* $ INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBVL, JOBVR +* INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ), +* $ B( LDB, * ), BETA( * ), VL( LDVL, * ), +* $ VR( LDVR, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SGGEV3 computes for a pair of N-by-N real nonsymmetric matrices (A,B) +*> the generalized eigenvalues, and optionally, the left and/or right +*> generalized eigenvectors. +*> +*> A generalized eigenvalue for a pair of matrices (A,B) is a scalar +*> lambda or a ratio alpha/beta = lambda, such that A - lambda*B is +*> singular. It is usually represented as the pair (alpha,beta), as +*> there is a reasonable interpretation for beta=0, and even for both +*> being zero. +*> +*> The right eigenvector v(j) corresponding to the eigenvalue lambda(j) +*> of (A,B) satisfies +*> +*> A * v(j) = lambda(j) * B * v(j). +*> +*> The left eigenvector u(j) corresponding to the eigenvalue lambda(j) +*> of (A,B) satisfies +*> +*> u(j)**H * A = lambda(j) * u(j)**H * B . +*> +*> where u(j)**H is the conjugate-transpose of u(j). +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBVL +*> \verbatim +*> JOBVL is CHARACTER*1 +*> = 'N': do not compute the left generalized eigenvectors; +*> = 'V': compute the left generalized eigenvectors. +*> \endverbatim +*> +*> \param[in] JOBVR +*> \verbatim +*> JOBVR is CHARACTER*1 +*> = 'N': do not compute the right generalized eigenvectors; +*> = 'V': compute the right generalized eigenvectors. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A, B, VL, and VR. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA, N) +*> On entry, the matrix A in the pair (A,B). +*> On exit, A has been overwritten. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB, N) +*> On entry, the matrix B in the pair (A,B). +*> On exit, B has been overwritten. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] ALPHAR +*> \verbatim +*> ALPHAR is REAL array, dimension (N) +*> \endverbatim +*> +*> \param[out] ALPHAI +*> \verbatim +*> ALPHAI is REAL array, dimension (N) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is REAL array, dimension (N) +*> On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will +*> be the generalized eigenvalues. If ALPHAI(j) is zero, then +*> the j-th eigenvalue is real; if positive, then the j-th and +*> (j+1)-st eigenvalues are a complex conjugate pair, with +*> ALPHAI(j+1) negative. +*> +*> Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) +*> may easily over- or underflow, and BETA(j) may even be zero. +*> Thus, the user should avoid naively computing the ratio +*> alpha/beta. However, ALPHAR and ALPHAI will be always less +*> than and usually comparable with norm(A) in magnitude, and +*> BETA always less than and usually comparable with norm(B). +*> \endverbatim +*> +*> \param[out] VL +*> \verbatim +*> VL is REAL array, dimension (LDVL,N) +*> If JOBVL = 'V', the left eigenvectors u(j) are stored one +*> after another in the columns of VL, in the same order as +*> their eigenvalues. If the j-th eigenvalue is real, then +*> u(j) = VL(:,j), the j-th column of VL. If the j-th and +*> (j+1)-th eigenvalues form a complex conjugate pair, then +*> u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1). +*> Each eigenvector is scaled so the largest component has +*> abs(real part)+abs(imag. part)=1. +*> Not referenced if JOBVL = 'N'. +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of the matrix VL. LDVL >= 1, and +*> if JOBVL = 'V', LDVL >= N. +*> \endverbatim +*> +*> \param[out] VR +*> \verbatim +*> VR is REAL array, dimension (LDVR,N) +*> If JOBVR = 'V', the right eigenvectors v(j) are stored one +*> after another in the columns of VR, in the same order as +*> their eigenvalues. If the j-th eigenvalue is real, then +*> v(j) = VR(:,j), the j-th column of VR. If the j-th and +*> (j+1)-th eigenvalues form a complex conjugate pair, then +*> v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1). +*> Each eigenvector is scaled so the largest component has +*> abs(real part)+abs(imag. part)=1. +*> Not referenced if JOBVR = 'N'. +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the matrix VR. LDVR >= 1, and +*> if JOBVR = 'V', LDVR >= 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 +*> +*> 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. +*> = 1,...,N: +*> The QZ iteration failed. No eigenvectors have been +*> calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) +*> should be correct for j=INFO+1,...,N. +*> > N: =N+1: other than QZ iteration failed in SHGEQZ. +*> =N+2: error return from STGEVC. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date January 2015 +* +*> \ingroup realGEeigen +* +* ===================================================================== + SUBROUTINE SGGEV3( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, + $ ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, + $ INFO ) +* +* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2015 +* +* .. Scalar Arguments .. + CHARACTER JOBVL, JOBVR + INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N +* .. +* .. Array Arguments .. + REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ), + $ B( LDB, * ), BETA( * ), VL( LDVL, * ), + $ VR( LDVR, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY + CHARACTER CHTEMP + INTEGER ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO, + $ IN, IRIGHT, IROWS, ITAU, IWRK, JC, JR, LWKOPT + REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, + $ SMLNUM, TEMP +* .. +* .. Local Arrays .. + LOGICAL LDUMMA( 1 ) +* .. +* .. External Subroutines .. + EXTERNAL SGEQRF, SGGBAK, SGGBAL, SGGHD3, SHGEQZ, SLABAD, + $ SLACPY, SLASCL, SLASET, SORGQR, SORMQR, STGEVC, + $ XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SLAMCH, SLANGE + EXTERNAL LSAME, SLAMCH, SLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Decode the input arguments +* + IF( LSAME( JOBVL, 'N' ) ) THEN + IJOBVL = 1 + ILVL = .FALSE. + ELSE IF( LSAME( JOBVL, 'V' ) ) THEN + IJOBVL = 2 + ILVL = .TRUE. + ELSE + IJOBVL = -1 + ILVL = .FALSE. + END IF +* + IF( LSAME( JOBVR, 'N' ) ) THEN + IJOBVR = 1 + ILVR = .FALSE. + ELSE IF( LSAME( JOBVR, 'V' ) ) THEN + IJOBVR = 2 + ILVR = .TRUE. + ELSE + IJOBVR = -1 + ILVR = .FALSE. + END IF + ILV = ILVL .OR. ILVR +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( IJOBVL.LE.0 ) THEN + INFO = -1 + ELSE IF( IJOBVR.LE.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN + INFO = -12 + ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN + INFO = -14 + ELSE IF( LWORK.LT.MAX( 1, 8*N ) .AND. .NOT.LQUERY ) THEN + INFO = -16 + END IF +* +* Compute workspace +* + IF( INFO.EQ.0 ) THEN + CALL SGEQRF( N, N, B, LDB, WORK, WORK, -1, IERR ) + LWKOPT = MAX( 1, 8*N, 3*N+INT ( WORK( 1 ) ) ) + CALL SORMQR( 'L', 'T', N, N, N, B, LDB, WORK, A, LDA, WORK, + $ -1, IERR ) + LWKOPT = MAX( LWKOPT, 3*N+INT ( WORK( 1 ) ) ) + CALL SGGHD3( JOBVL, JOBVR, N, 1, N, A, LDA, B, LDB, VL, LDVL, + $ VR, LDVR, WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, 3*N+INT ( WORK( 1 ) ) ) + IF( ILVL ) THEN + CALL SORGQR( N, N, N, VL, LDVL, WORK, WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, 3*N+INT ( WORK( 1 ) ) ) + CALL SHGEQZ( 'S', JOBVL, JOBVR, N, 1, N, A, LDA, B, LDB, + $ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, + $ WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, 2*N+INT ( WORK( 1 ) ) ) + ELSE + CALL SHGEQZ( 'E', JOBVL, JOBVR, N, 1, N, A, LDA, B, LDB, + $ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, + $ WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, 2*N+INT ( WORK( 1 ) ) ) + END IF + WORK( 1 ) = REAL( LWKOPT ) +* + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SGGEV3 ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Get machine constants +* + EPS = SLAMCH( 'P' ) + SMLNUM = SLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL SLABAD( SMLNUM, BIGNUM ) + SMLNUM = SQRT( SMLNUM ) / EPS + BIGNUM = ONE / SMLNUM +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = SLANGE( 'M', N, N, A, LDA, WORK ) + ILASCL = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + ANRMTO = SMLNUM + ILASCL = .TRUE. + ELSE IF( ANRM.GT.BIGNUM ) THEN + ANRMTO = BIGNUM + ILASCL = .TRUE. + END IF + IF( ILASCL ) + $ CALL SLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR ) +* +* Scale B if max element outside range [SMLNUM,BIGNUM] +* + BNRM = SLANGE( 'M', N, N, B, LDB, WORK ) + ILBSCL = .FALSE. + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN + BNRMTO = SMLNUM + ILBSCL = .TRUE. + ELSE IF( BNRM.GT.BIGNUM ) THEN + BNRMTO = BIGNUM + ILBSCL = .TRUE. + END IF + IF( ILBSCL ) + $ CALL SLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR ) +* +* Permute the matrices A, B to isolate eigenvalues if possible +* + ILEFT = 1 + IRIGHT = N + 1 + IWRK = IRIGHT + N + CALL SGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ), + $ WORK( IRIGHT ), WORK( IWRK ), IERR ) +* +* Reduce B to triangular form (QR decomposition of B) +* + IROWS = IHI + 1 - ILO + IF( ILV ) THEN + ICOLS = N + 1 - ILO + ELSE + ICOLS = IROWS + END IF + ITAU = IWRK + IWRK = ITAU + IROWS + CALL SGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) +* +* Apply the orthogonal transformation to matrix A +* + CALL SORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, + $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), + $ LWORK+1-IWRK, IERR ) +* +* Initialize VL +* + IF( ILVL ) THEN + CALL SLASET( 'Full', N, N, ZERO, ONE, VL, LDVL ) + IF( IROWS.GT.1 ) THEN + CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, + $ VL( ILO+1, ILO ), LDVL ) + END IF + CALL SORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL, + $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR ) + END IF +* +* Initialize VR +* + IF( ILVR ) + $ CALL SLASET( 'Full', N, N, ZERO, ONE, VR, LDVR ) +* +* Reduce to generalized Hessenberg form +* + IF( ILV ) THEN +* +* Eigenvectors requested -- work on whole matrix. +* + CALL SGGHD3( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL, + $ LDVL, VR, LDVR, WORK( IWRK ), LWORK+1-IWRK, IERR ) + ELSE + CALL SGGHD3( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA, + $ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) + END IF +* +* Perform QZ algorithm (Compute eigenvalues, and optionally, the +* Schur forms and Schur vectors) +* + IWRK = ITAU + IF( ILV ) THEN + CHTEMP = 'S' + ELSE + CHTEMP = 'E' + END IF + CALL SHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, + $ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.GT.0 .AND. IERR.LE.N ) THEN + INFO = IERR + ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN + INFO = IERR - N + ELSE + INFO = N + 1 + END IF + GO TO 110 + END IF +* +* Compute Eigenvectors +* + IF( ILV ) THEN + IF( ILVL ) THEN + IF( ILVR ) THEN + CHTEMP = 'B' + ELSE + CHTEMP = 'L' + END IF + ELSE + CHTEMP = 'R' + END IF + CALL STGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL, + $ VR, LDVR, N, IN, WORK( IWRK ), IERR ) + IF( IERR.NE.0 ) THEN + INFO = N + 2 + GO TO 110 + END IF +* +* Undo balancing on VL and VR and normalization +* + IF( ILVL ) THEN + CALL SGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ), + $ WORK( IRIGHT ), N, VL, LDVL, IERR ) + DO 50 JC = 1, N + IF( ALPHAI( JC ).LT.ZERO ) + $ GO TO 50 + TEMP = ZERO + IF( ALPHAI( JC ).EQ.ZERO ) THEN + DO 10 JR = 1, N + TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) ) + 10 CONTINUE + ELSE + DO 20 JR = 1, N + TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+ + $ ABS( VL( JR, JC+1 ) ) ) + 20 CONTINUE + END IF + IF( TEMP.LT.SMLNUM ) + $ GO TO 50 + TEMP = ONE / TEMP + IF( ALPHAI( JC ).EQ.ZERO ) THEN + DO 30 JR = 1, N + VL( JR, JC ) = VL( JR, JC )*TEMP + 30 CONTINUE + ELSE + DO 40 JR = 1, N + VL( JR, JC ) = VL( JR, JC )*TEMP + VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP + 40 CONTINUE + END IF + 50 CONTINUE + END IF + IF( ILVR ) THEN + CALL SGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ), + $ WORK( IRIGHT ), N, VR, LDVR, IERR ) + DO 100 JC = 1, N + IF( ALPHAI( JC ).LT.ZERO ) + $ GO TO 100 + TEMP = ZERO + IF( ALPHAI( JC ).EQ.ZERO ) THEN + DO 60 JR = 1, N + TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) ) + 60 CONTINUE + ELSE + DO 70 JR = 1, N + TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+ + $ ABS( VR( JR, JC+1 ) ) ) + 70 CONTINUE + END IF + IF( TEMP.LT.SMLNUM ) + $ GO TO 100 + TEMP = ONE / TEMP + IF( ALPHAI( JC ).EQ.ZERO ) THEN + DO 80 JR = 1, N + VR( JR, JC ) = VR( JR, JC )*TEMP + 80 CONTINUE + ELSE + DO 90 JR = 1, N + VR( JR, JC ) = VR( JR, JC )*TEMP + VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP + 90 CONTINUE + END IF + 100 CONTINUE + END IF +* +* End of eigenvector calculation +* + END IF +* +* Undo scaling if necessary +* + 110 CONTINUE +* + IF( ILASCL ) THEN + CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR ) + CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR ) + END IF +* + IF( ILBSCL ) THEN + CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) + END IF +* + WORK( 1 ) = REAL( LWKOPT ) + RETURN +* +* End of SGGEV3 +* + END diff --git a/SRC/sgghd3.f b/SRC/sgghd3.f new file mode 100644 index 0000000..bf91f55 --- /dev/null +++ b/SRC/sgghd3.f @@ -0,0 +1,898 @@ +*> \brief \b SGGHD3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SGGHRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SGGHD3( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, +* LDQ, Z, LDZ, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER COMPQ, COMPZ +* INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N, LWORK +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ), +* $ Z( LDZ, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SGGHD3 reduces a pair of real matrices (A,B) to generalized upper +*> Hessenberg form using orthogonal transformations, where A is a +*> general matrix and B is upper triangular. The form of the +*> generalized eigenvalue problem is +*> A*x = lambda*B*x, +*> and B is typically made upper triangular by computing its QR +*> factorization and moving the orthogonal matrix Q to the left side +*> of the equation. +*> +*> This subroutine simultaneously reduces A to a Hessenberg matrix H: +*> Q**T*A*Z = H +*> and transforms B to another upper triangular matrix T: +*> Q**T*B*Z = T +*> in order to reduce the problem to its standard form +*> H*y = lambda*T*y +*> where y = Z**T*x. +*> +*> The orthogonal matrices Q and Z are determined as products of Givens +*> rotations. They may either be formed explicitly, or they may be +*> postmultiplied into input matrices Q1 and Z1, so that +*> +*> Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T +*> +*> Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T +*> +*> If Q1 is the orthogonal matrix from the QR factorization of B in the +*> original equation A*x = lambda*B*x, then SGGHD3 reduces the original +*> problem to generalized Hessenberg form. +*> +*> This is a blocked variant of SGGHRD, using matrix-matrix +*> multiplications for parts of the computation to enhance performance. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] COMPQ +*> \verbatim +*> COMPQ is CHARACTER*1 +*> = 'N': do not compute Q; +*> = 'I': Q is initialized to the unit matrix, and the +*> orthogonal matrix Q is returned; +*> = 'V': Q must contain an orthogonal matrix Q1 on entry, +*> and the product Q1*Q is returned. +*> \endverbatim +*> +*> \param[in] COMPZ +*> \verbatim +*> COMPZ is CHARACTER*1 +*> = 'N': do not compute Z; +*> = 'I': Z is initialized to the unit matrix, and the +*> orthogonal matrix Z is returned; +*> = 'V': Z must contain an orthogonal matrix Z1 on entry, +*> and the product Z1*Z is returned. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> +*> ILO and IHI mark the rows and columns of A which are to be +*> reduced. It is assumed that A is already upper triangular +*> in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are +*> normally set by a previous call to SGGBAL; otherwise they +*> should be set to 1 and N respectively. +*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA, N) +*> On entry, the N-by-N general matrix to be reduced. +*> On exit, the upper triangle and the first subdiagonal of A +*> are overwritten with the upper Hessenberg matrix H, and the +*> rest is set to zero. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB, N) +*> On entry, the N-by-N upper triangular matrix B. +*> On exit, the upper triangular matrix T = Q**T B Z. The +*> elements below the diagonal are set to zero. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] Q +*> \verbatim +*> Q is REAL array, dimension (LDQ, N) +*> On entry, if COMPQ = 'V', the orthogonal matrix Q1, +*> typically from the QR factorization of B. +*> On exit, if COMPQ='I', the orthogonal matrix Q, and if +*> COMPQ = 'V', the product Q1*Q. +*> Not referenced if COMPQ='N'. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. +*> LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is REAL array, dimension (LDZ, N) +*> On entry, if COMPZ = 'V', the orthogonal matrix Z1. +*> On exit, if COMPZ='I', the orthogonal matrix Z, and if +*> COMPZ = 'V', the product Z1*Z. +*> Not referenced if COMPZ='N'. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. +*> LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (LWORK) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1. +*> For optimum performance LWORK >= 6*N*NB, where NB is the +*> optimal blocksize. +*> +*> 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 January 2015 +* +*> \ingroup realOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> This routine reduces A to Hessenberg form and maintains B in +*> using a blocked variant of Moler and Stewart's original algorithm, +*> as described by Kagstrom, Kressner, Quintana-Orti, and Quintana-Orti +*> (BIT 2008). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SGGHD3( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, + $ LDQ, Z, LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2015 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ + INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N, LWORK +* .. +* .. Array Arguments .. + REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ), + $ Z( LDZ, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL BLK22, INITQ, INITZ, LQUERY, WANTQ, WANTZ + CHARACTER*1 COMPQ2, COMPZ2 + INTEGER COLA, I, IERR, J, J0, JCOL, JJ, JROW, K, + $ KACC22, LEN, LWKOPT, N2NB, NB, NBLST, NBMIN, + $ NH, NNB, NX, PPW, PPWO, PW, TOP, TOPQ + REAL C, C1, C2, S, S1, S2, TEMP, TEMP1, TEMP2, TEMP3 +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +* .. +* .. External Subroutines .. + EXTERNAL SGGHRD, SLARTG, SLASET, SORM22, SROT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, MAX +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters. +* + INFO = 0 + NB = ILAENV( 1, 'SGGHD3', ' ', N, ILO, IHI, -1 ) + LWKOPT = 6*N*NB + WORK( 1 ) = REAL( LWKOPT ) + INITQ = LSAME( COMPQ, 'I' ) + WANTQ = INITQ .OR. LSAME( COMPQ, 'V' ) + INITZ = LSAME( COMPZ, 'I' ) + WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) + LQUERY = ( LWORK.EQ.-1 ) +* + IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( ILO.LT.1 ) THEN + INFO = -4 + ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( ( WANTQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN + INFO = -11 + ELSE IF( ( WANTZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN + INFO = -13 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -15 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SGGHD3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Initialize Q and Z if desired. +* + IF( INITQ ) + $ CALL SLASET( 'All', N, N, ZERO, ONE, Q, LDQ ) + IF( INITZ ) + $ CALL SLASET( 'All', N, N, ZERO, ONE, Z, LDZ ) +* +* Zero out lower triangle of B. +* + IF( N.GT.1 ) + $ CALL SLASET( 'Lower', N-1, N-1, ZERO, ZERO, B(2, 1), LDB ) +* +* Quick return if possible +* + NH = IHI - ILO + 1 + IF( NH.LE.1 ) THEN + WORK( 1 ) = ONE + RETURN + END IF +* +* Determine the blocksize. +* + NBMIN = ILAENV( 2, 'SGGHD3', ' ', N, ILO, IHI, -1 ) + IF( NB.GT.1 .AND. NB.LT.NH ) THEN +* +* Determine when to use unblocked instead of blocked code. +* + NX = MAX( NB, ILAENV( 3, 'SGGHD3', ' ', N, ILO, IHI, -1 ) ) + IF( NX.LT.NH ) THEN +* +* Determine if workspace is large enough for blocked code. +* + IF( LWORK.LT.LWKOPT ) THEN +* +* Not enough workspace to use optimal NB: determine the +* minimum value of NB, and reduce NB or force use of +* unblocked code. +* + NBMIN = MAX( 2, ILAENV( 2, 'SGGHD3', ' ', N, ILO, IHI, + $ -1 ) ) + IF( LWORK.GE.6*N*NBMIN ) THEN + NB = LWORK / ( 6*N ) + ELSE + NB = 1 + END IF + END IF + END IF + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN +* +* Use unblocked code below +* + JCOL = ILO +* + ELSE +* +* Use blocked code +* + KACC22 = ILAENV( 16, 'SGGHD3', ' ', N, ILO, IHI, -1 ) + BLK22 = KACC22.EQ.2 + DO JCOL = ILO, IHI-2, NB + NNB = MIN( NB, IHI-JCOL-1 ) +* +* Initialize small orthogonal factors that will hold the +* accumulated Givens rotations in workspace. +* N2NB denotes the number of 2*NNB-by-2*NNB factors +* NBLST denotes the (possibly smaller) order of the last +* factor. +* + N2NB = ( IHI-JCOL-1 ) / NNB - 1 + NBLST = IHI - JCOL - N2NB*NNB + CALL SLASET( 'All', NBLST, NBLST, ZERO, ONE, WORK, NBLST ) + PW = NBLST * NBLST + 1 + DO I = 1, N2NB + CALL SLASET( 'All', 2*NNB, 2*NNB, ZERO, ONE, + $ WORK( PW ), 2*NNB ) + PW = PW + 4*NNB*NNB + END DO +* +* Reduce columns JCOL:JCOL+NNB-1 of A to Hessenberg form. +* + DO J = JCOL, JCOL+NNB-1 +* +* Reduce Jth column of A. Store cosines and sines in Jth +* column of A and B, respectively. +* + DO I = IHI, J+2, -1 + TEMP = A( I-1, J ) + CALL SLARTG( TEMP, A( I, J ), C, S, A( I-1, J ) ) + A( I, J ) = C + B( I, J ) = S + END DO +* +* Accumulate Givens rotations into workspace array. +* + PPW = ( NBLST + 1 )*( NBLST - 2 ) - J + JCOL + 1 + LEN = 2 + J - JCOL + JROW = J + N2NB*NNB + 2 + DO I = IHI, JROW, -1 + C = A( I, J ) + S = B( I, J ) + DO JJ = PPW, PPW+LEN-1 + TEMP = WORK( JJ + NBLST ) + WORK( JJ + NBLST ) = C*TEMP - S*WORK( JJ ) + WORK( JJ ) = S*TEMP + C*WORK( JJ ) + END DO + LEN = LEN + 1 + PPW = PPW - NBLST - 1 + END DO +* + PPWO = NBLST*NBLST + ( NNB+J-JCOL-1 )*2*NNB + NNB + J0 = JROW - NNB + DO JROW = J0, J+2, -NNB + PPW = PPWO + LEN = 2 + J - JCOL + DO I = JROW+NNB-1, JROW, -1 + C = A( I, J ) + S = B( I, J ) + DO JJ = PPW, PPW+LEN-1 + TEMP = WORK( JJ + 2*NNB ) + WORK( JJ + 2*NNB ) = C*TEMP - S*WORK( JJ ) + WORK( JJ ) = S*TEMP + C*WORK( JJ ) + END DO + LEN = LEN + 1 + PPW = PPW - 2*NNB - 1 + END DO + PPWO = PPWO + 4*NNB*NNB + END DO +* +* TOP denotes the number of top rows in A and B that will +* not be updated during the next steps. +* + IF( JCOL.LE.2 ) THEN + TOP = 0 + ELSE + TOP = JCOL + END IF +* +* Propagate transformations through B and replace stored +* left sines/cosines by right sines/cosines. +* + DO JJ = N, J+1, -1 +* +* Update JJth column of B. +* + DO I = MIN( JJ+1, IHI ), J+2, -1 + C = A( I, J ) + S = B( I, J ) + TEMP = B( I, JJ ) + B( I, JJ ) = C*TEMP - S*B( I-1, JJ ) + B( I-1, JJ ) = S*TEMP + C*B( I-1, JJ ) + END DO +* +* Annihilate B( JJ+1, JJ ). +* + IF( JJ.LT.IHI ) THEN + TEMP = B( JJ+1, JJ+1 ) + CALL SLARTG( TEMP, B( JJ+1, JJ ), C, S, + $ B( JJ+1, JJ+1 ) ) + B( JJ+1, JJ ) = ZERO + CALL SROT( JJ-TOP, B( TOP+1, JJ+1 ), 1, + $ B( TOP+1, JJ ), 1, C, S ) + A( JJ+1, J ) = C + B( JJ+1, J ) = -S + END IF + END DO +* +* Update A by transformations from right. +* Explicit loop unrolling provides better performance +* compared to SLASR. +* CALL SLASR( 'Right', 'Variable', 'Backward', IHI-TOP, +* $ IHI-J, A( J+2, J ), B( J+2, J ), +* $ A( TOP+1, J+1 ), LDA ) +* + JJ = MOD( IHI-J-1, 3 ) + DO I = IHI-J-3, JJ+1, -3 + C = A( J+1+I, J ) + S = -B( J+1+I, J ) + C1 = A( J+2+I, J ) + S1 = -B( J+2+I, J ) + C2 = A( J+3+I, J ) + S2 = -B( J+3+I, J ) +* + DO K = TOP+1, IHI + TEMP = A( K, J+I ) + TEMP1 = A( K, J+I+1 ) + TEMP2 = A( K, J+I+2 ) + TEMP3 = A( K, J+I+3 ) + A( K, J+I+3 ) = C2*TEMP3 + S2*TEMP2 + TEMP2 = -S2*TEMP3 + C2*TEMP2 + A( K, J+I+2 ) = C1*TEMP2 + S1*TEMP1 + TEMP1 = -S1*TEMP2 + C1*TEMP1 + A( K, J+I+1 ) = C*TEMP1 + S*TEMP + A( K, J+I ) = -S*TEMP1 + C*TEMP + END DO + END DO +* + IF( JJ.GT.0 ) THEN + DO I = JJ, 1, -1 + CALL SROT( IHI-TOP, A( TOP+1, J+I+1 ), 1, + $ A( TOP+1, J+I ), 1, A( J+1+I, J ), + $ -B( J+1+I, J ) ) + END DO + END IF +* +* Update (J+1)th column of A by transformations from left. +* + IF ( J .LT. JCOL + NNB - 1 ) THEN + LEN = 1 + J - JCOL +* +* Multiply with the trailing accumulated orthogonal +* matrix, which takes the form +* +* [ U11 U12 ] +* U = [ ], +* [ U21 U22 ] +* +* where U21 is a LEN-by-LEN matrix and U12 is lower +* triangular. +* + JROW = IHI - NBLST + 1 + CALL SGEMV( 'Transpose', NBLST, LEN, ONE, WORK, + $ NBLST, A( JROW, J+1 ), 1, ZERO, + $ WORK( PW ), 1 ) + PPW = PW + LEN + DO I = JROW, JROW+NBLST-LEN-1 + WORK( PPW ) = A( I, J+1 ) + PPW = PPW + 1 + END DO + CALL STRMV( 'Lower', 'Transpose', 'Non-unit', + $ NBLST-LEN, WORK( LEN*NBLST + 1 ), NBLST, + $ WORK( PW+LEN ), 1 ) + CALL SGEMV( 'Transpose', LEN, NBLST-LEN, ONE, + $ WORK( (LEN+1)*NBLST - LEN + 1 ), NBLST, + $ A( JROW+NBLST-LEN, J+1 ), 1, ONE, + $ WORK( PW+LEN ), 1 ) + PPW = PW + DO I = JROW, JROW+NBLST-1 + A( I, J+1 ) = WORK( PPW ) + PPW = PPW + 1 + END DO +* +* Multiply with the other accumulated orthogonal +* matrices, which take the form +* +* [ U11 U12 0 ] +* [ ] +* U = [ U21 U22 0 ], +* [ ] +* [ 0 0 I ] +* +* where I denotes the (NNB-LEN)-by-(NNB-LEN) identity +* matrix, U21 is a LEN-by-LEN upper triangular matrix +* and U12 is an NNB-by-NNB lower triangular matrix. +* + PPWO = 1 + NBLST*NBLST + J0 = JROW - NNB + DO JROW = J0, JCOL+1, -NNB + PPW = PW + LEN + DO I = JROW, JROW+NNB-1 + WORK( PPW ) = A( I, J+1 ) + PPW = PPW + 1 + END DO + PPW = PW + DO I = JROW+NNB, JROW+NNB+LEN-1 + WORK( PPW ) = A( I, J+1 ) + PPW = PPW + 1 + END DO + CALL STRMV( 'Upper', 'Transpose', 'Non-unit', LEN, + $ WORK( PPWO + NNB ), 2*NNB, WORK( PW ), + $ 1 ) + CALL STRMV( 'Lower', 'Transpose', 'Non-unit', NNB, + $ WORK( PPWO + 2*LEN*NNB ), + $ 2*NNB, WORK( PW + LEN ), 1 ) + CALL SGEMV( 'Transpose', NNB, LEN, ONE, + $ WORK( PPWO ), 2*NNB, A( JROW, J+1 ), 1, + $ ONE, WORK( PW ), 1 ) + CALL SGEMV( 'Transpose', LEN, NNB, ONE, + $ WORK( PPWO + 2*LEN*NNB + NNB ), 2*NNB, + $ A( JROW+NNB, J+1 ), 1, ONE, + $ WORK( PW+LEN ), 1 ) + PPW = PW + DO I = JROW, JROW+LEN+NNB-1 + A( I, J+1 ) = WORK( PPW ) + PPW = PPW + 1 + END DO + PPWO = PPWO + 4*NNB*NNB + END DO + END IF + END DO +* +* Apply accumulated orthogonal matrices to A. +* + COLA = N - JCOL - NNB + 1 + J = IHI - NBLST + 1 + CALL SGEMM( 'Transpose', 'No Transpose', NBLST, + $ COLA, NBLST, ONE, WORK, NBLST, + $ A( J, JCOL+NNB ), LDA, ZERO, WORK( PW ), + $ NBLST ) + CALL SLACPY( 'All', NBLST, COLA, WORK( PW ), NBLST, + $ A( J, JCOL+NNB ), LDA ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( BLK22 ) THEN +* +* Exploit the structure of +* +* [ U11 U12 ] +* U = [ ] +* [ U21 U22 ], +* +* where all blocks are NNB-by-NNB, U21 is upper +* triangular and U12 is lower triangular. +* + CALL SORM22( 'Left', 'Transpose', 2*NNB, COLA, NNB, + $ NNB, WORK( PPWO ), 2*NNB, + $ A( J, JCOL+NNB ), LDA, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL SGEMM( 'Transpose', 'No Transpose', 2*NNB, + $ COLA, 2*NNB, ONE, WORK( PPWO ), 2*NNB, + $ A( J, JCOL+NNB ), LDA, ZERO, WORK( PW ), + $ 2*NNB ) + CALL SLACPY( 'All', 2*NNB, COLA, WORK( PW ), 2*NNB, + $ A( J, JCOL+NNB ), LDA ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO +* +* Apply accumulated orthogonal matrices to Q. +* + IF( WANTQ ) THEN + J = IHI - NBLST + 1 + IF ( INITQ ) THEN + TOPQ = MAX( 2, J - JCOL + 1 ) + NH = IHI - TOPQ + 1 + ELSE + TOPQ = 1 + NH = N + END IF + CALL SGEMM( 'No Transpose', 'No Transpose', NH, + $ NBLST, NBLST, ONE, Q( TOPQ, J ), LDQ, + $ WORK, NBLST, ZERO, WORK( PW ), NH ) + CALL SLACPY( 'All', NH, NBLST, WORK( PW ), NH, + $ Q( TOPQ, J ), LDQ ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( INITQ ) THEN + TOPQ = MAX( 2, J - JCOL + 1 ) + NH = IHI - TOPQ + 1 + END IF + IF ( BLK22 ) THEN +* +* Exploit the structure of U. +* + CALL SORM22( 'Right', 'No Transpose', NH, 2*NNB, + $ NNB, NNB, WORK( PPWO ), 2*NNB, + $ Q( TOPQ, J ), LDQ, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL SGEMM( 'No Transpose', 'No Transpose', NH, + $ 2*NNB, 2*NNB, ONE, Q( TOPQ, J ), LDQ, + $ WORK( PPWO ), 2*NNB, ZERO, WORK( PW ), + $ NH ) + CALL SLACPY( 'All', NH, 2*NNB, WORK( PW ), NH, + $ Q( TOPQ, J ), LDQ ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO + END IF +* +* Accumulate right Givens rotations if required. +* + IF ( WANTZ .OR. TOP.GT.0 ) THEN +* +* Initialize small orthogonal factors that will hold the +* accumulated Givens rotations in workspace. +* + CALL SLASET( 'All', NBLST, NBLST, ZERO, ONE, WORK, + $ NBLST ) + PW = NBLST * NBLST + 1 + DO I = 1, N2NB + CALL SLASET( 'All', 2*NNB, 2*NNB, ZERO, ONE, + $ WORK( PW ), 2*NNB ) + PW = PW + 4*NNB*NNB + END DO +* +* Accumulate Givens rotations into workspace array. +* + DO J = JCOL, JCOL+NNB-1 + PPW = ( NBLST + 1 )*( NBLST - 2 ) - J + JCOL + 1 + LEN = 2 + J - JCOL + JROW = J + N2NB*NNB + 2 + DO I = IHI, JROW, -1 + C = A( I, J ) + A( I, J ) = ZERO + S = B( I, J ) + B( I, J ) = ZERO + DO JJ = PPW, PPW+LEN-1 + TEMP = WORK( JJ + NBLST ) + WORK( JJ + NBLST ) = C*TEMP - S*WORK( JJ ) + WORK( JJ ) = S*TEMP + C*WORK( JJ ) + END DO + LEN = LEN + 1 + PPW = PPW - NBLST - 1 + END DO +* + PPWO = NBLST*NBLST + ( NNB+J-JCOL-1 )*2*NNB + NNB + J0 = JROW - NNB + DO JROW = J0, J+2, -NNB + PPW = PPWO + LEN = 2 + J - JCOL + DO I = JROW+NNB-1, JROW, -1 + C = A( I, J ) + A( I, J ) = ZERO + S = B( I, J ) + B( I, J ) = ZERO + DO JJ = PPW, PPW+LEN-1 + TEMP = WORK( JJ + 2*NNB ) + WORK( JJ + 2*NNB ) = C*TEMP - S*WORK( JJ ) + WORK( JJ ) = S*TEMP + C*WORK( JJ ) + END DO + LEN = LEN + 1 + PPW = PPW - 2*NNB - 1 + END DO + PPWO = PPWO + 4*NNB*NNB + END DO + END DO + ELSE + + DO J = ILO, ILO+NNB + DO I = J+2, IHI + A( I, J ) = ZERO + B( I, J ) = ZERO + END DO + END DO + END IF +* +* Apply accumulated orthogonal matrices to A and B. +* + IF ( TOP.GT.0 ) THEN + J = IHI - NBLST + 1 + CALL SGEMM( 'No Transpose', 'No Transpose', TOP, + $ NBLST, NBLST, ONE, A( 1, J ), LDA, + $ WORK, NBLST, ZERO, WORK( PW ), TOP ) + CALL SLACPY( 'All', TOP, NBLST, WORK( PW ), TOP, + $ A( 1, J ), LDA ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( BLK22 ) THEN +* +* Exploit the structure of U. +* + CALL SORM22( 'Right', 'No Transpose', TOP, 2*NNB, + $ NNB, NNB, WORK( PPWO ), 2*NNB, + $ A( 1, J ), LDA, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL SGEMM( 'No Transpose', 'No Transpose', TOP, + $ 2*NNB, 2*NNB, ONE, A( 1, J ), LDA, + $ WORK( PPWO ), 2*NNB, ZERO, + $ WORK( PW ), TOP ) + CALL SLACPY( 'All', TOP, 2*NNB, WORK( PW ), TOP, + $ A( 1, J ), LDA ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO +* + J = IHI - NBLST + 1 + CALL SGEMM( 'No Transpose', 'No Transpose', TOP, + $ NBLST, NBLST, ONE, B( 1, J ), LDB, + $ WORK, NBLST, ZERO, WORK( PW ), TOP ) + CALL SLACPY( 'All', TOP, NBLST, WORK( PW ), TOP, + $ B( 1, J ), LDB ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( BLK22 ) THEN +* +* Exploit the structure of U. +* + CALL SORM22( 'Right', 'No Transpose', TOP, 2*NNB, + $ NNB, NNB, WORK( PPWO ), 2*NNB, + $ B( 1, J ), LDA, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL SGEMM( 'No Transpose', 'No Transpose', TOP, + $ 2*NNB, 2*NNB, ONE, B( 1, J ), LDB, + $ WORK( PPWO ), 2*NNB, ZERO, + $ WORK( PW ), TOP ) + CALL SLACPY( 'All', TOP, 2*NNB, WORK( PW ), TOP, + $ B( 1, J ), LDB ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO + END IF +* +* Apply accumulated orthogonal matrices to Z. +* + IF( WANTZ ) THEN + J = IHI - NBLST + 1 + IF ( INITQ ) THEN + TOPQ = MAX( 2, J - JCOL + 1 ) + NH = IHI - TOPQ + 1 + ELSE + TOPQ = 1 + NH = N + END IF + CALL SGEMM( 'No Transpose', 'No Transpose', NH, + $ NBLST, NBLST, ONE, Z( TOPQ, J ), LDZ, + $ WORK, NBLST, ZERO, WORK( PW ), NH ) + CALL SLACPY( 'All', NH, NBLST, WORK( PW ), NH, + $ Z( TOPQ, J ), LDZ ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( INITQ ) THEN + TOPQ = MAX( 2, J - JCOL + 1 ) + NH = IHI - TOPQ + 1 + END IF + IF ( BLK22 ) THEN +* +* Exploit the structure of U. +* + CALL SORM22( 'Right', 'No Transpose', NH, 2*NNB, + $ NNB, NNB, WORK( PPWO ), 2*NNB, + $ Z( TOPQ, J ), LDZ, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL SGEMM( 'No Transpose', 'No Transpose', NH, + $ 2*NNB, 2*NNB, ONE, Z( TOPQ, J ), LDZ, + $ WORK( PPWO ), 2*NNB, ZERO, WORK( PW ), + $ NH ) + CALL SLACPY( 'All', NH, 2*NNB, WORK( PW ), NH, + $ Z( TOPQ, J ), LDZ ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO + END IF + END DO + END IF +* +* Use unblocked code to reduce the rest of the matrix +* Avoid re-initialization of modified Q and Z. +* + COMPQ2 = COMPQ + COMPZ2 = COMPZ + IF ( JCOL.NE.ILO ) THEN + IF ( WANTQ ) + $ COMPQ2 = 'V' + IF ( WANTZ ) + $ COMPZ2 = 'V' + END IF +* + IF ( JCOL.LT.IHI ) + $ CALL SGGHRD( COMPQ2, COMPZ2, N, JCOL, IHI, A, LDA, B, LDB, Q, + $ LDQ, Z, LDZ, IERR ) + WORK( 1 ) = REAL( LWKOPT ) +* + RETURN +* +* End of SGGHD3 +* + END diff --git a/SRC/sorm22.f b/SRC/sorm22.f new file mode 100644 index 0000000..fdb5cd8 --- /dev/null +++ b/SRC/sorm22.f @@ -0,0 +1,441 @@ +*> \brief \b SORM22 multiplies a general matrix by a banded orthogonal matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SORM22 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SORM22( SIDE, TRANS, M, N, N1, N2, Q, LDQ, C, LDC, +* $ WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER M, N, N1, N2, LDQ, LDC, LWORK, INFO +* .. +* .. Array Arguments .. +* REAL Q( LDQ, * ), C( LDC, * ), WORK( * ) +* .. +* +*> \par Purpose +* ============ +*> +*> \verbatim +*> +*> +*> SORM22 overwrites the general real M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'T': Q**T * C C * Q**T +*> +*> where Q is a real orthogonal matrix of order NQ, with NQ = M if +*> SIDE = 'L' and NQ = N if SIDE = 'R'. +*> The orthogonal matrix Q processes a 2-by-2 block structure +*> +*> [ Q11 Q12 ] +*> Q = [ ] +*> [ Q21 Q22 ], +*> +*> where Q12 is an N1-by-N1 lower triangular matrix and Q21 is an +*> N2-by-N2 upper triangular matrix. +*> \endverbatim +* +* Arguments +* ========= +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply Q (No transpose); +*> = 'C': apply Q**T (Conjugate transpose). +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] N1 +*> \param[in] N2 +*> \verbatim +*> N1 is INTEGER +*> N2 is INTEGER +*> The dimension of Q12 and Q21, respectively. N1, N2 >= 0. +*> The following requirement must be satisfied: +*> N1 + N2 = M if SIDE = 'L' and N1 + N2 = N if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is REAL array, dimension +*> (LDQ,M) if SIDE = 'L' +*> (LDQ,N) if SIDE = 'R' +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. +*> LDQ >= max(1,M) if SIDE = 'L'; LDQ >= max(1,N) if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is REAL array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \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 dimension of the array WORK. +*> If SIDE = 'L', LWORK >= max(1,N); +*> if SIDE = 'R', LWORK >= max(1,M). +*> For optimum performance LWORK >= M*N. +*> +*> 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 January 2015 +* +*> \ingroup complexOTHERcomputational +* +* ===================================================================== + SUBROUTINE SORM22( SIDE, TRANS, M, N, N1, N2, Q, LDQ, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2015 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER M, N, N1, N2, LDQ, LDC, LWORK, INFO +* .. +* .. Array Arguments .. + REAL Q( LDQ, * ), C( LDC, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) +* +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + INTEGER I, LDWORK, LEN, LWKOPT, NB, NQ, NW +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SGEMM, SLACPY, STRMM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q; +* NW is the minimum dimension of WORK. +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + NW = NQ + IF( N1.EQ.0 .OR. N2.EQ.0 ) NW = 1 + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) ) + $ THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( N1.LT.0 .OR. N1+N2.NE.NQ ) THEN + INFO = -5 + ELSE IF( N2.LT.0 ) THEN + INFO = -6 + ELSE IF( LDQ.LT.MAX( 1, NQ ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN + LWKOPT = M*N + WORK( 1 ) = REAL( LWKOPT ) + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SORM22', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* Degenerate cases (N1 = 0 or N2 = 0) are handled using STRMM. +* + IF( N1.EQ.0 ) THEN + CALL STRMM( SIDE, 'Upper', TRANS, 'Non-Unit', M, N, ONE, + $ Q, LDQ, C, LDC ) + WORK( 1 ) = ONE + RETURN + ELSE IF( N2.EQ.0 ) THEN + CALL STRMM( SIDE, 'Lower', TRANS, 'Non-Unit', M, N, ONE, + $ Q, LDQ, C, LDC ) + WORK( 1 ) = ONE + RETURN + END IF +* +* Compute the largest chunk size available from the workspace. +* + NB = MAX( 1, MIN( LWORK, LWKOPT ) / NQ ) +* + IF( LEFT ) THEN + IF( NOTRAN ) THEN + DO I = 1, N, NB + LEN = MIN( NB, N-I+1 ) + LDWORK = M +* +* Multiply bottom part of C by Q12. +* + CALL SLACPY( 'All', N1, LEN, C( N2+1, I ), LDC, WORK, + $ LDWORK ) + CALL STRMM( 'Left', 'Lower', 'No Transpose', 'Non-Unit', + $ N1, LEN, ONE, Q( 1, N2+1 ), LDQ, WORK, + $ LDWORK ) +* +* Multiply top part of C by Q11. +* + CALL SGEMM( 'No Transpose', 'No Transpose', N1, LEN, N2, + $ ONE, Q, LDQ, C( 1, I ), LDC, ONE, WORK, + $ LDWORK ) +* +* Multiply top part of C by Q21. +* + CALL SLACPY( 'All', N2, LEN, C( 1, I ), LDC, + $ WORK( N1+1 ), LDWORK ) + CALL STRMM( 'Left', 'Upper', 'No Transpose', 'Non-Unit', + $ N2, LEN, ONE, Q( N1+1, 1 ), LDQ, + $ WORK( N1+1 ), LDWORK ) +* +* Multiply bottom part of C by Q22. +* + CALL SGEMM( 'No Transpose', 'No Transpose', N2, LEN, N1, + $ ONE, Q( N1+1, N2+1 ), LDQ, C( N2+1, I ), LDC, + $ ONE, WORK( N1+1 ), LDWORK ) +* +* Copy everything back. +* + CALL SLACPY( 'All', M, LEN, WORK, LDWORK, C( 1, I ), + $ LDC ) + END DO + ELSE + DO I = 1, N, NB + LEN = MIN( NB, N-I+1 ) + LDWORK = M +* +* Multiply bottom part of C by Q21**T. +* + CALL SLACPY( 'All', N2, LEN, C( N1+1, I ), LDC, WORK, + $ LDWORK ) + CALL STRMM( 'Left', 'Upper', 'Transpose', 'Non-Unit', + $ N2, LEN, ONE, Q( N1+1, 1 ), LDQ, WORK, + $ LDWORK ) +* +* Multiply top part of C by Q11**T. +* + CALL SGEMM( 'Transpose', 'No Transpose', N2, LEN, N1, + $ ONE, Q, LDQ, C( 1, I ), LDC, ONE, WORK, + $ LDWORK ) +* +* Multiply top part of C by Q12**T. +* + CALL SLACPY( 'All', N1, LEN, C( 1, I ), LDC, + $ WORK( N2+1 ), LDWORK ) + CALL STRMM( 'Left', 'Lower', 'Transpose', 'Non-Unit', + $ N1, LEN, ONE, Q( 1, N2+1 ), LDQ, + $ WORK( N2+1 ), LDWORK ) +* +* Multiply bottom part of C by Q22**T. +* + CALL SGEMM( 'Transpose', 'No Transpose', N1, LEN, N2, + $ ONE, Q( N1+1, N2+1 ), LDQ, C( N1+1, I ), LDC, + $ ONE, WORK( N2+1 ), LDWORK ) +* +* Copy everything back. +* + CALL SLACPY( 'All', M, LEN, WORK, LDWORK, C( 1, I ), + $ LDC ) + END DO + END IF + ELSE + IF( NOTRAN ) THEN + DO I = 1, M, NB + LEN = MIN( NB, M-I+1 ) + LDWORK = LEN +* +* Multiply right part of C by Q21. +* + CALL SLACPY( 'All', LEN, N2, C( I, N1+1 ), LDC, WORK, + $ LDWORK ) + CALL STRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', + $ LEN, N2, ONE, Q( N1+1, 1 ), LDQ, WORK, + $ LDWORK ) +* +* Multiply left part of C by Q11. +* + CALL SGEMM( 'No Transpose', 'No Transpose', LEN, N2, N1, + $ ONE, C( I, 1 ), LDC, Q, LDQ, ONE, WORK, + $ LDWORK ) +* +* Multiply left part of C by Q12. +* + CALL SLACPY( 'All', LEN, N1, C( I, 1 ), LDC, + $ WORK( 1 + N2*LDWORK ), LDWORK ) + CALL STRMM( 'Right', 'Lower', 'No Transpose', 'Non-Unit', + $ LEN, N1, ONE, Q( 1, N2+1 ), LDQ, + $ WORK( 1 + N2*LDWORK ), LDWORK ) +* +* Multiply right part of C by Q22. +* + CALL SGEMM( 'No Transpose', 'No Transpose', LEN, N1, N2, + $ ONE, C( I, N1+1 ), LDC, Q( N1+1, N2+1 ), LDQ, + $ ONE, WORK( 1 + N2*LDWORK ), LDWORK ) +* +* Copy everything back. +* + CALL SLACPY( 'All', LEN, N, WORK, LDWORK, C( I, 1 ), + $ LDC ) + END DO + ELSE + DO I = 1, M, NB + LEN = MIN( NB, M-I+1 ) + LDWORK = LEN +* +* Multiply right part of C by Q12**T. +* + CALL SLACPY( 'All', LEN, N1, C( I, N2+1 ), LDC, WORK, + $ LDWORK ) + CALL STRMM( 'Right', 'Lower', 'Transpose', 'Non-Unit', + $ LEN, N1, ONE, Q( 1, N2+1 ), LDQ, WORK, + $ LDWORK ) +* +* Multiply left part of C by Q11**T. +* + CALL SGEMM( 'No Transpose', 'Transpose', LEN, N1, N2, + $ ONE, C( I, 1 ), LDC, Q, LDQ, ONE, WORK, + $ LDWORK ) +* +* Multiply left part of C by Q21**T. +* + CALL SLACPY( 'All', LEN, N2, C( I, 1 ), LDC, + $ WORK( 1 + N1*LDWORK ), LDWORK ) + CALL STRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', + $ LEN, N2, ONE, Q( N1+1, 1 ), LDQ, + $ WORK( 1 + N1*LDWORK ), LDWORK ) +* +* Multiply right part of C by Q22**T. +* + CALL SGEMM( 'No Transpose', 'Transpose', LEN, N2, N1, + $ ONE, C( I, N2+1 ), LDC, Q( N1+1, N2+1 ), LDQ, + $ ONE, WORK( 1 + N1*LDWORK ), LDWORK ) +* +* Copy everything back. +* + CALL SLACPY( 'All', LEN, N, WORK, LDWORK, C( I, 1 ), + $ LDC ) + END DO + END IF + END IF +* + WORK( 1 ) = REAL( LWKOPT ) + RETURN +* +* End of SORM22 +* + END diff --git a/SRC/zgges3.f b/SRC/zgges3.f new file mode 100644 index 0000000..d445514 --- /dev/null +++ b/SRC/zgges3.f @@ -0,0 +1,595 @@ +*> \brief ZGGES3 computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices (blocked algorithm) +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZGGES3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZGGES3( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, +* $ LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, +* $ WORK, LWORK, RWORK, BWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBVSL, JOBVSR, SORT +* INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM +* .. +* .. Array Arguments .. +* LOGICAL BWORK( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), +* $ BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ), +* $ WORK( * ) +* .. +* .. Function Arguments .. +* LOGICAL SELCTG +* EXTERNAL SELCTG +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGGES3 computes for a pair of N-by-N complex nonsymmetric matrices +*> (A,B), the generalized eigenvalues, the generalized complex Schur +*> form (S, T), and optionally left and/or right Schur vectors (VSL +*> and VSR). This gives the generalized Schur factorization +*> +*> (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H ) +*> +*> where (VSR)**H is the conjugate-transpose of VSR. +*> +*> Optionally, it also orders the eigenvalues so that a selected cluster +*> of eigenvalues appears in the leading diagonal blocks of the upper +*> triangular matrix S and the upper triangular matrix T. The leading +*> columns of VSL and VSR then form an unitary basis for the +*> corresponding left and right eigenspaces (deflating subspaces). +*> +*> (If only the generalized eigenvalues are needed, use the driver +*> ZGGEV instead, which is faster.) +*> +*> A generalized eigenvalue for a pair of matrices (A,B) is a scalar w +*> or a ratio alpha/beta = w, such that A - w*B is singular. It is +*> usually represented as the pair (alpha,beta), as there is a +*> reasonable interpretation for beta=0, and even for both being zero. +*> +*> A pair of matrices (S,T) is in generalized complex Schur form if S +*> and T are upper triangular and, in addition, the diagonal elements +*> of T are non-negative real numbers. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBVSL +*> \verbatim +*> JOBVSL is CHARACTER*1 +*> = 'N': do not compute the left Schur vectors; +*> = 'V': compute the left Schur vectors. +*> \endverbatim +*> +*> \param[in] JOBVSR +*> \verbatim +*> JOBVSR is CHARACTER*1 +*> = 'N': do not compute the right Schur vectors; +*> = 'V': compute the right Schur vectors. +*> \endverbatim +*> +*> \param[in] SORT +*> \verbatim +*> SORT is CHARACTER*1 +*> Specifies whether or not to order the eigenvalues on the +*> diagonal of the generalized Schur form. +*> = 'N': Eigenvalues are not ordered; +*> = 'S': Eigenvalues are ordered (see SELCTG). +*> \endverbatim +*> +*> \param[in] SELCTG +*> \verbatim +*> SELCTG is a LOGICAL FUNCTION of two COMPLEX*16 arguments +*> SELCTG must be declared EXTERNAL in the calling subroutine. +*> If SORT = 'N', SELCTG is not referenced. +*> If SORT = 'S', SELCTG is used to select eigenvalues to sort +*> to the top left of the Schur form. +*> An eigenvalue ALPHA(j)/BETA(j) is selected if +*> SELCTG(ALPHA(j),BETA(j)) is true. +*> +*> Note that a selected complex eigenvalue may no longer satisfy +*> SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since +*> ordering may change the value of complex eigenvalues +*> (especially if the eigenvalue is ill-conditioned), in this +*> case INFO is set to N+2 (See INFO below). +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A, B, VSL, and VSR. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA, N) +*> On entry, the first of the pair of matrices. +*> On exit, A has been overwritten by its generalized Schur +*> form S. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB, N) +*> On entry, the second of the pair of matrices. +*> On exit, B has been overwritten by its generalized Schur +*> form T. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] SDIM +*> \verbatim +*> SDIM is INTEGER +*> If SORT = 'N', SDIM = 0. +*> If SORT = 'S', SDIM = number of eigenvalues (after sorting) +*> for which SELCTG is true. +*> \endverbatim +*> +*> \param[out] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 array, dimension (N) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is COMPLEX*16 array, dimension (N) +*> On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the +*> generalized eigenvalues. ALPHA(j), j=1,...,N and BETA(j), +*> j=1,...,N are the diagonals of the complex Schur form (A,B) +*> output by ZGGES3. The BETA(j) will be non-negative real. +*> +*> Note: the quotients ALPHA(j)/BETA(j) may easily over- or +*> underflow, and BETA(j) may even be zero. Thus, the user +*> should avoid naively computing the ratio alpha/beta. +*> However, ALPHA will be always less than and usually +*> comparable with norm(A) in magnitude, and BETA always less +*> than and usually comparable with norm(B). +*> \endverbatim +*> +*> \param[out] VSL +*> \verbatim +*> VSL is COMPLEX*16 array, dimension (LDVSL,N) +*> If JOBVSL = 'V', VSL will contain the left Schur vectors. +*> Not referenced if JOBVSL = 'N'. +*> \endverbatim +*> +*> \param[in] LDVSL +*> \verbatim +*> LDVSL is INTEGER +*> The leading dimension of the matrix VSL. LDVSL >= 1, and +*> if JOBVSL = 'V', LDVSL >= N. +*> \endverbatim +*> +*> \param[out] VSR +*> \verbatim +*> VSR is COMPLEX*16 array, dimension (LDVSR,N) +*> If JOBVSR = 'V', VSR will contain the right Schur vectors. +*> Not referenced if JOBVSR = 'N'. +*> \endverbatim +*> +*> \param[in] LDVSR +*> \verbatim +*> LDVSR is INTEGER +*> The leading dimension of the matrix VSR. LDVSR >= 1, and +*> if JOBVSR = 'V', LDVSR >= 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 dimension of the array WORK. +*> +*> 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 (8*N) +*> \endverbatim +*> +*> \param[out] BWORK +*> \verbatim +*> BWORK is LOGICAL array, dimension (N) +*> Not referenced if SORT = 'N'. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> =1,...,N: +*> The QZ iteration failed. (A,B) are not in Schur +*> form, but ALPHA(j) and BETA(j) should be correct for +*> j=INFO+1,...,N. +*> > N: =N+1: other than QZ iteration failed in ZHGEQZ +*> =N+2: after reordering, roundoff changed values of +*> some complex eigenvalues so that leading +*> eigenvalues in the Generalized Schur form no +*> longer satisfy SELCTG=.TRUE. This could also +*> be caused due to scaling. +*> =N+3: reordering failed in ZTGSEN. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date January 2015 +* +*> \ingroup complex16GEeigen +* +* ===================================================================== + SUBROUTINE ZGGES3( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, + $ LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, + $ WORK, LWORK, RWORK, BWORK, INFO ) +* +* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2015 +* +* .. Scalar Arguments .. + CHARACTER JOBVSL, JOBVSR, SORT + INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM +* .. +* .. Array Arguments .. + LOGICAL BWORK( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), + $ BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ), + $ WORK( * ) +* .. +* .. Function Arguments .. + LOGICAL SELCTG + EXTERNAL SELCTG +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), + $ CONE = ( 1.0D0, 0.0D0 ) ) +* .. +* .. Local Scalars .. + LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL, + $ LQUERY, WANTST + INTEGER I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, + $ ILO, IRIGHT, IROWS, IRWRK, ITAU, IWRK, LWKOPT + DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL, + $ PVSR, SMLNUM +* .. +* .. Local Arrays .. + INTEGER IDUM( 1 ) + DOUBLE PRECISION DIF( 2 ) +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, XERBLA, ZGEQRF, ZGGBAK, ZGGBAL, ZGGHD3, + $ ZHGEQZ, ZLACPY, ZLASCL, ZLASET, ZTGSEN, ZUNGQR, + $ ZUNMQR +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, ZLANGE + EXTERNAL LSAME, DLAMCH, ZLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Executable Statements .. +* +* Decode the input arguments +* + IF( LSAME( JOBVSL, 'N' ) ) THEN + IJOBVL = 1 + ILVSL = .FALSE. + ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN + IJOBVL = 2 + ILVSL = .TRUE. + ELSE + IJOBVL = -1 + ILVSL = .FALSE. + END IF +* + IF( LSAME( JOBVSR, 'N' ) ) THEN + IJOBVR = 1 + ILVSR = .FALSE. + ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN + IJOBVR = 2 + ILVSR = .TRUE. + ELSE + IJOBVR = -1 + ILVSR = .FALSE. + END IF +* + WANTST = LSAME( SORT, 'S' ) +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( IJOBVL.LE.0 ) THEN + INFO = -1 + ELSE IF( IJOBVR.LE.0 ) THEN + INFO = -2 + ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN + INFO = -14 + ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN + INFO = -16 + ELSE IF( LWORK.LT.MAX( 1, 2*N ) .AND. .NOT.LQUERY ) THEN + INFO = -18 + END IF +* +* Compute workspace +* + IF( INFO.EQ.0 ) THEN + CALL ZGEQRF( N, N, B, LDB, WORK, WORK, -1, IERR ) + LWKOPT = MAX( 1, N + INT ( WORK( 1 ) ) ) + CALL ZUNMQR( 'L', 'C', N, N, N, B, LDB, WORK, A, LDA, WORK, + $ -1, IERR ) + LWKOPT = MAX( LWKOPT, N + INT ( WORK( 1 ) ) ) + IF( ILVSL ) THEN + CALL ZUNGQR( N, N, N, VSL, LDVSL, WORK, WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, N + INT ( WORK( 1 ) ) ) + END IF + CALL ZGGHD3( JOBVSL, JOBVSR, N, 1, N, A, LDA, B, LDB, VSL, + $ LDVSL, VSR, LDVSR, WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, N + INT ( WORK( 1 ) ) ) + CALL ZHGEQZ( 'S', JOBVSL, JOBVSR, N, 1, N, A, LDA, B, LDB, + $ ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, + $ -1, RWORK, IERR ) + LWKOPT = MAX( LWKOPT, INT ( WORK( 1 ) ) ) + IF( WANTST ) THEN + CALL ZTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, + $ ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, SDIM, + $ PVSL, PVSR, DIF, WORK, -1, IDUM, 1, IERR ) + LWKOPT = MAX( LWKOPT, INT ( WORK( 1 ) ) ) + END IF + WORK( 1 ) = DCMPLX( WKOPT ) + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGGES3 ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + SDIM = 0 + RETURN + END IF +* +* Get machine constants +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SQRT( SMLNUM ) / EPS + BIGNUM = ONE / SMLNUM +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = ZLANGE( 'M', N, N, A, LDA, RWORK ) + ILASCL = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + ANRMTO = SMLNUM + ILASCL = .TRUE. + ELSE IF( ANRM.GT.BIGNUM ) THEN + ANRMTO = BIGNUM + ILASCL = .TRUE. + END IF +* + IF( ILASCL ) + $ CALL ZLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR ) +* +* Scale B if max element outside range [SMLNUM,BIGNUM] +* + BNRM = ZLANGE( 'M', N, N, B, LDB, RWORK ) + ILBSCL = .FALSE. + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN + BNRMTO = SMLNUM + ILBSCL = .TRUE. + ELSE IF( BNRM.GT.BIGNUM ) THEN + BNRMTO = BIGNUM + ILBSCL = .TRUE. + END IF +* + IF( ILBSCL ) + $ CALL ZLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR ) +* +* Permute the matrix to make it more nearly triangular +* + ILEFT = 1 + IRIGHT = N + 1 + IRWRK = IRIGHT + N + CALL ZGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, RWORK( ILEFT ), + $ RWORK( IRIGHT ), RWORK( IRWRK ), IERR ) +* +* Reduce B to triangular form (QR decomposition of B) +* + IROWS = IHI + 1 - ILO + ICOLS = N + 1 - ILO + ITAU = 1 + IWRK = ITAU + IROWS + CALL ZGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) +* +* Apply the orthogonal transformation to matrix A +* + CALL ZUNMQR( 'L', 'C', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, + $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), + $ LWORK+1-IWRK, IERR ) +* +* Initialize VSL +* + IF( ILVSL ) THEN + CALL ZLASET( 'Full', N, N, CZERO, CONE, VSL, LDVSL ) + IF( IROWS.GT.1 ) THEN + CALL ZLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, + $ VSL( ILO+1, ILO ), LDVSL ) + END IF + CALL ZUNGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL, + $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR ) + END IF +* +* Initialize VSR +* + IF( ILVSR ) + $ CALL ZLASET( 'Full', N, N, CZERO, CONE, VSR, LDVSR ) +* +* Reduce to generalized Hessenberg form +* + CALL ZGGHD3( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, + $ LDVSL, VSR, LDVSR, WORK( IWRK ), LWORK+1-IWRK, IERR ) +* + SDIM = 0 +* +* Perform QZ algorithm, computing Schur vectors if desired +* + IWRK = ITAU + CALL ZHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, + $ ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK( IWRK ), + $ LWORK+1-IWRK, RWORK( IRWRK ), IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.GT.0 .AND. IERR.LE.N ) THEN + INFO = IERR + ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN + INFO = IERR - N + ELSE + INFO = N + 1 + END IF + GO TO 30 + END IF +* +* Sort eigenvalues ALPHA/BETA if desired +* + IF( WANTST ) THEN +* +* Undo scaling on eigenvalues before selecting +* + IF( ILASCL ) + $ CALL ZLASCL( 'G', 0, 0, ANRM, ANRMTO, N, 1, ALPHA, N, IERR ) + IF( ILBSCL ) + $ CALL ZLASCL( 'G', 0, 0, BNRM, BNRMTO, N, 1, BETA, N, IERR ) +* +* Select eigenvalues +* + DO 10 I = 1, N + BWORK( I ) = SELCTG( ALPHA( I ), BETA( I ) ) + 10 CONTINUE +* + CALL ZTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, ALPHA, + $ BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PVSL, PVSR, + $ DIF, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1, IERR ) + IF( IERR.EQ.1 ) + $ INFO = N + 3 +* + END IF +* +* Apply back-permutation to VSL and VSR +* + IF( ILVSL ) + $ CALL ZGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ), + $ RWORK( IRIGHT ), N, VSL, LDVSL, IERR ) + IF( ILVSR ) + $ CALL ZGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ), + $ RWORK( IRIGHT ), N, VSR, LDVSR, IERR ) +* +* Undo scaling +* + IF( ILASCL ) THEN + CALL ZLASCL( 'U', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR ) + CALL ZLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHA, N, IERR ) + END IF +* + IF( ILBSCL ) THEN + CALL ZLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR ) + CALL ZLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) + END IF +* + IF( WANTST ) THEN +* +* Check if reordering is correct +* + LASTSL = .TRUE. + SDIM = 0 + DO 20 I = 1, N + CURSL = SELCTG( ALPHA( I ), BETA( I ) ) + IF( CURSL ) + $ SDIM = SDIM + 1 + IF( CURSL .AND. .NOT.LASTSL ) + $ INFO = N + 2 + LASTSL = CURSL + 20 CONTINUE +* + END IF +* + 30 CONTINUE +* + WORK( 1 ) = DCMPLX( LWKOPT ) +* + RETURN +* +* End of ZGGES3 +* + END diff --git a/SRC/zggev3.f b/SRC/zggev3.f new file mode 100644 index 0000000..1c4e832 --- /dev/null +++ b/SRC/zggev3.f @@ -0,0 +1,559 @@ +*> \brief ZGGEV3 computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices (blocked algorithm) +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZGGEV3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZGGEV3( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, +* VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBVL, JOBVR +* INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), +* $ BETA( * ), VL( LDVL, * ), VR( LDVR, * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGGEV3 computes for a pair of N-by-N complex nonsymmetric matrices +*> (A,B), the generalized eigenvalues, and optionally, the left and/or +*> right generalized eigenvectors. +*> +*> A generalized eigenvalue for a pair of matrices (A,B) is a scalar +*> lambda or a ratio alpha/beta = lambda, such that A - lambda*B is +*> singular. It is usually represented as the pair (alpha,beta), as +*> there is a reasonable interpretation for beta=0, and even for both +*> being zero. +*> +*> The right generalized eigenvector v(j) corresponding to the +*> generalized eigenvalue lambda(j) of (A,B) satisfies +*> +*> A * v(j) = lambda(j) * B * v(j). +*> +*> The left generalized eigenvector u(j) corresponding to the +*> generalized eigenvalues lambda(j) of (A,B) satisfies +*> +*> u(j)**H * A = lambda(j) * u(j)**H * B +*> +*> where u(j)**H is the conjugate-transpose of u(j). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBVL +*> \verbatim +*> JOBVL is CHARACTER*1 +*> = 'N': do not compute the left generalized eigenvectors; +*> = 'V': compute the left generalized eigenvectors. +*> \endverbatim +*> +*> \param[in] JOBVR +*> \verbatim +*> JOBVR is CHARACTER*1 +*> = 'N': do not compute the right generalized eigenvectors; +*> = 'V': compute the right generalized eigenvectors. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A, B, VL, and VR. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA, N) +*> On entry, the matrix A in the pair (A,B). +*> On exit, A has been overwritten. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB, N) +*> On entry, the matrix B in the pair (A,B). +*> On exit, B has been overwritten. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 array, dimension (N) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is COMPLEX*16 array, dimension (N) +*> On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the +*> generalized eigenvalues. +*> +*> Note: the quotients ALPHA(j)/BETA(j) may easily over- or +*> underflow, and BETA(j) may even be zero. Thus, the user +*> should avoid naively computing the ratio alpha/beta. +*> However, ALPHA will be always less than and usually +*> comparable with norm(A) in magnitude, and BETA always less +*> than and usually comparable with norm(B). +*> \endverbatim +*> +*> \param[out] VL +*> \verbatim +*> VL is COMPLEX*16 array, dimension (LDVL,N) +*> If JOBVL = 'V', the left generalized eigenvectors u(j) are +*> stored one after another in the columns of VL, in the same +*> order as their eigenvalues. +*> Each eigenvector is scaled so the largest component has +*> abs(real part) + abs(imag. part) = 1. +*> Not referenced if JOBVL = 'N'. +*> \endverbatim +*> +*> \param[in] LDVL +*> \verbatim +*> LDVL is INTEGER +*> The leading dimension of the matrix VL. LDVL >= 1, and +*> if JOBVL = 'V', LDVL >= N. +*> \endverbatim +*> +*> \param[out] VR +*> \verbatim +*> VR is COMPLEX*16 array, dimension (LDVR,N) +*> If JOBVR = 'V', the right generalized eigenvectors v(j) are +*> stored one after another in the columns of VR, in the same +*> order as their eigenvalues. +*> Each eigenvector is scaled so the largest component has +*> abs(real part) + abs(imag. part) = 1. +*> Not referenced if JOBVR = 'N'. +*> \endverbatim +*> +*> \param[in] LDVR +*> \verbatim +*> LDVR is INTEGER +*> The leading dimension of the matrix VR. LDVR >= 1, and +*> if JOBVR = 'V', LDVR >= 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 dimension of the array WORK. +*> +*> 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 (8*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> =1,...,N: +*> The QZ iteration failed. No eigenvectors have been +*> calculated, but ALPHA(j) and BETA(j) should be +*> correct for j=INFO+1,...,N. +*> > N: =N+1: other then QZ iteration failed in DHGEQZ, +*> =N+2: error return from DTGEVC. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date January 2015 +* +*> \ingroup complex16GEeigen +* +* ===================================================================== + SUBROUTINE ZGGEV3( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, + $ VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) +* +* -- LAPACK driver routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2015 +* +* .. Scalar Arguments .. + CHARACTER JOBVL, JOBVR + INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), + $ BETA( * ), VL( LDVL, * ), VR( LDVR, * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), + $ CONE = ( 1.0D0, 0.0D0 ) ) +* .. +* .. Local Scalars .. + LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY + CHARACTER CHTEMP + INTEGER ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO, + $ IN, IRIGHT, IROWS, IRWRK, ITAU, IWRK, JC, JR, + $ LWKOPT + DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, + $ SMLNUM, TEMP + COMPLEX*16 X +* .. +* .. Local Arrays .. + LOGICAL LDUMMA( 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, XERBLA, ZGEQRF, ZGGBAK, ZGGBAL, ZGGHD3, + $ ZHGEQZ, ZLACPY, ZLASCL, ZLASET, ZTGEVC, ZUNGQR, + $ ZUNMQR +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, ZLANGE + EXTERNAL LSAME, DLAMCH, ZLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DIMAG, MAX, SQRT +* .. +* .. Statement Functions .. + DOUBLE PRECISION ABS1 +* .. +* .. Statement Function definitions .. + ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) ) +* .. +* .. Executable Statements .. +* +* Decode the input arguments +* + IF( LSAME( JOBVL, 'N' ) ) THEN + IJOBVL = 1 + ILVL = .FALSE. + ELSE IF( LSAME( JOBVL, 'V' ) ) THEN + IJOBVL = 2 + ILVL = .TRUE. + ELSE + IJOBVL = -1 + ILVL = .FALSE. + END IF +* + IF( LSAME( JOBVR, 'N' ) ) THEN + IJOBVR = 1 + ILVR = .FALSE. + ELSE IF( LSAME( JOBVR, 'V' ) ) THEN + IJOBVR = 2 + ILVR = .TRUE. + ELSE + IJOBVR = -1 + ILVR = .FALSE. + END IF + ILV = ILVL .OR. ILVR +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( IJOBVL.LE.0 ) THEN + INFO = -1 + ELSE IF( IJOBVR.LE.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN + INFO = -11 + ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN + INFO = -13 + ELSE IF( LWORK.LT.MAX( 1, 2*N ) .AND. .NOT.LQUERY ) THEN + INFO = -15 + END IF +* +* Compute workspace +* + IF( INFO.EQ.0 ) THEN + CALL ZGEQRF( N, N, B, LDB, WORK, WORK, -1, IERR ) + LWKOPT = MAX( 1, N+INT( WORK( 1 ) ) ) + CALL ZUNMQR( 'L', 'C', N, N, N, B, LDB, WORK, A, LDA, WORK, + $ -1, IERR ) + LWKOPT = MAX( LWKOPT, N+INT( WORK( 1 ) ) ) + IF( ILVL ) THEN + CALL ZUNGQR( N, N, N, VL, LDVL, WORK, WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, N+INT( WORK( 1 ) ) ) + END IF + IF( ILV ) THEN + CALL ZGGHD3( JOBVL, JOBVR, N, 1, N, A, LDA, B, LDB, VL, + $ LDVL, VR, LDVR, WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, N+INT( WORK( 1 ) ) ) + CALL ZHGEQZ( 'S', JOBVL, JOBVR, N, 1, N, A, LDA, B, LDB, + $ ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, -1, + $ WORK, IERR ) + LWKOPT = MAX( LWKOPT, N+INT( WORK( 1 ) ) ) + ELSE + CALL ZGGHD3( JOBVL, JOBVR, N, 1, N, A, LDA, B, LDB, VL, + $ LDVL, VR, LDVR, WORK, -1, IERR ) + LWKOPT = MAX( LWKOPT, N+INT( WORK( 1 ) ) ) + CALL ZHGEQZ( 'E', JOBVL, JOBVR, N, 1, N, A, LDA, B, LDB, + $ ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, -1, + $ WORK, IERR ) + LWKOPT = MAX( LWKOPT, N+INT( WORK( 1 ) ) ) + END IF + WORK( 1 ) = DCMPLX( LWKOPT ) + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGGEV3 ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Get machine constants +* + EPS = DLAMCH( 'E' )*DLAMCH( 'B' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SQRT( SMLNUM ) / EPS + BIGNUM = ONE / SMLNUM +* +* Scale A if max element outside range [SMLNUM,BIGNUM] +* + ANRM = ZLANGE( 'M', N, N, A, LDA, RWORK ) + ILASCL = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + ANRMTO = SMLNUM + ILASCL = .TRUE. + ELSE IF( ANRM.GT.BIGNUM ) THEN + ANRMTO = BIGNUM + ILASCL = .TRUE. + END IF + IF( ILASCL ) + $ CALL ZLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR ) +* +* Scale B if max element outside range [SMLNUM,BIGNUM] +* + BNRM = ZLANGE( 'M', N, N, B, LDB, RWORK ) + ILBSCL = .FALSE. + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN + BNRMTO = SMLNUM + ILBSCL = .TRUE. + ELSE IF( BNRM.GT.BIGNUM ) THEN + BNRMTO = BIGNUM + ILBSCL = .TRUE. + END IF + IF( ILBSCL ) + $ CALL ZLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR ) +* +* Permute the matrices A, B to isolate eigenvalues if possible +* + ILEFT = 1 + IRIGHT = N + 1 + IRWRK = IRIGHT + N + CALL ZGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, RWORK( ILEFT ), + $ RWORK( IRIGHT ), RWORK( IRWRK ), IERR ) +* +* Reduce B to triangular form (QR decomposition of B) +* + IROWS = IHI + 1 - ILO + IF( ILV ) THEN + ICOLS = N + 1 - ILO + ELSE + ICOLS = IROWS + END IF + ITAU = 1 + IWRK = ITAU + IROWS + CALL ZGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) +* +* Apply the orthogonal transformation to matrix A +* + CALL ZUNMQR( 'L', 'C', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, + $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), + $ LWORK+1-IWRK, IERR ) +* +* Initialize VL +* + IF( ILVL ) THEN + CALL ZLASET( 'Full', N, N, CZERO, CONE, VL, LDVL ) + IF( IROWS.GT.1 ) THEN + CALL ZLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, + $ VL( ILO+1, ILO ), LDVL ) + END IF + CALL ZUNGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL, + $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR ) + END IF +* +* Initialize VR +* + IF( ILVR ) + $ CALL ZLASET( 'Full', N, N, CZERO, CONE, VR, LDVR ) +* +* Reduce to generalized Hessenberg form +* + IF( ILV ) THEN +* +* Eigenvectors requested -- work on whole matrix. +* + CALL ZGGHD3( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL, + $ LDVL, VR, LDVR, WORK( IWRK ), LWORK+1-IWRK, IERR ) + ELSE + CALL ZGGHD3( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA, + $ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, + $ WORK( IWRK ), LWORK+1-IWRK, IERR ) + END IF +* +* Perform QZ algorithm (Compute eigenvalues, and optionally, the +* Schur form and Schur vectors) +* + IWRK = ITAU + IF( ILV ) THEN + CHTEMP = 'S' + ELSE + CHTEMP = 'E' + END IF + CALL ZHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, + $ ALPHA, BETA, VL, LDVL, VR, LDVR, WORK( IWRK ), + $ LWORK+1-IWRK, RWORK( IRWRK ), IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.GT.0 .AND. IERR.LE.N ) THEN + INFO = IERR + ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN + INFO = IERR - N + ELSE + INFO = N + 1 + END IF + GO TO 70 + END IF +* +* Compute Eigenvectors +* + IF( ILV ) THEN + IF( ILVL ) THEN + IF( ILVR ) THEN + CHTEMP = 'B' + ELSE + CHTEMP = 'L' + END IF + ELSE + CHTEMP = 'R' + END IF +* + CALL ZTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL, + $ VR, LDVR, N, IN, WORK( IWRK ), RWORK( IRWRK ), + $ IERR ) + IF( IERR.NE.0 ) THEN + INFO = N + 2 + GO TO 70 + END IF +* +* Undo balancing on VL and VR and normalization +* + IF( ILVL ) THEN + CALL ZGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ), + $ RWORK( IRIGHT ), N, VL, LDVL, IERR ) + DO 30 JC = 1, N + TEMP = ZERO + DO 10 JR = 1, N + TEMP = MAX( TEMP, ABS1( VL( JR, JC ) ) ) + 10 CONTINUE + IF( TEMP.LT.SMLNUM ) + $ GO TO 30 + TEMP = ONE / TEMP + DO 20 JR = 1, N + VL( JR, JC ) = VL( JR, JC )*TEMP + 20 CONTINUE + 30 CONTINUE + END IF + IF( ILVR ) THEN + CALL ZGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ), + $ RWORK( IRIGHT ), N, VR, LDVR, IERR ) + DO 60 JC = 1, N + TEMP = ZERO + DO 40 JR = 1, N + TEMP = MAX( TEMP, ABS1( VR( JR, JC ) ) ) + 40 CONTINUE + IF( TEMP.LT.SMLNUM ) + $ GO TO 60 + TEMP = ONE / TEMP + DO 50 JR = 1, N + VR( JR, JC ) = VR( JR, JC )*TEMP + 50 CONTINUE + 60 CONTINUE + END IF + END IF +* +* Undo scaling if necessary +* + 70 CONTINUE +* + IF( ILASCL ) + $ CALL ZLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHA, N, IERR ) +* + IF( ILBSCL ) + $ CALL ZLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) +* + WORK( 1 ) = DCMPLX( LWKOPT ) + RETURN +* +* End of ZGGEV3 +* + END diff --git a/SRC/zgghd3.f b/SRC/zgghd3.f new file mode 100644 index 0000000..55952a4 --- /dev/null +++ b/SRC/zgghd3.f @@ -0,0 +1,896 @@ +*> \brief \b ZGGHD3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZGGHD3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZGGHD3( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, +* LDQ, Z, LDZ, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER COMPQ, COMPZ +* INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N, LWORK +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ), +* $ Z( LDZ, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGGHD3 reduces a pair of complex matrices (A,B) to generalized upper +*> Hessenberg form using unitary transformations, where A is a +*> general matrix and B is upper triangular. The form of the +*> generalized eigenvalue problem is +*> A*x = lambda*B*x, +*> and B is typically made upper triangular by computing its QR +*> factorization and moving the unitary matrix Q to the left side +*> of the equation. +*> +*> This subroutine simultaneously reduces A to a Hessenberg matrix H: +*> Q**H*A*Z = H +*> and transforms B to another upper triangular matrix T: +*> Q**H*B*Z = T +*> in order to reduce the problem to its standard form +*> H*y = lambda*T*y +*> where y = Z**H*x. +*> +*> The unitary matrices Q and Z are determined as products of Givens +*> rotations. They may either be formed explicitly, or they may be +*> postmultiplied into input matrices Q1 and Z1, so that +*> Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H +*> Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H +*> If Q1 is the unitary matrix from the QR factorization of B in the +*> original equation A*x = lambda*B*x, then ZGGHD3 reduces the original +*> problem to generalized Hessenberg form. +*> +*> This is a blocked variant of CGGHRD, using matrix-matrix +*> multiplications for parts of the computation to enhance performance. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] COMPQ +*> \verbatim +*> COMPQ is CHARACTER*1 +*> = 'N': do not compute Q; +*> = 'I': Q is initialized to the unit matrix, and the +*> unitary matrix Q is returned; +*> = 'V': Q must contain a unitary matrix Q1 on entry, +*> and the product Q1*Q is returned. +*> \endverbatim +*> +*> \param[in] COMPZ +*> \verbatim +*> COMPZ is CHARACTER*1 +*> = 'N': do not compute Z; +*> = 'I': Z is initialized to the unit matrix, and the +*> unitary matrix Z is returned; +*> = 'V': Z must contain a unitary matrix Z1 on entry, +*> and the product Z1*Z is returned. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> +*> ILO and IHI mark the rows and columns of A which are to be +*> reduced. It is assumed that A is already upper triangular +*> in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are +*> normally set by a previous call to ZGGBAL; otherwise they +*> should be set to 1 and N respectively. +*> 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA, N) +*> On entry, the N-by-N general matrix to be reduced. +*> On exit, the upper triangle and the first subdiagonal of A +*> are overwritten with the upper Hessenberg matrix H, and the +*> rest is set to zero. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (LDB, N) +*> On entry, the N-by-N upper triangular matrix B. +*> On exit, the upper triangular matrix T = Q**H B Z. The +*> elements below the diagonal are set to zero. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] Q +*> \verbatim +*> Q is COMPLEX*16 array, dimension (LDQ, N) +*> On entry, if COMPQ = 'V', the unitary matrix Q1, typically +*> from the QR factorization of B. +*> On exit, if COMPQ='I', the unitary matrix Q, and if +*> COMPQ = 'V', the product Q1*Q. +*> Not referenced if COMPQ='N'. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. +*> LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is COMPLEX*16 array, dimension (LDZ, N) +*> On entry, if COMPZ = 'V', the unitary matrix Z1. +*> On exit, if COMPZ='I', the unitary matrix Z, and if +*> COMPZ = 'V', the product Z1*Z. +*> Not referenced if COMPZ='N'. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. +*> LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (LWORK) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= 1. +*> For optimum performance LWORK >= 6*N*NB, where NB is the +*> optimal blocksize. +*> +*> 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 January 2015 +* +*> \ingroup complex16OTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> This routine reduces A to Hessenberg form and maintains B in +*> using a blocked variant of Moler and Stewart's original algorithm, +*> as described by Kagstrom, Kressner, Quintana-Orti, and Quintana-Orti +*> (BIT 2008). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGGHD3( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, + $ LDQ, Z, LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2015 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ + INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N, LWORK +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ), + $ Z( LDZ, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 CONE, CZERO + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), + $ CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL BLK22, INITQ, INITZ, LQUERY, WANTQ, WANTZ + CHARACTER*1 COMPQ2, COMPZ2 + INTEGER COLA, I, IERR, J, J0, JCOL, JJ, JROW, K, + $ KACC22, LEN, LWKOPT, N2NB, NB, NBLST, NBMIN, + $ NH, NNB, NX, PPW, PPWO, PW, TOP, TOPQ + DOUBLE PRECISION C + COMPLEX*16 C1, C2, CTEMP, S, S1, S2, TEMP, TEMP1, TEMP2, + $ TEMP3 +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZGGHRD, ZLARTG, ZLASET, ZUNM22, ZROT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX, DCONJG, MAX +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters. +* + INFO = 0 + NB = ILAENV( 1, 'ZGGHD3', ' ', N, ILO, IHI, -1 ) + LWKOPT = 6*N*NB + WORK( 1 ) = DCMPLX( LWKOPT ) + INITQ = LSAME( COMPQ, 'I' ) + WANTQ = INITQ .OR. LSAME( COMPQ, 'V' ) + INITZ = LSAME( COMPZ, 'I' ) + WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) + LQUERY = ( LWORK.EQ.-1 ) +* + IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( ILO.LT.1 ) THEN + INFO = -4 + ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( ( WANTQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN + INFO = -11 + ELSE IF( ( WANTZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN + INFO = -13 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -15 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGGHD3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Initialize Q and Z if desired. +* + IF( INITQ ) + $ CALL ZLASET( 'All', N, N, CZERO, CONE, Q, LDQ ) + IF( INITZ ) + $ CALL ZLASET( 'All', N, N, CZERO, CONE, Z, LDZ ) +* +* Zero out lower triangle of B. +* + IF( N.GT.1 ) + $ CALL ZLASET( 'Lower', N-1, N-1, CZERO, CZERO, B(2, 1), LDB ) +* +* Quick return if possible +* + NH = IHI - ILO + 1 + IF( NH.LE.1 ) THEN + WORK( 1 ) = CONE + RETURN + END IF +* +* Determine the blocksize. +* + NBMIN = ILAENV( 2, 'ZGGHD3', ' ', N, ILO, IHI, -1 ) + IF( NB.GT.1 .AND. NB.LT.NH ) THEN +* +* Determine when to use unblocked instead of blocked code. +* + NX = MAX( NB, ILAENV( 3, 'ZGGHD3', ' ', N, ILO, IHI, -1 ) ) + IF( NX.LT.NH ) THEN +* +* Determine if workspace is large enough for blocked code. +* + IF( LWORK.LT.LWKOPT ) THEN +* +* Not enough workspace to use optimal NB: determine the +* minimum value of NB, and reduce NB or force use of +* unblocked code. +* + NBMIN = MAX( 2, ILAENV( 2, 'ZGGHD3', ' ', N, ILO, IHI, + $ -1 ) ) + IF( LWORK.GE.6*N*NBMIN ) THEN + NB = LWORK / ( 6*N ) + ELSE + NB = 1 + END IF + END IF + END IF + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN +* +* Use unblocked code below +* + JCOL = ILO +* + ELSE +* +* Use blocked code +* + KACC22 = ILAENV( 16, 'ZGGHD3', ' ', N, ILO, IHI, -1 ) + BLK22 = KACC22.EQ.2 + DO JCOL = ILO, IHI-2, NB + NNB = MIN( NB, IHI-JCOL-1 ) +* +* Initialize small unitary factors that will hold the +* accumulated Givens rotations in workspace. +* N2NB denotes the number of 2*NNB-by-2*NNB factors +* NBLST denotes the (possibly smaller) order of the last +* factor. +* + N2NB = ( IHI-JCOL-1 ) / NNB - 1 + NBLST = IHI - JCOL - N2NB*NNB + CALL ZLASET( 'All', NBLST, NBLST, CZERO, CONE, WORK, NBLST ) + PW = NBLST * NBLST + 1 + DO I = 1, N2NB + CALL ZLASET( 'All', 2*NNB, 2*NNB, CZERO, CONE, + $ WORK( PW ), 2*NNB ) + PW = PW + 4*NNB*NNB + END DO +* +* Reduce columns JCOL:JCOL+NNB-1 of A to Hessenberg form. +* + DO J = JCOL, JCOL+NNB-1 +* +* Reduce Jth column of A. Store cosines and sines in Jth +* column of A and B, respectively. +* + DO I = IHI, J+2, -1 + TEMP = A( I-1, J ) + CALL ZLARTG( TEMP, A( I, J ), C, S, A( I-1, J ) ) + A( I, J ) = DCMPLX( C ) + B( I, J ) = S + END DO +* +* Accumulate Givens rotations into workspace array. +* + PPW = ( NBLST + 1 )*( NBLST - 2 ) - J + JCOL + 1 + LEN = 2 + J - JCOL + JROW = J + N2NB*NNB + 2 + DO I = IHI, JROW, -1 + CTEMP = A( I, J ) + S = B( I, J ) + DO JJ = PPW, PPW+LEN-1 + TEMP = WORK( JJ + NBLST ) + WORK( JJ + NBLST ) = CTEMP*TEMP - S*WORK( JJ ) + WORK( JJ ) = DCONJG( S )*TEMP + CTEMP*WORK( JJ ) + END DO + LEN = LEN + 1 + PPW = PPW - NBLST - 1 + END DO +* + PPWO = NBLST*NBLST + ( NNB+J-JCOL-1 )*2*NNB + NNB + J0 = JROW - NNB + DO JROW = J0, J+2, -NNB + PPW = PPWO + LEN = 2 + J - JCOL + DO I = JROW+NNB-1, JROW, -1 + CTEMP = A( I, J ) + S = B( I, J ) + DO JJ = PPW, PPW+LEN-1 + TEMP = WORK( JJ + 2*NNB ) + WORK( JJ + 2*NNB ) = CTEMP*TEMP - S*WORK( JJ ) + WORK( JJ ) = DCONJG( S )*TEMP + CTEMP*WORK( JJ ) + END DO + LEN = LEN + 1 + PPW = PPW - 2*NNB - 1 + END DO + PPWO = PPWO + 4*NNB*NNB + END DO +* +* TOP denotes the number of top rows in A and B that will +* not be updated during the next steps. +* + IF( JCOL.LE.2 ) THEN + TOP = 0 + ELSE + TOP = JCOL + END IF +* +* Propagate transformations through B and replace stored +* left sines/cosines by right sines/cosines. +* + DO JJ = N, J+1, -1 +* +* Update JJth column of B. +* + DO I = MIN( JJ+1, IHI ), J+2, -1 + CTEMP = A( I, J ) + S = B( I, J ) + TEMP = B( I, JJ ) + B( I, JJ ) = CTEMP*TEMP - DCONJG( S )*B( I-1, JJ ) + B( I-1, JJ ) = S*TEMP + CTEMP*B( I-1, JJ ) + END DO +* +* Annihilate B( JJ+1, JJ ). +* + IF( JJ.LT.IHI ) THEN + TEMP = B( JJ+1, JJ+1 ) + CALL ZLARTG( TEMP, B( JJ+1, JJ ), C, S, + $ B( JJ+1, JJ+1 ) ) + B( JJ+1, JJ ) = CZERO + CALL ZROT( JJ-TOP, B( TOP+1, JJ+1 ), 1, + $ B( TOP+1, JJ ), 1, C, S ) + A( JJ+1, J ) = DCMPLX( C ) + B( JJ+1, J ) = -DCONJG( S ) + END IF + END DO +* +* Update A by transformations from right. +* + JJ = MOD( IHI-J-1, 3 ) + DO I = IHI-J-3, JJ+1, -3 + CTEMP = A( J+1+I, J ) + S = -B( J+1+I, J ) + C1 = A( J+2+I, J ) + S1 = -B( J+2+I, J ) + C2 = A( J+3+I, J ) + S2 = -B( J+3+I, J ) +* + DO K = TOP+1, IHI + TEMP = A( K, J+I ) + TEMP1 = A( K, J+I+1 ) + TEMP2 = A( K, J+I+2 ) + TEMP3 = A( K, J+I+3 ) + A( K, J+I+3 ) = C2*TEMP3 + DCONJG( S2 )*TEMP2 + TEMP2 = -S2*TEMP3 + C2*TEMP2 + A( K, J+I+2 ) = C1*TEMP2 + DCONJG( S1 )*TEMP1 + TEMP1 = -S1*TEMP2 + C1*TEMP1 + A( K, J+I+1 ) = CTEMP*TEMP1 + DCONJG( S )*TEMP + A( K, J+I ) = -S*TEMP1 + CTEMP*TEMP + END DO + END DO +* + IF( JJ.GT.0 ) THEN + DO I = JJ, 1, -1 + C = DBLE( A( J+1+I, J ) ) + CALL ZROT( IHI-TOP, A( TOP+1, J+I+1 ), 1, + $ A( TOP+1, J+I ), 1, C, + $ -DCONJG( B( J+1+I, J ) ) ) + END DO + END IF +* +* Update (J+1)th column of A by transformations from left. +* + IF ( J .LT. JCOL + NNB - 1 ) THEN + LEN = 1 + J - JCOL +* +* Multiply with the trailing accumulated unitary +* matrix, which takes the form +* +* [ U11 U12 ] +* U = [ ], +* [ U21 U22 ] +* +* where U21 is a LEN-by-LEN matrix and U12 is lower +* triangular. +* + JROW = IHI - NBLST + 1 + CALL ZGEMV( 'Conjugate', NBLST, LEN, CONE, WORK, + $ NBLST, A( JROW, J+1 ), 1, CZERO, + $ WORK( PW ), 1 ) + PPW = PW + LEN + DO I = JROW, JROW+NBLST-LEN-1 + WORK( PPW ) = A( I, J+1 ) + PPW = PPW + 1 + END DO + CALL ZTRMV( 'Lower', 'Conjugate', 'Non-unit', + $ NBLST-LEN, WORK( LEN*NBLST + 1 ), NBLST, + $ WORK( PW+LEN ), 1 ) + CALL ZGEMV( 'Conjugate', LEN, NBLST-LEN, CONE, + $ WORK( (LEN+1)*NBLST - LEN + 1 ), NBLST, + $ A( JROW+NBLST-LEN, J+1 ), 1, CONE, + $ WORK( PW+LEN ), 1 ) + PPW = PW + DO I = JROW, JROW+NBLST-1 + A( I, J+1 ) = WORK( PPW ) + PPW = PPW + 1 + END DO +* +* Multiply with the other accumulated unitary +* matrices, which take the form +* +* [ U11 U12 0 ] +* [ ] +* U = [ U21 U22 0 ], +* [ ] +* [ 0 0 I ] +* +* where I denotes the (NNB-LEN)-by-(NNB-LEN) identity +* matrix, U21 is a LEN-by-LEN upper triangular matrix +* and U12 is an NNB-by-NNB lower triangular matrix. +* + PPWO = 1 + NBLST*NBLST + J0 = JROW - NNB + DO JROW = J0, JCOL+1, -NNB + PPW = PW + LEN + DO I = JROW, JROW+NNB-1 + WORK( PPW ) = A( I, J+1 ) + PPW = PPW + 1 + END DO + PPW = PW + DO I = JROW+NNB, JROW+NNB+LEN-1 + WORK( PPW ) = A( I, J+1 ) + PPW = PPW + 1 + END DO + CALL ZTRMV( 'Upper', 'Conjugate', 'Non-unit', LEN, + $ WORK( PPWO + NNB ), 2*NNB, WORK( PW ), + $ 1 ) + CALL ZTRMV( 'Lower', 'Conjugate', 'Non-unit', NNB, + $ WORK( PPWO + 2*LEN*NNB ), + $ 2*NNB, WORK( PW + LEN ), 1 ) + CALL ZGEMV( 'Conjugate', NNB, LEN, CONE, + $ WORK( PPWO ), 2*NNB, A( JROW, J+1 ), 1, + $ CONE, WORK( PW ), 1 ) + CALL ZGEMV( 'Conjugate', LEN, NNB, CONE, + $ WORK( PPWO + 2*LEN*NNB + NNB ), 2*NNB, + $ A( JROW+NNB, J+1 ), 1, CONE, + $ WORK( PW+LEN ), 1 ) + PPW = PW + DO I = JROW, JROW+LEN+NNB-1 + A( I, J+1 ) = WORK( PPW ) + PPW = PPW + 1 + END DO + PPWO = PPWO + 4*NNB*NNB + END DO + END IF + END DO +* +* Apply accumulated unitary matrices to A. +* + COLA = N - JCOL - NNB + 1 + J = IHI - NBLST + 1 + CALL ZGEMM( 'Conjugate', 'No Transpose', NBLST, + $ COLA, NBLST, CONE, WORK, NBLST, + $ A( J, JCOL+NNB ), LDA, CZERO, WORK( PW ), + $ NBLST ) + CALL ZLACPY( 'All', NBLST, COLA, WORK( PW ), NBLST, + $ A( J, JCOL+NNB ), LDA ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( BLK22 ) THEN +* +* Exploit the structure of +* +* [ U11 U12 ] +* U = [ ] +* [ U21 U22 ], +* +* where all blocks are NNB-by-NNB, U21 is upper +* triangular and U12 is lower triangular. +* + CALL ZUNM22( 'Left', 'Conjugate', 2*NNB, COLA, NNB, + $ NNB, WORK( PPWO ), 2*NNB, + $ A( J, JCOL+NNB ), LDA, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL ZGEMM( 'Conjugate', 'No Transpose', 2*NNB, + $ COLA, 2*NNB, CONE, WORK( PPWO ), 2*NNB, + $ A( J, JCOL+NNB ), LDA, CZERO, WORK( PW ), + $ 2*NNB ) + CALL ZLACPY( 'All', 2*NNB, COLA, WORK( PW ), 2*NNB, + $ A( J, JCOL+NNB ), LDA ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO +* +* Apply accumulated unitary matrices to Q. +* + IF( WANTQ ) THEN + J = IHI - NBLST + 1 + IF ( INITQ ) THEN + TOPQ = MAX( 2, J - JCOL + 1 ) + NH = IHI - TOPQ + 1 + ELSE + TOPQ = 1 + NH = N + END IF + CALL ZGEMM( 'No Transpose', 'No Transpose', NH, + $ NBLST, NBLST, CONE, Q( TOPQ, J ), LDQ, + $ WORK, NBLST, CZERO, WORK( PW ), NH ) + CALL ZLACPY( 'All', NH, NBLST, WORK( PW ), NH, + $ Q( TOPQ, J ), LDQ ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( INITQ ) THEN + TOPQ = MAX( 2, J - JCOL + 1 ) + NH = IHI - TOPQ + 1 + END IF + IF ( BLK22 ) THEN +* +* Exploit the structure of U. +* + CALL ZUNM22( 'Right', 'No Transpose', NH, 2*NNB, + $ NNB, NNB, WORK( PPWO ), 2*NNB, + $ Q( TOPQ, J ), LDQ, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL ZGEMM( 'No Transpose', 'No Transpose', NH, + $ 2*NNB, 2*NNB, CONE, Q( TOPQ, J ), LDQ, + $ WORK( PPWO ), 2*NNB, CZERO, WORK( PW ), + $ NH ) + CALL ZLACPY( 'All', NH, 2*NNB, WORK( PW ), NH, + $ Q( TOPQ, J ), LDQ ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO + END IF +* +* Accumulate right Givens rotations if required. +* + IF ( WANTZ .OR. TOP.GT.0 ) THEN +* +* Initialize small unitary factors that will hold the +* accumulated Givens rotations in workspace. +* + CALL ZLASET( 'All', NBLST, NBLST, CZERO, CONE, WORK, + $ NBLST ) + PW = NBLST * NBLST + 1 + DO I = 1, N2NB + CALL ZLASET( 'All', 2*NNB, 2*NNB, CZERO, CONE, + $ WORK( PW ), 2*NNB ) + PW = PW + 4*NNB*NNB + END DO +* +* Accumulate Givens rotations into workspace array. +* + DO J = JCOL, JCOL+NNB-1 + PPW = ( NBLST + 1 )*( NBLST - 2 ) - J + JCOL + 1 + LEN = 2 + J - JCOL + JROW = J + N2NB*NNB + 2 + DO I = IHI, JROW, -1 + CTEMP = A( I, J ) + A( I, J ) = CZERO + S = B( I, J ) + B( I, J ) = CZERO + DO JJ = PPW, PPW+LEN-1 + TEMP = WORK( JJ + NBLST ) + WORK( JJ + NBLST ) = CTEMP*TEMP - + $ DCONJG( S )*WORK( JJ ) + WORK( JJ ) = S*TEMP + CTEMP*WORK( JJ ) + END DO + LEN = LEN + 1 + PPW = PPW - NBLST - 1 + END DO +* + PPWO = NBLST*NBLST + ( NNB+J-JCOL-1 )*2*NNB + NNB + J0 = JROW - NNB + DO JROW = J0, J+2, -NNB + PPW = PPWO + LEN = 2 + J - JCOL + DO I = JROW+NNB-1, JROW, -1 + CTEMP = A( I, J ) + A( I, J ) = CZERO + S = B( I, J ) + B( I, J ) = CZERO + DO JJ = PPW, PPW+LEN-1 + TEMP = WORK( JJ + 2*NNB ) + WORK( JJ + 2*NNB ) = CTEMP*TEMP - + $ DCONJG( S )*WORK( JJ ) + WORK( JJ ) = S*TEMP + CTEMP*WORK( JJ ) + END DO + LEN = LEN + 1 + PPW = PPW - 2*NNB - 1 + END DO + PPWO = PPWO + 4*NNB*NNB + END DO + END DO + ELSE + + DO J = ILO, ILO+NNB + DO I = J+2, IHI + A( I, J ) = CZERO + B( I, J ) = CZERO + END DO + END DO + END IF +* +* Apply accumulated unitary matrices to A and B. +* + IF ( TOP.GT.0 ) THEN + J = IHI - NBLST + 1 + CALL ZGEMM( 'No Transpose', 'No Transpose', TOP, + $ NBLST, NBLST, CONE, A( 1, J ), LDA, + $ WORK, NBLST, CZERO, WORK( PW ), TOP ) + CALL ZLACPY( 'All', TOP, NBLST, WORK( PW ), TOP, + $ A( 1, J ), LDA ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( BLK22 ) THEN +* +* Exploit the structure of U. +* + CALL ZUNM22( 'Right', 'No Transpose', TOP, 2*NNB, + $ NNB, NNB, WORK( PPWO ), 2*NNB, + $ A( 1, J ), LDA, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL ZGEMM( 'No Transpose', 'No Transpose', TOP, + $ 2*NNB, 2*NNB, CONE, A( 1, J ), LDA, + $ WORK( PPWO ), 2*NNB, CZERO, + $ WORK( PW ), TOP ) + CALL ZLACPY( 'All', TOP, 2*NNB, WORK( PW ), TOP, + $ A( 1, J ), LDA ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO +* + J = IHI - NBLST + 1 + CALL ZGEMM( 'No Transpose', 'No Transpose', TOP, + $ NBLST, NBLST, CONE, B( 1, J ), LDB, + $ WORK, NBLST, CZERO, WORK( PW ), TOP ) + CALL ZLACPY( 'All', TOP, NBLST, WORK( PW ), TOP, + $ B( 1, J ), LDB ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( BLK22 ) THEN +* +* Exploit the structure of U. +* + CALL ZUNM22( 'Right', 'No Transpose', TOP, 2*NNB, + $ NNB, NNB, WORK( PPWO ), 2*NNB, + $ B( 1, J ), LDA, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL ZGEMM( 'No Transpose', 'No Transpose', TOP, + $ 2*NNB, 2*NNB, CONE, B( 1, J ), LDB, + $ WORK( PPWO ), 2*NNB, CZERO, + $ WORK( PW ), TOP ) + CALL ZLACPY( 'All', TOP, 2*NNB, WORK( PW ), TOP, + $ B( 1, J ), LDB ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO + END IF +* +* Apply accumulated unitary matrices to Z. +* + IF( WANTZ ) THEN + J = IHI - NBLST + 1 + IF ( INITQ ) THEN + TOPQ = MAX( 2, J - JCOL + 1 ) + NH = IHI - TOPQ + 1 + ELSE + TOPQ = 1 + NH = N + END IF + CALL ZGEMM( 'No Transpose', 'No Transpose', NH, + $ NBLST, NBLST, CONE, Z( TOPQ, J ), LDZ, + $ WORK, NBLST, CZERO, WORK( PW ), NH ) + CALL ZLACPY( 'All', NH, NBLST, WORK( PW ), NH, + $ Z( TOPQ, J ), LDZ ) + PPWO = NBLST*NBLST + 1 + J0 = J - NNB + DO J = J0, JCOL+1, -NNB + IF ( INITQ ) THEN + TOPQ = MAX( 2, J - JCOL + 1 ) + NH = IHI - TOPQ + 1 + END IF + IF ( BLK22 ) THEN +* +* Exploit the structure of U. +* + CALL ZUNM22( 'Right', 'No Transpose', NH, 2*NNB, + $ NNB, NNB, WORK( PPWO ), 2*NNB, + $ Z( TOPQ, J ), LDZ, WORK( PW ), + $ LWORK-PW+1, IERR ) + ELSE +* +* Ignore the structure of U. +* + CALL ZGEMM( 'No Transpose', 'No Transpose', NH, + $ 2*NNB, 2*NNB, CONE, Z( TOPQ, J ), LDZ, + $ WORK( PPWO ), 2*NNB, CZERO, WORK( PW ), + $ NH ) + CALL ZLACPY( 'All', NH, 2*NNB, WORK( PW ), NH, + $ Z( TOPQ, J ), LDZ ) + END IF + PPWO = PPWO + 4*NNB*NNB + END DO + END IF + END DO + END IF +* +* Use unblocked code to reduce the rest of the matrix +* Avoid re-initialization of modified Q and Z. +* + COMPQ2 = COMPQ + COMPZ2 = COMPZ + IF ( JCOL.NE.ILO ) THEN + IF ( WANTQ ) + $ COMPQ2 = 'V' + IF ( WANTZ ) + $ COMPZ2 = 'V' + END IF +* + IF ( JCOL.LT.IHI ) + $ CALL ZGGHRD( COMPQ2, COMPZ2, N, JCOL, IHI, A, LDA, B, LDB, Q, + $ LDQ, Z, LDZ, IERR ) + WORK( 1 ) = DCMPLX( LWKOPT ) +* + RETURN +* +* End of ZGGHD3 +* + END diff --git a/SRC/zunm22.f b/SRC/zunm22.f new file mode 100644 index 0000000..468d7d8 --- /dev/null +++ b/SRC/zunm22.f @@ -0,0 +1,440 @@ +*> \brief \b ZUNM22 multiplies a general matrix by a banded unitary matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZUNM22 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZUNM22( SIDE, TRANS, M, N, N1, N2, Q, LDQ, C, LDC, +* $ WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER M, N, N1, N2, LDQ, LDC, LWORK, INFO +* .. +* .. Array Arguments .. +* COMPLEX*16 Q( LDQ, * ), C( LDC, * ), WORK( * ) +* .. +* +*> \par Purpose +* ============ +*> +*> \verbatim +*> +*> ZUNM22 overwrites the general complex M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'C': Q**H * C C * Q**H +*> +*> where Q is a complex unitary matrix of order NQ, with NQ = M if +*> SIDE = 'L' and NQ = N if SIDE = 'R'. +*> The unitary matrix Q processes a 2-by-2 block structure +*> +*> [ Q11 Q12 ] +*> Q = [ ] +*> [ Q21 Q22 ], +*> +*> where Q12 is an N1-by-N1 lower triangular matrix and Q21 is an +*> N2-by-N2 upper triangular matrix. +*> \endverbatim +* +* Arguments +* ========= +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**H from the Left; +*> = 'R': apply Q or Q**H from the Right. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply Q (No transpose); +*> = 'C': apply Q**H (Conjugate transpose). +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] N1 +*> \param[in] N2 +*> \verbatim +*> N1 is INTEGER +*> N2 is INTEGER +*> The dimension of Q12 and Q21, respectively. N1, N2 >= 0. +*> The following requirement must be satisfied: +*> N1 + N2 = M if SIDE = 'L' and N1 + N2 = N if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is COMPLEX*16 array, dimension +*> (LDQ,M) if SIDE = 'L' +*> (LDQ,N) if SIDE = 'R' +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of the array Q. +*> LDQ >= max(1,M) if SIDE = 'L'; LDQ >= max(1,N) if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \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 dimension of the array WORK. +*> If SIDE = 'L', LWORK >= max(1,N); +*> if SIDE = 'R', LWORK >= max(1,M). +*> For optimum performance LWORK >= M*N. +*> +*> 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 January 2015 +* +*> \ingroup complexOTHERcomputational +* +* ===================================================================== + SUBROUTINE ZUNM22( SIDE, TRANS, M, N, N1, N2, Q, LDQ, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2015 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER M, N, N1, N2, LDQ, LDC, LWORK, INFO +* .. +* .. Array Arguments .. + COMPLEX*16 Q( LDQ, * ), C( LDC, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + INTEGER I, LDWORK, LEN, LWKOPT, NB, NQ, NW +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZGEMM, ZLACPY, ZTRMM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCMPLX, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q; +* NW is the minimum dimension of WORK. +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + NW = NQ + IF( N1.EQ.0 .OR. N2.EQ.0 ) NW = 1 + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) + $ THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( N1.LT.0 .OR. N1+N2.NE.NQ ) THEN + INFO = -5 + ELSE IF( N2.LT.0 ) THEN + INFO = -6 + ELSE IF( LDQ.LT.MAX( 1, NQ ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN + LWKOPT = M*N + WORK( 1 ) = DCMPLX( LWKOPT ) + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNM22', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* Degenerate cases (N1 = 0 or N2 = 0) are handled using ZTRMM. +* + IF( N1.EQ.0 ) THEN + CALL ZTRMM( SIDE, 'Upper', TRANS, 'Non-Unit', M, N, ONE, + $ Q, LDQ, C, LDC ) + WORK( 1 ) = ONE + RETURN + ELSE IF( N2.EQ.0 ) THEN + CALL ZTRMM( SIDE, 'Lower', TRANS, 'Non-Unit', M, N, ONE, + $ Q, LDQ, C, LDC ) + WORK( 1 ) = ONE + RETURN + END IF +* +* Compute the largest chunk size available from the workspace. +* + NB = MAX( 1, MIN( LWORK, LWKOPT ) / NQ ) +* + IF( LEFT ) THEN + IF( NOTRAN ) THEN + DO I = 1, N, NB + LEN = MIN( NB, N-I+1 ) + LDWORK = M +* +* Multiply bottom part of C by Q12. +* + CALL ZLACPY( 'All', N1, LEN, C( N2+1, I ), LDC, WORK, + $ LDWORK ) + CALL ZTRMM( 'Left', 'Lower', 'No Transpose', 'Non-Unit', + $ N1, LEN, ONE, Q( 1, N2+1 ), LDQ, WORK, + $ LDWORK ) +* +* Multiply top part of C by Q11. +* + CALL ZGEMM( 'No Transpose', 'No Transpose', N1, LEN, N2, + $ ONE, Q, LDQ, C( 1, I ), LDC, ONE, WORK, + $ LDWORK ) +* +* Multiply top part of C by Q21. +* + CALL ZLACPY( 'All', N2, LEN, C( 1, I ), LDC, + $ WORK( N1+1 ), LDWORK ) + CALL ZTRMM( 'Left', 'Upper', 'No Transpose', 'Non-Unit', + $ N2, LEN, ONE, Q( N1+1, 1 ), LDQ, + $ WORK( N1+1 ), LDWORK ) +* +* Multiply bottom part of C by Q22. +* + CALL ZGEMM( 'No Transpose', 'No Transpose', N2, LEN, N1, + $ ONE, Q( N1+1, N2+1 ), LDQ, C( N2+1, I ), LDC, + $ ONE, WORK( N1+1 ), LDWORK ) +* +* Copy everything back. +* + CALL ZLACPY( 'All', M, LEN, WORK, LDWORK, C( 1, I ), + $ LDC ) + END DO + ELSE + DO I = 1, N, NB + LEN = MIN( NB, N-I+1 ) + LDWORK = M +* +* Multiply bottom part of C by Q21**H. +* + CALL ZLACPY( 'All', N2, LEN, C( N1+1, I ), LDC, WORK, + $ LDWORK ) + CALL ZTRMM( 'Left', 'Upper', 'Conjugate', 'Non-Unit', + $ N2, LEN, ONE, Q( N1+1, 1 ), LDQ, WORK, + $ LDWORK ) +* +* Multiply top part of C by Q11**H. +* + CALL ZGEMM( 'Conjugate', 'No Transpose', N2, LEN, N1, + $ ONE, Q, LDQ, C( 1, I ), LDC, ONE, WORK, + $ LDWORK ) +* +* Multiply top part of C by Q12**H. +* + CALL ZLACPY( 'All', N1, LEN, C( 1, I ), LDC, + $ WORK( N2+1 ), LDWORK ) + CALL ZTRMM( 'Left', 'Lower', 'Conjugate', 'Non-Unit', + $ N1, LEN, ONE, Q( 1, N2+1 ), LDQ, + $ WORK( N2+1 ), LDWORK ) +* +* Multiply bottom part of C by Q22**H. +* + CALL ZGEMM( 'Conjugate', 'No Transpose', N1, LEN, N2, + $ ONE, Q( N1+1, N2+1 ), LDQ, C( N1+1, I ), LDC, + $ ONE, WORK( N2+1 ), LDWORK ) +* +* Copy everything back. +* + CALL ZLACPY( 'All', M, LEN, WORK, LDWORK, C( 1, I ), + $ LDC ) + END DO + END IF + ELSE + IF( NOTRAN ) THEN + DO I = 1, M, NB + LEN = MIN( NB, M-I+1 ) + LDWORK = LEN +* +* Multiply right part of C by Q21. +* + CALL ZLACPY( 'All', LEN, N2, C( I, N1+1 ), LDC, WORK, + $ LDWORK ) + CALL ZTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', + $ LEN, N2, ONE, Q( N1+1, 1 ), LDQ, WORK, + $ LDWORK ) +* +* Multiply left part of C by Q11. +* + CALL ZGEMM( 'No Transpose', 'No Transpose', LEN, N2, N1, + $ ONE, C( I, 1 ), LDC, Q, LDQ, ONE, WORK, + $ LDWORK ) +* +* Multiply left part of C by Q12. +* + CALL ZLACPY( 'All', LEN, N1, C( I, 1 ), LDC, + $ WORK( 1 + N2*LDWORK ), LDWORK ) + CALL ZTRMM( 'Right', 'Lower', 'No Transpose', 'Non-Unit', + $ LEN, N1, ONE, Q( 1, N2+1 ), LDQ, + $ WORK( 1 + N2*LDWORK ), LDWORK ) +* +* Multiply right part of C by Q22. +* + CALL ZGEMM( 'No Transpose', 'No Transpose', LEN, N1, N2, + $ ONE, C( I, N1+1 ), LDC, Q( N1+1, N2+1 ), LDQ, + $ ONE, WORK( 1 + N2*LDWORK ), LDWORK ) +* +* Copy everything back. +* + CALL ZLACPY( 'All', LEN, N, WORK, LDWORK, C( I, 1 ), + $ LDC ) + END DO + ELSE + DO I = 1, M, NB + LEN = MIN( NB, M-I+1 ) + LDWORK = LEN +* +* Multiply right part of C by Q12**H. +* + CALL ZLACPY( 'All', LEN, N1, C( I, N2+1 ), LDC, WORK, + $ LDWORK ) + CALL ZTRMM( 'Right', 'Lower', 'Conjugate', 'Non-Unit', + $ LEN, N1, ONE, Q( 1, N2+1 ), LDQ, WORK, + $ LDWORK ) +* +* Multiply left part of C by Q11**H. +* + CALL ZGEMM( 'No Transpose', 'Conjugate', LEN, N1, N2, + $ ONE, C( I, 1 ), LDC, Q, LDQ, ONE, WORK, + $ LDWORK ) +* +* Multiply left part of C by Q21**H. +* + CALL ZLACPY( 'All', LEN, N2, C( I, 1 ), LDC, + $ WORK( 1 + N1*LDWORK ), LDWORK ) + CALL ZTRMM( 'Right', 'Upper', 'Conjugate', 'Non-Unit', + $ LEN, N2, ONE, Q( N1+1, 1 ), LDQ, + $ WORK( 1 + N1*LDWORK ), LDWORK ) +* +* Multiply right part of C by Q22**H. +* + CALL ZGEMM( 'No Transpose', 'Conjugate', LEN, N2, N1, + $ ONE, C( I, N2+1 ), LDC, Q( N1+1, N2+1 ), LDQ, + $ ONE, WORK( 1 + N1*LDWORK ), LDWORK ) +* +* Copy everything back. +* + CALL ZLACPY( 'All', LEN, N, WORK, LDWORK, C( I, 1 ), + $ LDC ) + END DO + END IF + END IF +* + WORK( 1 ) = DCMPLX( LWKOPT ) + RETURN +* +* End of ZUNM22 +* + END diff --git a/TESTING/EIG/CMakeLists.txt b/TESTING/EIG/CMakeLists.txt index 05b11fb..cbf5622 100644 --- a/TESTING/EIG/CMakeLists.txt +++ b/TESTING/EIG/CMakeLists.txt @@ -51,16 +51,16 @@ set(SEIGTST schkee.f schkbb.f schkbd.f schkbk.f schkbl.f schkec.f schkgg.f schkgk.f schkgl.f schkhs.f schksb.f schkst.f sckcsd.f sckglm.f sckgqr.f sckgsv.f scklse.f scsdts.f - sdrges.f sdrgev.f sdrgsx.f sdrgvx.f - sdrvbd.f sdrves.f sdrvev.f sdrvgg.f sdrvsg.f - sdrvst.f sdrvsx.f sdrvvx.f - serrbd.f serrec.f serred.f serrgg.f serrhs.f serrst.f - sget02.f sget10.f sget22.f sget23.f sget24.f sget31.f - sget32.f sget33.f sget34.f sget35.f sget36.f - sget37.f sget38.f sget39.f sget51.f sget52.f sget53.f - sget54.f sglmts.f sgqrts.f sgrqts.f sgsvts.f - shst01.f slarfy.f slarhs.f slatm4.f slctes.f slctsx.f slsets.f sort01.f - sort03.f ssbt21.f ssgt01.f sslect.f sspt21.f sstt21.f + sdrges.f sdrgev.f sdrges3.f sdrgev3.f sdrgsx.f sdrgvx.f + sdrvbd.f sdrves.f sdrvev.f sdrvgg.f sdrvsg.f + sdrvst.f sdrvsx.f sdrvvx.f + serrbd.f serrec.f serred.f serrgg.f serrhs.f serrst.f + sget02.f sget10.f sget22.f sget23.f sget24.f sget31.f + sget32.f sget33.f sget34.f sget35.f sget36.f + sget37.f sget38.f sget39.f sget51.f sget52.f sget53.f + sget54.f sglmts.f sgqrts.f sgrqts.f sgsvts.f + shst01.f slarfy.f slarhs.f slatm4.f slctes.f slctsx.f slsets.f sort01.f + sort03.f ssbt21.f ssgt01.f sslect.f sspt21.f sstt21.f sstt22.f ssyt21.f ssyt22.f) set(CEIGTST cchkee.f @@ -68,16 +68,16 @@ set(CEIGTST cchkee.f cchkbb.f cchkbd.f cchkbk.f cchkbl.f cchkec.f cchkgg.f cchkgk.f cchkgl.f cchkhb.f cchkhs.f cchkst.f cckcsd.f cckglm.f cckgqr.f cckgsv.f ccklse.f ccsdts.f - cdrges.f cdrgev.f cdrgsx.f cdrgvx.f - cdrvbd.f cdrves.f cdrvev.f cdrvgg.f cdrvsg.f - cdrvst.f cdrvsx.f cdrvvx.f - cerrbd.f cerrec.f cerred.f cerrgg.f cerrhs.f cerrst.f - cget02.f cget10.f cget22.f cget23.f cget24.f - cget35.f cget36.f cget37.f cget38.f cget51.f cget52.f - cget54.f cglmts.f cgqrts.f cgrqts.f cgsvts.f - chbt21.f chet21.f chet22.f chpt21.f chst01.f - clarfy.f clarhs.f clatm4.f clctes.f clctsx.f clsets.f csbmv.f - csgt01.f cslect.f + cdrges.f cdrgev.f cdrges3.f cdrgev3.f cdrgsx.f cdrgvx.f + cdrvbd.f cdrves.f cdrvev.f cdrvgg.f cdrvsg.f + cdrvst.f cdrvsx.f cdrvvx.f + cerrbd.f cerrec.f cerred.f cerrgg.f cerrhs.f cerrst.f + cget02.f cget10.f cget22.f cget23.f cget24.f + cget35.f cget36.f cget37.f cget38.f cget51.f cget52.f + cget54.f cglmts.f cgqrts.f cgrqts.f cgsvts.f + chbt21.f chet21.f chet22.f chpt21.f chst01.f + clarfy.f clarhs.f clatm4.f clctes.f clctsx.f clsets.f csbmv.f + csgt01.f cslect.f cstt21.f cstt22.f cunt01.f cunt03.f) set(DZIGTST dlafts.f dlahd2.f dlasum.f dlatb9.f dstech.f dstect.f @@ -88,16 +88,16 @@ set(DEIGTST dchkee.f dchkbb.f dchkbd.f dchkbk.f dchkbl.f dchkec.f dchkgg.f dchkgk.f dchkgl.f dchkhs.f dchksb.f dchkst.f dckcsd.f dckglm.f dckgqr.f dckgsv.f dcklse.f dcsdts.f - ddrges.f ddrgev.f ddrgsx.f ddrgvx.f - ddrvbd.f ddrves.f ddrvev.f ddrvgg.f ddrvsg.f - ddrvst.f ddrvsx.f ddrvvx.f - derrbd.f derrec.f derred.f derrgg.f derrhs.f derrst.f - dget02.f dget10.f dget22.f dget23.f dget24.f dget31.f - dget32.f dget33.f dget34.f dget35.f dget36.f - dget37.f dget38.f dget39.f dget51.f dget52.f dget53.f - dget54.f dglmts.f dgqrts.f dgrqts.f dgsvts.f - dhst01.f dlarfy.f dlarhs.f dlatm4.f dlctes.f dlctsx.f dlsets.f dort01.f - dort03.f dsbt21.f dsgt01.f dslect.f dspt21.f dstt21.f + ddrges.f ddrgev.f ddrges3.f ddrgev3.f ddrgsx.f ddrgvx.f + ddrvbd.f ddrves.f ddrvev.f ddrvgg.f ddrvsg.f + ddrvst.f ddrvsx.f ddrvvx.f + derrbd.f derrec.f derred.f derrgg.f derrhs.f derrst.f + dget02.f dget10.f dget22.f dget23.f dget24.f dget31.f + dget32.f dget33.f dget34.f dget35.f dget36.f + dget37.f dget38.f dget39.f dget51.f dget52.f dget53.f + dget54.f dglmts.f dgqrts.f dgrqts.f dgsvts.f + dhst01.f dlarfy.f dlarhs.f dlatm4.f dlctes.f dlctsx.f dlsets.f dort01.f + dort03.f dsbt21.f dsgt01.f dslect.f dspt21.f dstt21.f dstt22.f dsyt21.f dsyt22.f) set(ZEIGTST zchkee.f @@ -105,16 +105,16 @@ set(ZEIGTST zchkee.f zchkbb.f zchkbd.f zchkbk.f zchkbl.f zchkec.f zchkgg.f zchkgk.f zchkgl.f zchkhb.f zchkhs.f zchkst.f zckcsd.f zckglm.f zckgqr.f zckgsv.f zcklse.f zcsdts.f - zdrges.f zdrgev.f zdrgsx.f zdrgvx.f - zdrvbd.f zdrves.f zdrvev.f zdrvgg.f zdrvsg.f - zdrvst.f zdrvsx.f zdrvvx.f - zerrbd.f zerrec.f zerred.f zerrgg.f zerrhs.f zerrst.f - zget02.f zget10.f zget22.f zget23.f zget24.f - zget35.f zget36.f zget37.f zget38.f zget51.f zget52.f - zget54.f zglmts.f zgqrts.f zgrqts.f zgsvts.f - zhbt21.f zhet21.f zhet22.f zhpt21.f zhst01.f - zlarfy.f zlarhs.f zlatm4.f zlctes.f zlctsx.f zlsets.f zsbmv.f - zsgt01.f zslect.f + zdrges.f zdrgev.f zdrges3.f zdrgev3.f zdrgsx.f zdrgvx.f + zdrvbd.f zdrves.f zdrvev.f zdrvgg.f zdrvsg.f + zdrvst.f zdrvsx.f zdrvvx.f + zerrbd.f zerrec.f zerred.f zerrgg.f zerrhs.f zerrst.f + zget02.f zget10.f zget22.f zget23.f zget24.f + zget35.f zget36.f zget37.f zget38.f zget51.f zget52.f + zget54.f zglmts.f zgqrts.f zgrqts.f zgsvts.f + zhbt21.f zhet21.f zhet22.f zhpt21.f zhst01.f + zlarfy.f zlarhs.f zlatm4.f zlctes.f zlctsx.f zlsets.f zsbmv.f + zsgt01.f zslect.f zstt21.f zstt22.f zunt01.f zunt03.f) macro(add_eig_executable name ) diff --git a/TESTING/EIG/Makefile b/TESTING/EIG/Makefile index 48e43c9..63d1457 100644 --- a/TESTING/EIG/Makefile +++ b/TESTING/EIG/Makefile @@ -53,7 +53,7 @@ SEIGTST = schkee.o \ schkbb.o schkbd.o schkbk.o schkbl.o schkec.o \ schkgg.o schkgk.o schkgl.o schkhs.o schksb.o schkst.o \ sckcsd.o sckglm.o sckgqr.o sckgsv.o scklse.o scsdts.o \ - sdrges.o sdrgev.o sdrgsx.o sdrgvx.o \ + sdrges.o sdrgev.o sdrges3.o sdrgev3.o sdrgsx.o sdrgvx.o \ sdrvbd.o sdrves.o sdrvev.o sdrvgg.o sdrvsg.o \ sdrvst.o sdrvsx.o sdrvvx.o \ serrbd.o serrec.o serred.o serrgg.o serrhs.o serrst.o \ @@ -70,7 +70,7 @@ CEIGTST = cchkee.o \ cchkbb.o cchkbd.o cchkbk.o cchkbl.o cchkec.o \ cchkgg.o cchkgk.o cchkgl.o cchkhb.o cchkhs.o cchkst.o \ cckcsd.o cckglm.o cckgqr.o cckgsv.o ccklse.o ccsdts.o \ - cdrges.o cdrgev.o cdrgsx.o cdrgvx.o \ + cdrges.o cdrgev.o cdrges3.o cdrgev3.o cdrgsx.o cdrgvx.o \ cdrvbd.o cdrves.o cdrvev.o cdrvgg.o cdrvsg.o \ cdrvst.o cdrvsx.o cdrvvx.o \ cerrbd.o cerrec.o cerred.o cerrgg.o cerrhs.o cerrst.o \ @@ -90,7 +90,7 @@ DEIGTST = dchkee.o \ dchkbb.o dchkbd.o dchkbk.o dchkbl.o dchkec.o \ dchkgg.o dchkgk.o dchkgl.o dchkhs.o dchksb.o dchkst.o \ dckcsd.o dckglm.o dckgqr.o dckgsv.o dcklse.o dcsdts.o \ - ddrges.o ddrgev.o ddrgsx.o ddrgvx.o \ + ddrges.o ddrgev.o ddrges3.o ddrgev3.o ddrgsx.o ddrgvx.o \ ddrvbd.o ddrves.o ddrvev.o ddrvgg.o ddrvsg.o \ ddrvst.o ddrvsx.o ddrvvx.o \ derrbd.o derrec.o derred.o derrgg.o derrhs.o derrst.o \ @@ -107,7 +107,7 @@ ZEIGTST = zchkee.o \ zchkbb.o zchkbd.o zchkbk.o zchkbl.o zchkec.o \ zchkgg.o zchkgk.o zchkgl.o zchkhb.o zchkhs.o zchkst.o \ zckcsd.o zckglm.o zckgqr.o zckgsv.o zcklse.o zcsdts.o \ - zdrges.o zdrgev.o zdrgsx.o zdrgvx.o \ + zdrges.o zdrgev.o zdrges3.o zdrgev3.o zdrgsx.o zdrgvx.o \ zdrvbd.o zdrves.o zdrvev.o zdrvgg.o zdrvsg.o \ zdrvst.o zdrvsx.o zdrvvx.o \ zerrbd.o zerrec.o zerred.o zerrgg.o zerrhs.o zerrst.o \ diff --git a/TESTING/EIG/cchkee.f b/TESTING/EIG/cchkee.f index 31715d5..e485acc 100644 --- a/TESTING/EIG/cchkee.f +++ b/TESTING/EIG/cchkee.f @@ -44,7 +44,7 @@ *> Test CGEESX *> *> CGG (Generalized Nonsymmetric Eigenvalue Problem): -*> Test CGGHRD, CGGBAL, CGGBAK, CHGEQZ, and CTGEVC +*> Test CGGHD3, CGGBAL, CGGBAK, CHGEQZ, and CTGEVC *> and the driver routines CGEGS and CGEGV *> *> CGS (Generalized Nonsymmetric Schur form Driver): @@ -489,38 +489,41 @@ *> line 8: MXBVAL, INTEGER array, dimension (NPARMS) *> The values for MAXB, used in determining minimum blocksize. *> -*> line 9: NBCOL, INTEGER array, dimension (NPARMS) +*> line 9: IACC22, INTEGER array, dimension (NPARMS) +*> select structured matrix multiply: 1 or 2) +*> +*> line 10: NBCOL, INTEGER array, dimension (NPARMS) *> The values for NBCOL, the minimum column dimension for *> blocks. *> -*> line 10: THRESH +*> line 11: THRESH *> Threshold value for the test ratios. Information will be *> printed about each test for which the test ratio is greater *> than or equal to the threshold. *> -*> line 11: TSTCHK, LOGICAL +*> line 12: TSTCHK, LOGICAL *> Flag indicating whether or not to test the LAPACK routines. *> -*> line 12: TSTDRV, LOGICAL +*> line 13: TSTDRV, LOGICAL *> Flag indicating whether or not to test the driver routines. *> -*> line 13: TSTERR, LOGICAL +*> line 14: TSTERR, LOGICAL *> Flag indicating whether or not to test the error exits for *> the LAPACK routines and driver routines. *> -*> line 14: NEWSD, INTEGER +*> line 15: NEWSD, INTEGER *> A code indicating how to set the random number seed. *> = 0: Set the seed to a default value before each run *> = 1: Initialize the seed to a default value only before the *> first run *> = 2: Like 1, but use the seed values on the next line *> -*> If line 14 was 2: +*> If line 15 was 2: *> -*> line 15: INTEGER array, dimension (4) +*> line 16: INTEGER array, dimension (4) *> Four integer values for the random number seed. *> -*> lines 16-EOF: Lines specifying matrix types, as for NEP. +*> lines 17-EOF: Lines specifying matrix types, as for NEP. *> The 3-character path name is 'CGG' for the generalized *> eigenvalue problem routines and driver routines. *> @@ -1100,7 +1103,8 @@ $ CCKCSD, CCKGLM, CCKGQR, CCKGSV, CCKLSE, CDRGES, $ CDRGEV, CDRGSX, CDRGVX, CDRVBD, CDRVES, CDRVEV, $ CDRVGG, CDRVSG, CDRVST, CDRVSX, CDRVVX, CERRBD, - $ CERRED, CERRGG, CERRHS, CERRST, ILAVER, XLAENV + $ CERRED, CERRGG, CERRHS, CERRST, ILAVER, XLAENV, + $ CDRGES3, CDRGEV3 * .. * .. Intrinsic Functions .. INTRINSIC LEN, MIN @@ -1621,7 +1625,7 @@ * * Read the values for IACC22. * - IF( NEP ) THEN + IF( NEP .OR. CGG ) THEN READ( NIN, FMT = * )( IACC22( I ), I = 1, NPARMS ) DO 620 I = 1, NPARMS IF( IACC22( I ).LT.0 ) THEN @@ -2090,6 +2094,7 @@ * NBMIN = minimum block size * NS = number of shifts * MAXB = minimum submatrix size +* IACC22: structured matrix multiply * NBCOL = minimum column dimension for blocks * MAXTYP = 26 @@ -2102,6 +2107,7 @@ CALL XLAENV( 2, NBMIN( I ) ) CALL XLAENV( 4, NSVAL( I ) ) CALL XLAENV( 8, MXBVAL( I ) ) + CALL XLAENV( 16, IACC22( I ) ) CALL XLAENV( 5, NBCOL( I ) ) * IF( NEWSD.EQ.0 ) THEN @@ -2110,7 +2116,7 @@ 340 CONTINUE END IF WRITE( NOUT, FMT = 9996 )C3, NBVAL( I ), NBMIN( I ), - $ NSVAL( I ), MXBVAL( I ), NBCOL( I ) + $ NSVAL( I ), MXBVAL( I ), IACC22( I ), NBCOL( I ) TSTDIF = .FALSE. THRSHN = 10. IF( TSTCHK ) THEN @@ -2162,8 +2168,20 @@ * IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'CDRGES', INFO +* +* Blocked version +* + CALL CDRGES3( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT, + $ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ), + $ A( 1, 4 ), A( 1, 7 ), NMAX, A( 1, 8 ), + $ DC( 1, 1 ), DC( 1, 2 ), WORK, LWORK, RWORK, + $ RESULT, LOGWRK, INFO ) +* + IF( INFO.NE.0 ) + $ WRITE( NOUT, FMT = 9980 )'CDRGES3', INFO END IF WRITE( NOUT, FMT = 9973 ) + GO TO 10 * ELSE IF( CGX ) THEN @@ -2216,6 +2234,17 @@ $ RESULT, INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'CDRGEV', INFO +* +* Blocked version +* + CALL CDRGEV3( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT, + $ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ), + $ A( 1, 4 ), A( 1, 7 ), NMAX, A( 1, 8 ), + $ A( 1, 9 ), NMAX, DC( 1, 1 ), DC( 1, 2 ), + $ DC( 1, 3 ), DC( 1, 4 ), WORK, LWORK, RWORK, + $ RESULT, INFO ) + IF( INFO.NE.0 ) + $ WRITE( NOUT, FMT = 9980 )'CDRGEV3', INFO END IF WRITE( NOUT, FMT = 9973 ) GO TO 10 @@ -2388,7 +2417,7 @@ 9999 FORMAT( / ' Execution not attempted due to input errors' ) 9997 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4 ) 9996 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NS =', I4, - $ ', MAXB =', I4, ', NBCOL =', I4 ) + $ ', MAXB =', I4, ', IACC22 =', I4, ', NBCOL =', I4 ) 9995 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4, $ ', NRHS =', I4 ) 9994 FORMAT( / / ' End of tests' ) diff --git a/TESTING/EIG/cdrges3.f b/TESTING/EIG/cdrges3.f new file mode 100644 index 0000000..0ef33df --- /dev/null +++ b/TESTING/EIG/cdrges3.f @@ -0,0 +1,940 @@ +*> \brief \b CDRGES3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CDRGES3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, ALPHA, +* BETA, WORK, LWORK, RWORK, RESULT, BWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL BWORK( * ), DOTYPE( * ) +* INTEGER ISEED( 4 ), NN( * ) +* REAL RESULT( 13 ), RWORK( * ) +* COMPLEX A( LDA, * ), ALPHA( * ), B( LDA, * ), +* $ BETA( * ), Q( LDQ, * ), S( LDA, * ), +* $ T( LDA, * ), WORK( * ), Z( LDQ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CDRGES3 checks the nonsymmetric generalized eigenvalue (Schur form) +*> problem driver CGGES3. +*> +*> CGGES3 factors A and B as Q*S*Z' and Q*T*Z' , where ' means conjugate +*> transpose, S and T are upper triangular (i.e., in generalized Schur +*> form), and Q and Z are unitary. It also computes the generalized +*> eigenvalues (alpha(j),beta(j)), j=1,...,n. Thus, +*> w(j) = alpha(j)/beta(j) is a root of the characteristic equation +*> +*> det( A - w(j) B ) = 0 +*> +*> Optionally it also reorder the eigenvalues so that a selected +*> cluster of eigenvalues appears in the leading diagonal block of the +*> Schur forms. +*> +*> When CDRGES3 is called, a number of matrix "sizes" ("N's") and a +*> number of matrix "TYPES" are specified. For each size ("N") +*> and each TYPE of matrix, a pair of matrices (A, B) will be generated +*> and used for testing. For each matrix pair, the following 13 tests +*> will be performed and compared with the threshhold THRESH except +*> the tests (5), (11) and (13). +*> +*> +*> (1) | A - Q S Z' | / ( |A| n ulp ) (no sorting of eigenvalues) +*> +*> +*> (2) | B - Q T Z' | / ( |B| n ulp ) (no sorting of eigenvalues) +*> +*> +*> (3) | I - QQ' | / ( n ulp ) (no sorting of eigenvalues) +*> +*> +*> (4) | I - ZZ' | / ( n ulp ) (no sorting of eigenvalues) +*> +*> (5) if A is in Schur form (i.e. triangular form) (no sorting of +*> eigenvalues) +*> +*> (6) if eigenvalues = diagonal elements of the Schur form (S, T), +*> i.e., test the maximum over j of D(j) where: +*> +*> |alpha(j) - S(j,j)| |beta(j) - T(j,j)| +*> D(j) = ------------------------ + ----------------------- +*> max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) +*> +*> (no sorting of eigenvalues) +*> +*> (7) | (A,B) - Q (S,T) Z' | / ( |(A,B)| n ulp ) +*> (with sorting of eigenvalues). +*> +*> (8) | I - QQ' | / ( n ulp ) (with sorting of eigenvalues). +*> +*> (9) | I - ZZ' | / ( n ulp ) (with sorting of eigenvalues). +*> +*> (10) if A is in Schur form (i.e. quasi-triangular form) +*> (with sorting of eigenvalues). +*> +*> (11) if eigenvalues = diagonal elements of the Schur form (S, T), +*> i.e. test the maximum over j of D(j) where: +*> +*> |alpha(j) - S(j,j)| |beta(j) - T(j,j)| +*> D(j) = ------------------------ + ----------------------- +*> max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) +*> +*> (with sorting of eigenvalues). +*> +*> (12) if sorting worked and SDIM is the number of eigenvalues +*> which were CELECTed. +*> +*> Test Matrices +*> ============= +*> +*> The sizes of the test matrices are specified by an array +*> NN(1:NSIZES); the value of each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if +*> DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) ( 0, 0 ) (a pair of zero matrices) +*> +*> (2) ( I, 0 ) (an identity and a zero matrix) +*> +*> (3) ( 0, I ) (an identity and a zero matrix) +*> +*> (4) ( I, I ) (a pair of identity matrices) +*> +*> t t +*> (5) ( J , J ) (a pair of transposed Jordan blocks) +*> +*> t ( I 0 ) +*> (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) +*> ( 0 I ) ( 0 J ) +*> and I is a k x k identity and J a (k+1)x(k+1) +*> Jordan block; k=(N-1)/2 +*> +*> (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal +*> matrix with those diagonal entries.) +*> (8) ( I, D ) +*> +*> (9) ( big*D, small*I ) where "big" is near overflow and small=1/big +*> +*> (10) ( small*D, big*I ) +*> +*> (11) ( big*I, small*D ) +*> +*> (12) ( small*I, big*D ) +*> +*> (13) ( big*D, big*I ) +*> +*> (14) ( small*D, small*I ) +*> +*> (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and +*> D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) +*> t t +*> (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. +*> +*> (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices +*> with random O(1) entries above the diagonal +*> and diagonal entries diag(T1) = +*> ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = +*> ( 0, N-3, N-4,..., 1, 0, 0 ) +*> +*> (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) +*> s = machine precision. +*> +*> (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) +*> +*> N-5 +*> (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) +*> +*> (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) +*> where r1,..., r(N-4) are random. +*> +*> (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular +*> matrices. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> SDRGES3 does nothing. NSIZES >= 0. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. NN >= 0. +*> \endverbatim +*> +*> \param[in] NTYPES +*> \verbatim +*> NTYPES is INTEGER +*> The number of elements in DOTYPE. If it is zero, SDRGES3 +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A on input. +*> This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> \endverbatim +*> +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> \endverbatim +*> +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to SDRGES3 to continue the same random number +*> sequence. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is REAL +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error is +*> scaled to be O(1), so THRESH should be a reasonably small +*> multiple of 1, e.g., 10 or 100. In particular, it should +*> not depend on the precision (single vs. double) or the size +*> of the matrix. THRESH >= 0. +*> \endverbatim +*> +*> \param[in] NOUNIT +*> \verbatim +*> NOUNIT is INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension(LDA, max(NN)) +*> Used to hold the original A matrix. Used as input only +*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and +*> DOTYPE(MAXTYP+1)=.TRUE. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A, B, S, and T. +*> It must be at least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension(LDA, max(NN)) +*> Used to hold the original B matrix. Used as input only +*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and +*> DOTYPE(MAXTYP+1)=.TRUE. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is COMPLEX array, dimension (LDA, max(NN)) +*> The Schur form matrix computed from A by CGGES3. On exit, S +*> contains the Schur form matrix corresponding to the matrix +*> in A. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX array, dimension (LDA, max(NN)) +*> The upper triangular matrix computed from B by CGGES3. +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is COMPLEX array, dimension (LDQ, max(NN)) +*> The (left) orthogonal matrix computed by CGGES3. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of Q and Z. It must +*> be at least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is COMPLEX array, dimension( LDQ, max(NN) ) +*> The (right) orthogonal matrix computed by CGGES3. +*> \endverbatim +*> +*> \param[out] ALPHA +*> \verbatim +*> ALPHA is COMPLEX array, dimension (max(NN)) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is COMPLEX array, dimension (max(NN)) +*> +*> The generalized eigenvalues of (A,B) computed by CGGES3. +*> ALPHA(k) / BETA(k) is the k-th generalized eigenvalue of A +*> and B. +*> \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 >= 3*N*N. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension ( 8*N ) +*> Real workspace. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (15) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid overflow. +*> \endverbatim +*> +*> \param[out] BWORK +*> \verbatim +*> BWORK is LOGICAL 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: A routine returned an error code. INFO is the +*> absolute value of the INFO value returned. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date February 2015 +* +*> \ingroup complex_eig +* +* ===================================================================== + SUBROUTINE CDRGES3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, ALPHA, + $ BETA, WORK, LWORK, RWORK, RESULT, BWORK, + $ INFO ) +* +* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* February 2015 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL BWORK( * ), DOTYPE( * ) + INTEGER ISEED( 4 ), NN( * ) + REAL RESULT( 13 ), RWORK( * ) + COMPLEX A( LDA, * ), ALPHA( * ), B( LDA, * ), + $ BETA( * ), Q( LDQ, * ), S( LDA, * ), + $ T( LDA, * ), WORK( * ), Z( LDQ, * ) +* .. +* +* ===================================================================== +* +* .. 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 ) ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 26 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN, ILABAD + CHARACTER SORT + INTEGER I, IADD, IINFO, IN, ISORT, J, JC, JR, JSIZE, + $ JTYPE, KNTEIG, MAXWRK, MINWRK, MTYPES, N, N1, + $ NB, NERRS, NMATS, NMAX, NTEST, NTESTT, RSUB, + $ SDIM + REAL SAFMAX, SAFMIN, TEMP1, TEMP2, ULP, ULPINV + COMPLEX CTEMP, X +* .. +* .. Local Arrays .. + LOGICAL LASIGN( MAXTYP ), LBSIGN( MAXTYP ) + INTEGER IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ), + $ KATYPE( MAXTYP ), KAZERO( MAXTYP ), + $ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ), + $ KBZERO( MAXTYP ), KCLASS( MAXTYP ), + $ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 ) + REAL RMAGN( 0: 3 ) +* .. +* .. External Functions .. + LOGICAL CLCTES + INTEGER ILAENV + REAL SLAMCH + COMPLEX CLARND + EXTERNAL CLCTES, ILAENV, SLAMCH, CLARND +* .. +* .. External Subroutines .. + EXTERNAL ALASVM, CGET51, CGET54, CGGES3, CLACPY, CLARFG, + $ CLASET, CLATM4, CUNM2R, SLABAD, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, AIMAG, CONJG, MAX, MIN, REAL, SIGN +* .. +* .. Statement Functions .. + REAL ABS1 +* .. +* .. Statement Function definitions .. + ABS1( X ) = ABS( REAL( X ) ) + ABS( AIMAG( X ) ) +* .. +* .. Data statements .. + DATA KCLASS / 15*1, 10*2, 1*3 / + DATA KZ1 / 0, 1, 2, 1, 3, 3 / + DATA KZ2 / 0, 0, 1, 2, 1, 1 / + DATA KADD / 0, 0, 0, 0, 3, 2 / + DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4, + $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 / + DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4, + $ 1, 1, -4, 2, -4, 8*8, 0 / + DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3, + $ 4*5, 4*3, 1 / + DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4, + $ 4*6, 4*4, 1 / + DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3, + $ 2, 1 / + DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3, + $ 2, 1 / + DATA KTRIAN / 16*0, 10*1 / + DATA LASIGN / 6*.FALSE., .TRUE., .FALSE., 2*.TRUE., + $ 2*.FALSE., 3*.TRUE., .FALSE., .TRUE., + $ 3*.FALSE., 5*.TRUE., .FALSE. / + DATA LBSIGN / 7*.FALSE., .TRUE., 2*.FALSE., + $ 2*.TRUE., 2*.FALSE., .TRUE., .FALSE., .TRUE., + $ 9*.FALSE. / +* .. +* .. Executable Statements .. +* +* Check for errors +* + INFO = 0 +* + BADNN = .FALSE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( THRESH.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDQ.LE.1 .OR. LDQ.LT.NMAX ) THEN + INFO = -14 + END IF +* +* Compute workspace +* (Note: Comments in the code beginning "Workspace:" describe the +* minimal amount of workspace needed at that point in the code, +* as well as the preferred amount for good performance. +* NB refers to the optimal block size for the immediately +* following subroutine, as returned by ILAENV. +* + MINWRK = 1 + IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN + MINWRK = 3*NMAX*NMAX + NB = MAX( 1, ILAENV( 1, 'CGEQRF', ' ', NMAX, NMAX, -1, -1 ), + $ ILAENV( 1, 'CUNMQR', 'LC', NMAX, NMAX, NMAX, -1 ), + $ ILAENV( 1, 'CUNGQR', ' ', NMAX, NMAX, NMAX, -1 ) ) + MAXWRK = MAX( NMAX+NMAX*NB, 3*NMAX*NMAX) + WORK( 1 ) = MAXWRK + END IF +* + IF( LWORK.LT.MINWRK ) + $ INFO = -19 +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CDRGES3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* + ULP = SLAMCH( 'Precision' ) + SAFMIN = SLAMCH( 'Safe minimum' ) + SAFMIN = SAFMIN / ULP + SAFMAX = ONE / SAFMIN + CALL SLABAD( SAFMIN, SAFMAX ) + ULPINV = ONE / ULP +* +* The values RMAGN(2:3) depend on N, see below. +* + RMAGN( 0 ) = ZERO + RMAGN( 1 ) = ONE +* +* Loop over matrix sizes +* + NTESTT = 0 + NERRS = 0 + NMATS = 0 +* + DO 190 JSIZE = 1, NSIZES + N = NN( JSIZE ) + N1 = MAX( 1, N ) + RMAGN( 2 ) = SAFMAX*ULP / REAL( N1 ) + RMAGN( 3 ) = SAFMIN*ULPINV*REAL( N1 ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* +* Loop over matrix types +* + DO 180 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 180 + NMATS = NMATS + 1 + NTEST = 0 +* +* Save ISEED in case of an error. +* + DO 20 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 20 CONTINUE +* +* Initialize RESULT +* + DO 30 J = 1, 13 + RESULT( J ) = ZERO + 30 CONTINUE +* +* Generate test matrices A and B +* +* Description of control parameters: +* +* KCLASS: =1 means w/o rotation, =2 means w/ rotation, +* =3 means random. +* KATYPE: the "type" to be passed to CLATM4 for computing A. +* KAZERO: the pattern of zeros on the diagonal for A: +* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), +* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), +* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of +* non-zero entries.) +* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), +* =2: large, =3: small. +* LASIGN: .TRUE. if the diagonal elements of A are to be +* multiplied by a random magnitude 1 number. +* KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B. +* KTRIAN: =0: don't fill in the upper triangle, =1: do. +* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. +* RMAGN: used to implement KAMAGN and KBMAGN. +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 110 + IINFO = 0 + IF( KCLASS( JTYPE ).LT.3 ) THEN +* +* Generate A (w/o rotation) +* + IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN + IN = 2*( ( N-1 ) / 2 ) + 1 + IF( IN.NE.N ) + $ CALL CLASET( 'Full', N, N, CZERO, CZERO, A, LDA ) + ELSE + IN = N + END IF + CALL CLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ), + $ KZ2( KAZERO( JTYPE ) ), LASIGN( JTYPE ), + $ RMAGN( KAMAGN( JTYPE ) ), ULP, + $ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2, + $ ISEED, A, LDA ) + IADD = KADD( KAZERO( JTYPE ) ) + IF( IADD.GT.0 .AND. IADD.LE.N ) + $ A( IADD, IADD ) = RMAGN( KAMAGN( JTYPE ) ) +* +* Generate B (w/o rotation) +* + IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN + IN = 2*( ( N-1 ) / 2 ) + 1 + IF( IN.NE.N ) + $ CALL CLASET( 'Full', N, N, CZERO, CZERO, B, LDA ) + ELSE + IN = N + END IF + CALL CLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ), + $ KZ2( KBZERO( JTYPE ) ), LBSIGN( JTYPE ), + $ RMAGN( KBMAGN( JTYPE ) ), ONE, + $ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2, + $ ISEED, B, LDA ) + IADD = KADD( KBZERO( JTYPE ) ) + IF( IADD.NE.0 .AND. IADD.LE.N ) + $ B( IADD, IADD ) = RMAGN( KBMAGN( JTYPE ) ) +* + IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN +* +* Include rotations +* +* Generate Q, Z as Householder transformations times +* a diagonal matrix. +* + DO 50 JC = 1, N - 1 + DO 40 JR = JC, N + Q( JR, JC ) = CLARND( 3, ISEED ) + Z( JR, JC ) = CLARND( 3, ISEED ) + 40 CONTINUE + CALL CLARFG( N+1-JC, Q( JC, JC ), Q( JC+1, JC ), 1, + $ WORK( JC ) ) + WORK( 2*N+JC ) = SIGN( ONE, REAL( Q( JC, JC ) ) ) + Q( JC, JC ) = CONE + CALL CLARFG( N+1-JC, Z( JC, JC ), Z( JC+1, JC ), 1, + $ WORK( N+JC ) ) + WORK( 3*N+JC ) = SIGN( ONE, REAL( Z( JC, JC ) ) ) + Z( JC, JC ) = CONE + 50 CONTINUE + CTEMP = CLARND( 3, ISEED ) + Q( N, N ) = CONE + WORK( N ) = CZERO + WORK( 3*N ) = CTEMP / ABS( CTEMP ) + CTEMP = CLARND( 3, ISEED ) + Z( N, N ) = CONE + WORK( 2*N ) = CZERO + WORK( 4*N ) = CTEMP / ABS( CTEMP ) +* +* Apply the diagonal matrices +* + DO 70 JC = 1, N + DO 60 JR = 1, N + A( JR, JC ) = WORK( 2*N+JR )* + $ CONJG( WORK( 3*N+JC ) )* + $ A( JR, JC ) + B( JR, JC ) = WORK( 2*N+JR )* + $ CONJG( WORK( 3*N+JC ) )* + $ B( JR, JC ) + 60 CONTINUE + 70 CONTINUE + CALL CUNM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, A, + $ LDA, WORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) + $ GO TO 100 + CALL CUNM2R( 'R', 'C', N, N, N-1, Z, LDQ, WORK( N+1 ), + $ A, LDA, WORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) + $ GO TO 100 + CALL CUNM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, B, + $ LDA, WORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) + $ GO TO 100 + CALL CUNM2R( 'R', 'C', N, N, N-1, Z, LDQ, WORK( N+1 ), + $ B, LDA, WORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) + $ GO TO 100 + END IF + ELSE +* +* Random matrices +* + DO 90 JC = 1, N + DO 80 JR = 1, N + A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )* + $ CLARND( 4, ISEED ) + B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )* + $ CLARND( 4, ISEED ) + 80 CONTINUE + 90 CONTINUE + END IF +* + 100 CONTINUE +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 110 CONTINUE +* + DO 120 I = 1, 13 + RESULT( I ) = -ONE + 120 CONTINUE +* +* Test with and without sorting of eigenvalues +* + DO 150 ISORT = 0, 1 + IF( ISORT.EQ.0 ) THEN + SORT = 'N' + RSUB = 0 + ELSE + SORT = 'S' + RSUB = 5 + END IF +* +* Call CGGES3 to compute H, T, Q, Z, alpha, and beta. +* + CALL CLACPY( 'Full', N, N, A, LDA, S, LDA ) + CALL CLACPY( 'Full', N, N, B, LDA, T, LDA ) + NTEST = 1 + RSUB + ISORT + RESULT( 1+RSUB+ISORT ) = ULPINV + CALL CGGES3( 'V', 'V', SORT, CLCTES, N, S, LDA, T, LDA, + $ SDIM, ALPHA, BETA, Q, LDQ, Z, LDQ, WORK, + $ LWORK, RWORK, BWORK, IINFO ) + IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN + RESULT( 1+RSUB+ISORT ) = ULPINV + WRITE( NOUNIT, FMT = 9999 )'CGGES3', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + GO TO 160 + END IF +* + NTEST = 4 + RSUB +* +* Do tests 1--4 (or tests 7--9 when reordering ) +* + IF( ISORT.EQ.0 ) THEN + CALL CGET51( 1, N, A, LDA, S, LDA, Q, LDQ, Z, LDQ, + $ WORK, RWORK, RESULT( 1 ) ) + CALL CGET51( 1, N, B, LDA, T, LDA, Q, LDQ, Z, LDQ, + $ WORK, RWORK, RESULT( 2 ) ) + ELSE + CALL CGET54( N, A, LDA, B, LDA, S, LDA, T, LDA, Q, + $ LDQ, Z, LDQ, WORK, RESULT( 2+RSUB ) ) + END IF +* + CALL CGET51( 3, N, B, LDA, T, LDA, Q, LDQ, Q, LDQ, WORK, + $ RWORK, RESULT( 3+RSUB ) ) + CALL CGET51( 3, N, B, LDA, T, LDA, Z, LDQ, Z, LDQ, WORK, + $ RWORK, RESULT( 4+RSUB ) ) +* +* Do test 5 and 6 (or Tests 10 and 11 when reordering): +* check Schur form of A and compare eigenvalues with +* diagonals. +* + NTEST = 6 + RSUB + TEMP1 = ZERO +* + DO 130 J = 1, N + ILABAD = .FALSE. + TEMP2 = ( ABS1( ALPHA( J )-S( J, J ) ) / + $ MAX( SAFMIN, ABS1( ALPHA( J ) ), ABS1( S( J, + $ J ) ) )+ABS1( BETA( J )-T( J, J ) ) / + $ MAX( SAFMIN, ABS1( BETA( J ) ), ABS1( T( J, + $ J ) ) ) ) / ULP +* + IF( J.LT.N ) THEN + IF( S( J+1, J ).NE.ZERO ) THEN + ILABAD = .TRUE. + RESULT( 5+RSUB ) = ULPINV + END IF + END IF + IF( J.GT.1 ) THEN + IF( S( J, J-1 ).NE.ZERO ) THEN + ILABAD = .TRUE. + RESULT( 5+RSUB ) = ULPINV + END IF + END IF + TEMP1 = MAX( TEMP1, TEMP2 ) + IF( ILABAD ) THEN + WRITE( NOUNIT, FMT = 9998 )J, N, JTYPE, IOLDSD + END IF + 130 CONTINUE + RESULT( 6+RSUB ) = TEMP1 +* + IF( ISORT.GE.1 ) THEN +* +* Do test 12 +* + NTEST = 12 + RESULT( 12 ) = ZERO + KNTEIG = 0 + DO 140 I = 1, N + IF( CLCTES( ALPHA( I ), BETA( I ) ) ) + $ KNTEIG = KNTEIG + 1 + 140 CONTINUE + IF( SDIM.NE.KNTEIG ) + $ RESULT( 13 ) = ULPINV + END IF +* + 150 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + 160 CONTINUE +* + NTESTT = NTESTT + NTEST +* +* Print out tests which fail. +* + DO 170 JR = 1, NTEST + IF( RESULT( JR ).GE.THRESH ) THEN +* +* If this is the first test to fail, +* print a header to the data file. +* + IF( NERRS.EQ.0 ) THEN + WRITE( NOUNIT, FMT = 9997 )'CGS' +* +* Matrix types +* + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 ) + WRITE( NOUNIT, FMT = 9994 )'Unitary' +* +* Tests performed +* + WRITE( NOUNIT, FMT = 9993 )'unitary', '''', + $ 'transpose', ( '''', J = 1, 8 ) +* + END IF + NERRS = NERRS + 1 + IF( RESULT( JR ).LT.10000.0 ) THEN + WRITE( NOUNIT, FMT = 9992 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + ELSE + WRITE( NOUNIT, FMT = 9991 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + END IF + END IF + 170 CONTINUE +* + 180 CONTINUE + 190 CONTINUE +* +* Summary +* + CALL ALASVM( 'CGS', NOUNIT, NERRS, NTESTT, 0 ) +* + WORK( 1 ) = MAXWRK +* + RETURN +* + 9999 FORMAT( ' CDRGES3: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', + $ I6, ', JTYPE=', I6, ', ISEED=(', 4( I4, ',' ), I5, ')' ) +* + 9998 FORMAT( ' CDRGES3: S not in Schur form at eigenvalue ', I6, '.', + $ / 9X, 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), + $ I5, ')' ) +* + 9997 FORMAT( / 1X, A3, ' -- Complex Generalized Schur from problem ', + $ 'driver' ) +* + 9996 FORMAT( ' Matrix types (see CDRGES3 for details): ' ) +* + 9995 FORMAT( ' Special Matrices:', 23X, + $ '(J''=transposed Jordan block)', + $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ', + $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ', + $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I', + $ ') 11=(large*I, small*D) 13=(large*D, large*I)', / + $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ', + $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' ) + 9994 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:', + $ / ' 16=Transposed Jordan Blocks 19=geometric ', + $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ', + $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ', + $ 'alpha, beta=0,1 21=random alpha, beta=0,1', + $ / ' Large & Small Matrices:', / ' 22=(large, small) ', + $ '23=(small,large) 24=(small,small) 25=(large,large)', + $ / ' 26=random O(1) matrices.' ) +* + 9993 FORMAT( / ' Tests performed: (S is Schur, T is triangular, ', + $ 'Q and Z are ', A, ',', / 19X, + $ 'l and r are the appropriate left and right', / 19X, + $ 'eigenvectors, resp., a is alpha, b is beta, and', / 19X, A, + $ ' means ', A, '.)', / ' Without ordering: ', + $ / ' 1 = | A - Q S Z', A, + $ ' | / ( |A| n ulp ) 2 = | B - Q T Z', A, + $ ' | / ( |B| n ulp )', / ' 3 = | I - QQ', A, + $ ' | / ( n ulp ) 4 = | I - ZZ', A, + $ ' | / ( n ulp )', / ' 5 = A is in Schur form S', + $ / ' 6 = difference between (alpha,beta)', + $ ' and diagonals of (S,T)', / ' With ordering: ', + $ / ' 7 = | (A,B) - Q (S,T) Z', A, ' | / ( |(A,B)| n ulp )', + $ / ' 8 = | I - QQ', A, + $ ' | / ( n ulp ) 9 = | I - ZZ', A, + $ ' | / ( n ulp )', / ' 10 = A is in Schur form S', + $ / ' 11 = difference between (alpha,beta) and diagonals', + $ ' of (S,T)', / ' 12 = SDIM is the correct number of ', + $ 'selected eigenvalues', / ) + 9992 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I2, ' is', 0P, F8.2 ) + 9991 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I2, ' is', 1P, E10.3 ) +* +* End of CDRGES3 +* + END diff --git a/TESTING/EIG/cdrgev3.f b/TESTING/EIG/cdrgev3.f new file mode 100644 index 0000000..a38882f --- /dev/null +++ b/TESTING/EIG/cdrgev3.f @@ -0,0 +1,943 @@ +*> \brief \b CDRGEV3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CDRGEV3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, QE, LDQE, +* ALPHA, BETA, ALPHA1, BETA1, WORK, LWORK, RWORK, +* RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDQ, LDQE, LWORK, NOUNIT, NSIZES, +* $ NTYPES +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), NN( * ) +* REAL RESULT( * ), RWORK( * ) +* COMPLEX A( LDA, * ), ALPHA( * ), ALPHA1( * ), +* $ B( LDA, * ), BETA( * ), BETA1( * ), +* $ Q( LDQ, * ), QE( LDQE, * ), S( LDA, * ), +* $ T( LDA, * ), WORK( * ), Z( LDQ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CDRGEV3 checks the nonsymmetric generalized eigenvalue problem driver +*> routine CGGEV3. +*> +*> CGGEV3 computes for a pair of n-by-n nonsymmetric matrices (A,B) the +*> generalized eigenvalues and, optionally, the left and right +*> eigenvectors. +*> +*> A generalized eigenvalue for a pair of matrices (A,B) is a scalar w +*> or a ratio alpha/beta = w, such that A - w*B is singular. It is +*> usually represented as the pair (alpha,beta), as there is reasonable +*> interpretation for beta=0, and even for both being zero. +*> +*> A right generalized eigenvector corresponding to a generalized +*> eigenvalue w for a pair of matrices (A,B) is a vector r such that +*> (A - wB) * r = 0. A left generalized eigenvector is a vector l such +*> that l**H * (A - wB) = 0, where l**H is the conjugate-transpose of l. +*> +*> When CDRGEV3 is called, a number of matrix "sizes" ("n's") and a +*> number of matrix "types" are specified. For each size ("n") +*> and each type of matrix, a pair of matrices (A, B) will be generated +*> and used for testing. For each matrix pair, the following tests +*> will be performed and compared with the threshhold THRESH. +*> +*> Results from CGGEV3: +*> +*> (1) max over all left eigenvalue/-vector pairs (alpha/beta,l) of +*> +*> | VL**H * (beta A - alpha B) |/( ulp max(|beta A|, |alpha B|) ) +*> +*> where VL**H is the conjugate-transpose of VL. +*> +*> (2) | |VL(i)| - 1 | / ulp and whether largest component real +*> +*> VL(i) denotes the i-th column of VL. +*> +*> (3) max over all left eigenvalue/-vector pairs (alpha/beta,r) of +*> +*> | (beta A - alpha B) * VR | / ( ulp max(|beta A|, |alpha B|) ) +*> +*> (4) | |VR(i)| - 1 | / ulp and whether largest component real +*> +*> VR(i) denotes the i-th column of VR. +*> +*> (5) W(full) = W(partial) +*> W(full) denotes the eigenvalues computed when both l and r +*> are also computed, and W(partial) denotes the eigenvalues +*> computed when only W, only W and r, or only W and l are +*> computed. +*> +*> (6) VL(full) = VL(partial) +*> VL(full) denotes the left eigenvectors computed when both l +*> and r are computed, and VL(partial) denotes the result +*> when only l is computed. +*> +*> (7) VR(full) = VR(partial) +*> VR(full) denotes the right eigenvectors computed when both l +*> and r are also computed, and VR(partial) denotes the result +*> when only l is computed. +*> +*> +*> Test Matrices +*> ---- -------- +*> +*> The sizes of the test matrices are specified by an array +*> NN(1:NSIZES); the value of each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if +*> DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) ( 0, 0 ) (a pair of zero matrices) +*> +*> (2) ( I, 0 ) (an identity and a zero matrix) +*> +*> (3) ( 0, I ) (an identity and a zero matrix) +*> +*> (4) ( I, I ) (a pair of identity matrices) +*> +*> t t +*> (5) ( J , J ) (a pair of transposed Jordan blocks) +*> +*> t ( I 0 ) +*> (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) +*> ( 0 I ) ( 0 J ) +*> and I is a k x k identity and J a (k+1)x(k+1) +*> Jordan block; k=(N-1)/2 +*> +*> (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal +*> matrix with those diagonal entries.) +*> (8) ( I, D ) +*> +*> (9) ( big*D, small*I ) where "big" is near overflow and small=1/big +*> +*> (10) ( small*D, big*I ) +*> +*> (11) ( big*I, small*D ) +*> +*> (12) ( small*I, big*D ) +*> +*> (13) ( big*D, big*I ) +*> +*> (14) ( small*D, small*I ) +*> +*> (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and +*> D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) +*> t t +*> (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. +*> +*> (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices +*> with random O(1) entries above the diagonal +*> and diagonal entries diag(T1) = +*> ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = +*> ( 0, N-3, N-4,..., 1, 0, 0 ) +*> +*> (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) +*> s = machine precision. +*> +*> (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) +*> +*> N-5 +*> (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) +*> +*> (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) +*> where r1,..., r(N-4) are random. +*> +*> (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular +*> matrices. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> CDRGEV3 does nothing. NSIZES >= 0. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. NN >= 0. +*> \endverbatim +*> +*> \param[in] NTYPES +*> \verbatim +*> NTYPES is INTEGER +*> The number of elements in DOTYPE. If it is zero, CDRGEV3 +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> \endverbatim +*> +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> \endverbatim +*> +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to CDRGEV3 to continue the same random number +*> sequence. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is REAL +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error is +*> scaled to be O(1), so THRESH should be a reasonably small +*> multiple of 1, e.g., 10 or 100. In particular, it should +*> not depend on the precision (single vs. double) or the size +*> of the matrix. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NOUNIT +*> \verbatim +*> NOUNIT is INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IERR not equal to 0.) +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension(LDA, max(NN)) +*> Used to hold the original A matrix. Used as input only +*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and +*> DOTYPE(MAXTYP+1)=.TRUE. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A, B, S, and T. +*> It must be at least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX array, dimension(LDA, max(NN)) +*> Used to hold the original B matrix. Used as input only +*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and +*> DOTYPE(MAXTYP+1)=.TRUE. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is COMPLEX array, dimension (LDA, max(NN)) +*> The Schur form matrix computed from A by CGGEV3. On exit, S +*> contains the Schur form matrix corresponding to the matrix +*> in A. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX array, dimension (LDA, max(NN)) +*> The upper triangular matrix computed from B by CGGEV3. +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is COMPLEX array, dimension (LDQ, max(NN)) +*> The (left) eigenvectors matrix computed by CGGEV3. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of Q and Z. It must +*> be at least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is COMPLEX array, dimension( LDQ, max(NN) ) +*> The (right) orthogonal matrix computed by CGGEV3. +*> \endverbatim +*> +*> \param[out] QE +*> \verbatim +*> QE is COMPLEX array, dimension( LDQ, max(NN) ) +*> QE holds the computed right or left eigenvectors. +*> \endverbatim +*> +*> \param[in] LDQE +*> \verbatim +*> LDQE is INTEGER +*> The leading dimension of QE. LDQE >= max(1,max(NN)). +*> \endverbatim +*> +*> \param[out] ALPHA +*> \verbatim +*> ALPHA is COMPLEX array, dimension (max(NN)) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is COMPLEX array, dimension (max(NN)) +*> +*> The generalized eigenvalues of (A,B) computed by CGGEV3. +*> ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th +*> generalized eigenvalue of A and B. +*> \endverbatim +*> +*> \param[out] ALPHA1 +*> \verbatim +*> ALPHA1 is COMPLEX array, dimension (max(NN)) +*> \endverbatim +*> +*> \param[out] BETA1 +*> \verbatim +*> BETA1 is COMPLEX array, dimension (max(NN)) +*> +*> Like ALPHAR, ALPHAI, BETA, these arrays contain the +*> eigenvalues of A and B, but those computed when CGGEV3 only +*> computes a partial eigendecomposition, i.e. not the +*> eigenvalues and left and right eigenvectors. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The number of entries in WORK. LWORK >= N*(N+1) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (8*N) +*> Real workspace. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (2) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid overflow. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: A routine returned an error code. INFO is the +*> absolute value of the INFO value returned. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date January 2015 +* +*> \ingroup complex_eig +* +* ===================================================================== + SUBROUTINE CDRGEV3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, QE, LDQE, + $ ALPHA, BETA, ALPHA1, BETA1, WORK, LWORK, + $ RWORK, RESULT, INFO ) +* +* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* January 2015 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDQ, LDQE, LWORK, NOUNIT, NSIZES, + $ NTYPES + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), NN( * ) + REAL RESULT( * ), RWORK( * ) + COMPLEX A( LDA, * ), ALPHA( * ), ALPHA1( * ), + $ B( LDA, * ), BETA( * ), BETA1( * ), + $ Q( LDQ, * ), QE( LDQE, * ), S( LDA, * ), + $ T( LDA, * ), WORK( * ), Z( LDQ, * ) +* .. +* +* ===================================================================== +* +* .. 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 ) ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 26 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + INTEGER I, IADD, IERR, IN, J, JC, JR, JSIZE, JTYPE, + $ MAXWRK, MINWRK, MTYPES, N, N1, NB, NERRS, + $ NMATS, NMAX, NTESTT + REAL SAFMAX, SAFMIN, ULP, ULPINV + COMPLEX CTEMP +* .. +* .. Local Arrays .. + LOGICAL LASIGN( MAXTYP ), LBSIGN( MAXTYP ) + INTEGER IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ), + $ KATYPE( MAXTYP ), KAZERO( MAXTYP ), + $ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ), + $ KBZERO( MAXTYP ), KCLASS( MAXTYP ), + $ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 ) + REAL RMAGN( 0: 3 ) +* .. +* .. External Functions .. + INTEGER ILAENV + REAL SLAMCH + COMPLEX CLARND + EXTERNAL ILAENV, SLAMCH, CLARND +* .. +* .. External Subroutines .. + EXTERNAL ALASVM, CGET52, CGGEV3, CLACPY, CLARFG, CLASET, + $ CLATM4, CUNM2R, SLABAD, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, CONJG, MAX, MIN, REAL, SIGN +* .. +* .. Data statements .. + DATA KCLASS / 15*1, 10*2, 1*3 / + DATA KZ1 / 0, 1, 2, 1, 3, 3 / + DATA KZ2 / 0, 0, 1, 2, 1, 1 / + DATA KADD / 0, 0, 0, 0, 3, 2 / + DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4, + $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 / + DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4, + $ 1, 1, -4, 2, -4, 8*8, 0 / + DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3, + $ 4*5, 4*3, 1 / + DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4, + $ 4*6, 4*4, 1 / + DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3, + $ 2, 1 / + DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3, + $ 2, 1 / + DATA KTRIAN / 16*0, 10*1 / + DATA LASIGN / 6*.FALSE., .TRUE., .FALSE., 2*.TRUE., + $ 2*.FALSE., 3*.TRUE., .FALSE., .TRUE., + $ 3*.FALSE., 5*.TRUE., .FALSE. / + DATA LBSIGN / 7*.FALSE., .TRUE., 2*.FALSE., + $ 2*.TRUE., 2*.FALSE., .TRUE., .FALSE., .TRUE., + $ 9*.FALSE. / +* .. +* .. Executable Statements .. +* +* Check for errors +* + INFO = 0 +* + BADNN = .FALSE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( THRESH.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDQ.LE.1 .OR. LDQ.LT.NMAX ) THEN + INFO = -14 + ELSE IF( LDQE.LE.1 .OR. LDQE.LT.NMAX ) THEN + INFO = -17 + END IF +* +* Compute workspace +* (Note: Comments in the code beginning "Workspace:" describe the +* minimal amount of workspace needed at that point in the code, +* as well as the preferred amount for good performance. +* NB refers to the optimal block size for the immediately +* following subroutine, as returned by ILAENV. +* + MINWRK = 1 + IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN + MINWRK = NMAX*( NMAX+1 ) + NB = MAX( 1, ILAENV( 1, 'CGEQRF', ' ', NMAX, NMAX, -1, -1 ), + $ ILAENV( 1, 'CUNMQR', 'LC', NMAX, NMAX, NMAX, -1 ), + $ ILAENV( 1, 'CUNGQR', ' ', NMAX, NMAX, NMAX, -1 ) ) + MAXWRK = MAX( 2*NMAX, NMAX*( NB+1 ), NMAX*( NMAX+1 ) ) + WORK( 1 ) = MAXWRK + END IF +* + IF( LWORK.LT.MINWRK ) + $ INFO = -23 +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CDRGEV3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* + ULP = SLAMCH( 'Precision' ) + SAFMIN = SLAMCH( 'Safe minimum' ) + SAFMIN = SAFMIN / ULP + SAFMAX = ONE / SAFMIN + CALL SLABAD( SAFMIN, SAFMAX ) + ULPINV = ONE / ULP +* +* The values RMAGN(2:3) depend on N, see below. +* + RMAGN( 0 ) = ZERO + RMAGN( 1 ) = ONE +* +* Loop over sizes, types +* + NTESTT = 0 + NERRS = 0 + NMATS = 0 +* + DO 220 JSIZE = 1, NSIZES + N = NN( JSIZE ) + N1 = MAX( 1, N ) + RMAGN( 2 ) = SAFMAX*ULP / REAL( N1 ) + RMAGN( 3 ) = SAFMIN*ULPINV*N1 +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 210 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 210 + NMATS = NMATS + 1 +* +* Save ISEED in case of an error. +* + DO 20 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 20 CONTINUE +* +* Generate test matrices A and B +* +* Description of control parameters: +* +* KCLASS: =1 means w/o rotation, =2 means w/ rotation, +* =3 means random. +* KATYPE: the "type" to be passed to CLATM4 for computing A. +* KAZERO: the pattern of zeros on the diagonal for A: +* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), +* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), +* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of +* non-zero entries.) +* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), +* =2: large, =3: small. +* LASIGN: .TRUE. if the diagonal elements of A are to be +* multiplied by a random magnitude 1 number. +* KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B. +* KTRIAN: =0: don't fill in the upper triangle, =1: do. +* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. +* RMAGN: used to implement KAMAGN and KBMAGN. +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 100 + IERR = 0 + IF( KCLASS( JTYPE ).LT.3 ) THEN +* +* Generate A (w/o rotation) +* + IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN + IN = 2*( ( N-1 ) / 2 ) + 1 + IF( IN.NE.N ) + $ CALL CLASET( 'Full', N, N, CZERO, CZERO, A, LDA ) + ELSE + IN = N + END IF + CALL CLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ), + $ KZ2( KAZERO( JTYPE ) ), LASIGN( JTYPE ), + $ RMAGN( KAMAGN( JTYPE ) ), ULP, + $ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2, + $ ISEED, A, LDA ) + IADD = KADD( KAZERO( JTYPE ) ) + IF( IADD.GT.0 .AND. IADD.LE.N ) + $ A( IADD, IADD ) = RMAGN( KAMAGN( JTYPE ) ) +* +* Generate B (w/o rotation) +* + IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN + IN = 2*( ( N-1 ) / 2 ) + 1 + IF( IN.NE.N ) + $ CALL CLASET( 'Full', N, N, CZERO, CZERO, B, LDA ) + ELSE + IN = N + END IF + CALL CLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ), + $ KZ2( KBZERO( JTYPE ) ), LBSIGN( JTYPE ), + $ RMAGN( KBMAGN( JTYPE ) ), ONE, + $ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2, + $ ISEED, B, LDA ) + IADD = KADD( KBZERO( JTYPE ) ) + IF( IADD.NE.0 .AND. IADD.LE.N ) + $ B( IADD, IADD ) = RMAGN( KBMAGN( JTYPE ) ) +* + IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN +* +* Include rotations +* +* Generate Q, Z as Householder transformations times +* a diagonal matrix. +* + DO 40 JC = 1, N - 1 + DO 30 JR = JC, N + Q( JR, JC ) = CLARND( 3, ISEED ) + Z( JR, JC ) = CLARND( 3, ISEED ) + 30 CONTINUE + CALL CLARFG( N+1-JC, Q( JC, JC ), Q( JC+1, JC ), 1, + $ WORK( JC ) ) + WORK( 2*N+JC ) = SIGN( ONE, REAL( Q( JC, JC ) ) ) + Q( JC, JC ) = CONE + CALL CLARFG( N+1-JC, Z( JC, JC ), Z( JC+1, JC ), 1, + $ WORK( N+JC ) ) + WORK( 3*N+JC ) = SIGN( ONE, REAL( Z( JC, JC ) ) ) + Z( JC, JC ) = CONE + 40 CONTINUE + CTEMP = CLARND( 3, ISEED ) + Q( N, N ) = CONE + WORK( N ) = CZERO + WORK( 3*N ) = CTEMP / ABS( CTEMP ) + CTEMP = CLARND( 3, ISEED ) + Z( N, N ) = CONE + WORK( 2*N ) = CZERO + WORK( 4*N ) = CTEMP / ABS( CTEMP ) +* +* Apply the diagonal matrices +* + DO 60 JC = 1, N + DO 50 JR = 1, N + A( JR, JC ) = WORK( 2*N+JR )* + $ CONJG( WORK( 3*N+JC ) )* + $ A( JR, JC ) + B( JR, JC ) = WORK( 2*N+JR )* + $ CONJG( WORK( 3*N+JC ) )* + $ B( JR, JC ) + 50 CONTINUE + 60 CONTINUE + CALL CUNM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, A, + $ LDA, WORK( 2*N+1 ), IERR ) + IF( IERR.NE.0 ) + $ GO TO 90 + CALL CUNM2R( 'R', 'C', N, N, N-1, Z, LDQ, WORK( N+1 ), + $ A, LDA, WORK( 2*N+1 ), IERR ) + IF( IERR.NE.0 ) + $ GO TO 90 + CALL CUNM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, B, + $ LDA, WORK( 2*N+1 ), IERR ) + IF( IERR.NE.0 ) + $ GO TO 90 + CALL CUNM2R( 'R', 'C', N, N, N-1, Z, LDQ, WORK( N+1 ), + $ B, LDA, WORK( 2*N+1 ), IERR ) + IF( IERR.NE.0 ) + $ GO TO 90 + END IF + ELSE +* +* Random matrices +* + DO 80 JC = 1, N + DO 70 JR = 1, N + A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )* + $ CLARND( 4, ISEED ) + B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )* + $ CLARND( 4, ISEED ) + 70 CONTINUE + 80 CONTINUE + END IF +* + 90 CONTINUE +* + IF( IERR.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IERR, N, JTYPE, + $ IOLDSD + INFO = ABS( IERR ) + RETURN + END IF +* + 100 CONTINUE +* + DO 110 I = 1, 7 + RESULT( I ) = -ONE + 110 CONTINUE +* +* Call CGGEV3 to compute eigenvalues and eigenvectors. +* + CALL CLACPY( ' ', N, N, A, LDA, S, LDA ) + CALL CLACPY( ' ', N, N, B, LDA, T, LDA ) + CALL CGGEV3( 'V', 'V', N, S, LDA, T, LDA, ALPHA, BETA, Q, + $ LDQ, Z, LDQ, WORK, LWORK, RWORK, IERR ) + IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN + RESULT( 1 ) = ULPINV + WRITE( NOUNIT, FMT = 9999 )'CGGEV31', IERR, N, JTYPE, + $ IOLDSD + INFO = ABS( IERR ) + GO TO 190 + END IF +* +* Do the tests (1) and (2) +* + CALL CGET52( .TRUE., N, A, LDA, B, LDA, Q, LDQ, ALPHA, BETA, + $ WORK, RWORK, RESULT( 1 ) ) + IF( RESULT( 2 ).GT.THRESH ) THEN + WRITE( NOUNIT, FMT = 9998 )'Left', 'CGGEV31', + $ RESULT( 2 ), N, JTYPE, IOLDSD + END IF +* +* Do the tests (3) and (4) +* + CALL CGET52( .FALSE., N, A, LDA, B, LDA, Z, LDQ, ALPHA, + $ BETA, WORK, RWORK, RESULT( 3 ) ) + IF( RESULT( 4 ).GT.THRESH ) THEN + WRITE( NOUNIT, FMT = 9998 )'Right', 'CGGEV31', + $ RESULT( 4 ), N, JTYPE, IOLDSD + END IF +* +* Do test (5) +* + CALL CLACPY( ' ', N, N, A, LDA, S, LDA ) + CALL CLACPY( ' ', N, N, B, LDA, T, LDA ) + CALL CGGEV3( 'N', 'N', N, S, LDA, T, LDA, ALPHA1, BETA1, Q, + $ LDQ, Z, LDQ, WORK, LWORK, RWORK, IERR ) + IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN + RESULT( 1 ) = ULPINV + WRITE( NOUNIT, FMT = 9999 )'CGGEV32', IERR, N, JTYPE, + $ IOLDSD + INFO = ABS( IERR ) + GO TO 190 + END IF +* + DO 120 J = 1, N + IF( ALPHA( J ).NE.ALPHA1( J ) .OR. BETA( J ).NE. + $ BETA1( J ) ) RESULT( 5 ) = ULPINV + 120 CONTINUE +* +* Do the test (6): Compute eigenvalues and left eigenvectors, +* and test them +* + CALL CLACPY( ' ', N, N, A, LDA, S, LDA ) + CALL CLACPY( ' ', N, N, B, LDA, T, LDA ) + CALL CGGEV3( 'V', 'N', N, S, LDA, T, LDA, ALPHA1, BETA1, QE, + $ LDQE, Z, LDQ, WORK, LWORK, RWORK, IERR ) + IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN + RESULT( 1 ) = ULPINV + WRITE( NOUNIT, FMT = 9999 )'CGGEV33', IERR, N, JTYPE, + $ IOLDSD + INFO = ABS( IERR ) + GO TO 190 + END IF + +* + DO 130 J = 1, N + IF( ALPHA( J ).NE.ALPHA1( J ) .OR. + $ BETA( J ).NE.BETA1( J ) ) THEN + RESULT( 6 ) = ULPINV + ENDIF + 130 CONTINUE +* + DO 150 J = 1, N + DO 140 JC = 1, N + IF( Q( J, JC ).NE.QE( J, JC ) ) THEN + RESULT( 6 ) = ULPINV + END IF + 140 CONTINUE + 150 CONTINUE +* +* DO the test (7): Compute eigenvalues and right eigenvectors, +* and test them +* + CALL CLACPY( ' ', N, N, A, LDA, S, LDA ) + CALL CLACPY( ' ', N, N, B, LDA, T, LDA ) + CALL CGGEV3( 'N', 'V', N, S, LDA, T, LDA, ALPHA1, BETA1, Q, + $ LDQ, QE, LDQE, WORK, LWORK, RWORK, IERR ) + IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN + RESULT( 1 ) = ULPINV + WRITE( NOUNIT, FMT = 9999 )'CGGEV34', IERR, N, JTYPE, + $ IOLDSD + INFO = ABS( IERR ) + GO TO 190 + END IF +* + DO 160 J = 1, N + IF( ALPHA( J ).NE.ALPHA1( J ) .OR. BETA( J ).NE. + $ BETA1( J ) )RESULT( 7 ) = ULPINV + 160 CONTINUE +* + DO 180 J = 1, N + DO 170 JC = 1, N + IF( Z( J, JC ).NE.QE( J, JC ) ) + $ RESULT( 7 ) = ULPINV + 170 CONTINUE + 180 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + 190 CONTINUE +* + NTESTT = NTESTT + 7 +* +* Print out tests which fail. +* + DO 200 JR = 1, 7 + IF( RESULT( JR ).GE.THRESH ) THEN +* +* If this is the first test to fail, +* print a header to the data file. +* + IF( NERRS.EQ.0 ) THEN + WRITE( NOUNIT, FMT = 9997 )'CGV' +* +* Matrix types +* + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 ) + WRITE( NOUNIT, FMT = 9994 )'Orthogonal' +* +* Tests performed +* + WRITE( NOUNIT, FMT = 9993 ) +* + END IF + NERRS = NERRS + 1 + IF( RESULT( JR ).LT.10000.0 ) THEN + WRITE( NOUNIT, FMT = 9992 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + ELSE + WRITE( NOUNIT, FMT = 9991 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + END IF + END IF + 200 CONTINUE +* + 210 CONTINUE + 220 CONTINUE +* +* Summary +* + CALL ALASVM( 'CGV3', NOUNIT, NERRS, NTESTT, 0 ) +* + WORK( 1 ) = MAXWRK +* + RETURN +* + 9999 FORMAT( ' CDRGEV3: ', A, ' returned INFO=', I6, '.', / 3X, 'N=', + $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* + 9998 FORMAT( ' CDRGEV3: ', A, ' Eigenvectors from ', A, ' incorrectly ', + $ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 3X, + $ 'N=', I4, ', JTYPE=', I3, ', ISEED=(', 3( I4, ',' ), I5, + $ ')' ) +* + 9997 FORMAT( / 1X, A3, ' -- Complex Generalized eigenvalue problem ', + $ 'driver' ) +* + 9996 FORMAT( ' Matrix types (see CDRGEV3 for details): ' ) +* + 9995 FORMAT( ' Special Matrices:', 23X, + $ '(J''=transposed Jordan block)', + $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ', + $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ', + $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I', + $ ') 11=(large*I, small*D) 13=(large*D, large*I)', / + $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ', + $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' ) + 9994 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:', + $ / ' 16=Transposed Jordan Blocks 19=geometric ', + $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ', + $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ', + $ 'alpha, beta=0,1 21=random alpha, beta=0,1', + $ / ' Large & Small Matrices:', / ' 22=(large, small) ', + $ '23=(small,large) 24=(small,small) 25=(large,large)', + $ / ' 26=random O(1) matrices.' ) +* + 9993 FORMAT( / ' Tests performed: ', + $ / ' 1 = max | ( b A - a B )''*l | / const.,', + $ / ' 2 = | |VR(i)| - 1 | / ulp,', + $ / ' 3 = max | ( b A - a B )*r | / const.', + $ / ' 4 = | |VL(i)| - 1 | / ulp,', + $ / ' 5 = 0 if W same no matter if r or l computed,', + $ / ' 6 = 0 if l same no matter if l computed,', + $ / ' 7 = 0 if r same no matter if r computed,', / 1X ) + 9992 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I2, ' is', 0P, F8.2 ) + 9991 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I2, ' is', 1P, E10.3 ) +* +* End of CDRGEV3 +* + END diff --git a/TESTING/EIG/cerrgg.f b/TESTING/EIG/cerrgg.f index a768fe1..6f7e050 100644 --- a/TESTING/EIG/cerrgg.f +++ b/TESTING/EIG/cerrgg.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 CERRGG( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -22,8 +22,9 @@ *> \verbatim *> *> CERRGG tests the error exits for CGGES, CGGESX, CGGEV, CGGEVX, -*> CGGGLM, CGGHRD, CGGLSE, CGGQRF, CGGRQF, CGGSVD, CGGSVP, CHGEQZ, -*> CTGEVC, CTGEXC, CTGSEN, CTGSJA, CTGSNA, CTGSYL and CUNCSD. +*> CGGES3, CGGEV3, CGGGLM, CGGHRD, CGGLSE, CGGQRF, CGGRQF, CGGSVD, +*> CGGSVP, CHGEQZ, CTGEVC, CTGEXC, CTGSEN, CTGSJA, CTGSNA, CTGSYL, +*> and CUNCSD. *> \endverbatim * * Arguments: @@ -44,10 +45,10 @@ * 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 * @@ -98,7 +99,7 @@ EXTERNAL CGGES, CGGESX, CGGEV, CGGEVX, CGGGLM, CGGHRD, $ CGGLSE, CGGQRF, CGGRQF, CGGSVD, CGGSVP, CHGEQZ, $ CHKXER, CTGEVC, CTGEXC, CTGSEN, CTGSJA, CTGSNA, - $ CTGSYL, CUNCSD + $ CTGSYL, CUNCSD, CGGES3, CGGEV3, CGGHD3 * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -171,6 +172,47 @@ CALL CHKXER( 'CGGHRD', INFOT, NOUT, LERR, OK ) NT = NT + 9 * +* CGGHD3 +* + SRNAMT = 'CGGHD3' + INFOT = 1 + CALL CGGHD3( '/', 'N', 0, 1, 0, A, 1, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'CGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGGHD3( 'N', '/', 0, 1, 0, A, 1, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'CGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CGGHD3( 'N', 'N', -1, 0, 0, A, 1, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'CGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGGHD3( 'N', 'N', 0, 0, 0, A, 1, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'CGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGGHD3( 'N', 'N', 0, 1, 1, A, 1, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'CGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CGGHD3( 'N', 'N', 2, 1, 1, A, 1, B, 2, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'CGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CGGHD3( 'N', 'N', 2, 1, 1, A, 2, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'CGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CGGHD3( 'V', 'N', 2, 1, 1, A, 2, B, 2, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'CGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CGGHD3( 'N', 'V', 2, 1, 1, A, 2, B, 2, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'CGGHD3', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * CHGEQZ * SRNAMT = 'CHGEQZ' @@ -520,56 +562,56 @@ $ -1, 0, 0, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, 1, A, - $ 1, W, LW, RW, LW, IW, INFO ) + $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'CUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 8 CALL CUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, -1, 0, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, 1, A, - $ 1, W, LW, RW, LW, IW, INFO ) + $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'CUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, -1, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, 1, A, - $ 1, W, LW, RW, LW, IW, INFO ) + $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'CUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, -1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, 1, A, - $ 1, W, LW, RW, LW, IW, INFO ) + $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'CUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 20 CALL CUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, $ 1, A, 1, A, 1, A, $ A, -1, A, 1, A, 1, A, - $ 1, W, LW, RW, LW, IW, INFO ) + $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'CUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 22 CALL CUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, -1, A, 1, A, - $ 1, W, LW, RW, LW, IW, INFO ) + $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'CUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 24 CALL CUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, -1, A, - $ 1, W, LW, RW, LW, IW, INFO ) + $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'CUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 26 CALL CUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, 1, A, - $ -1, W, LW, RW, LW, IW, INFO ) + $ -1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'CUNCSD', INFOT, NOUT, LERR, OK ) NT = NT + 8 * @@ -679,6 +721,55 @@ CALL CHKXER( 'CGGES ', INFOT, NOUT, LERR, OK ) NT = NT + 11 * +* CGGES3 +* + SRNAMT = 'CGGES3' + INFOT = 1 + CALL CGGES3( '/', 'N', 'S', CLCTES, 1, A, 1, B, 1, SDIM, ALPHA, + $ BETA, Q, 1, U, 1, W, 1, RW, BW, INFO ) + CALL CHKXER( 'CGGES3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGGES3( 'N', '/', 'S', CLCTES, 1, A, 1, B, 1, SDIM, ALPHA, + $ BETA, Q, 1, U, 1, W, 1, RW, BW, INFO ) + CALL CHKXER( 'CGGES3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CGGES3( 'N', 'V', '/', CLCTES, 1, A, 1, B, 1, SDIM, ALPHA, + $ BETA, Q, 1, U, 1, W, 1, RW, BW, INFO ) + CALL CHKXER( 'CGGES3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGGES3( 'N', 'V', 'S', CLCTES, -1, A, 1, B, 1, SDIM, + $ ALPHA, BETA, Q, 1, U, 1, W, 1, RW, BW, INFO ) + CALL CHKXER( 'CGGES3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CGGES3( 'N', 'V', 'S', CLCTES, 1, A, 0, B, 1, SDIM, ALPHA, + $ BETA, Q, 1, U, 1, W, 1, RW, BW, INFO ) + CALL CHKXER( 'CGGES3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CGGES3( 'N', 'V', 'S', CLCTES, 1, A, 1, B, 0, SDIM, ALPHA, + $ BETA, Q, 1, U, 1, W, 1, RW, BW, INFO ) + CALL CHKXER( 'CGGES3', INFOT, NOUT, LERR, OK ) + INFOT = 14 + CALL CGGES3( 'N', 'V', 'S', CLCTES, 1, A, 1, B, 1, SDIM, ALPHA, + $ BETA, Q, 0, U, 1, W, 1, RW, BW, INFO ) + CALL CHKXER( 'CGGES3', INFOT, NOUT, LERR, OK ) + INFOT = 14 + CALL CGGES3( 'V', 'V', 'S', CLCTES, 2, A, 2, B, 2, SDIM, ALPHA, + $ BETA, Q, 1, U, 2, W, 1, RW, BW, INFO ) + CALL CHKXER( 'CGGES3', INFOT, NOUT, LERR, OK ) + INFOT = 16 + CALL CGGES3( 'N', 'V', 'S', CLCTES, 1, A, 1, B, 1, SDIM, ALPHA, + $ BETA, Q, 1, U, 0, W, 1, RW, BW, INFO ) + CALL CHKXER( 'CGGES3', INFOT, NOUT, LERR, OK ) + INFOT = 16 + CALL CGGES3( 'V', 'V', 'S', CLCTES, 2, A, 2, B, 2, SDIM, ALPHA, + $ BETA, Q, 2, U, 1, W, 1, RW, BW, INFO ) + CALL CHKXER( 'CGGES3', INFOT, NOUT, LERR, OK ) + INFOT = 18 + CALL CGGES3( 'V', 'V', 'S', CLCTES, 2, A, 2, B, 2, SDIM, ALPHA, + $ BETA, Q, 2, U, 2, W, 1, RW, BW, INFO ) + CALL CHKXER( 'CGGES3', INFOT, NOUT, LERR, OK ) + NT = NT + 11 +* * CGGESX * SRNAMT = 'CGGESX' @@ -794,6 +885,51 @@ CALL CHKXER( 'CGGEV ', INFOT, NOUT, LERR, OK ) NT = NT + 10 * +* CGGEV3 +* + SRNAMT = 'CGGEV3' + INFOT = 1 + CALL CGGEV3( '/', 'N', 1, A, 1, B, 1, ALPHA, BETA, Q, 1, U, 1, + $ W, 1, RW, INFO ) + CALL CHKXER( 'CGGEV3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGGEV3( 'N', '/', 1, A, 1, B, 1, ALPHA, BETA, Q, 1, U, 1, + $ W, 1, RW, INFO ) + CALL CHKXER( 'CGGEV3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CGGEV3( 'V', 'V', -1, A, 1, B, 1, ALPHA, BETA, Q, 1, U, 1, + $ W, 1, RW, INFO ) + CALL CHKXER( 'CGGEV3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGGEV3( 'V', 'V', 1, A, 0, B, 1, ALPHA, BETA, Q, 1, U, 1, + $ W, 1, RW, INFO ) + CALL CHKXER( 'CGGEV3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CGGEV3( 'V', 'V', 1, A, 1, B, 0, ALPHA, BETA, Q, 1, U, 1, + $ W, 1, RW, INFO ) + CALL CHKXER( 'CGGEV3', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CGGEV3( 'N', 'V', 1, A, 1, B, 1, ALPHA, BETA, Q, 0, U, 1, + $ W, 1, RW, INFO ) + CALL CHKXER( 'CGGEV3', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CGGEV3( 'V', 'V', 2, A, 2, B, 2, ALPHA, BETA, Q, 1, U, 2, + $ W, 1, RW, INFO ) + CALL CHKXER( 'CGGEV3', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CGGEV3( 'V', 'N', 2, A, 2, B, 2, ALPHA, BETA, Q, 2, U, 0, + $ W, 1, RW, INFO ) + CALL CHKXER( 'CGGEV3', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CGGEV3( 'V', 'V', 2, A, 2, B, 2, ALPHA, BETA, Q, 2, U, 1, + $ W, 1, RW, INFO ) + CALL CHKXER( 'CGGEV3', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL CGGEV3( 'V', 'V', 1, A, 1, B, 1, ALPHA, BETA, Q, 1, U, 1, + $ W, 1, RW, INFO ) + CALL CHKXER( 'CGGEV3', INFOT, NOUT, LERR, OK ) + NT = NT + 10 +* * CGGEVX * SRNAMT = 'CGGEVX' diff --git a/TESTING/EIG/dchkee.f b/TESTING/EIG/dchkee.f index 2123aa7..8a29cc1 100644 --- a/TESTING/EIG/dchkee.f +++ b/TESTING/EIG/dchkee.f @@ -2,14 +2,14 @@ * * =========== 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: * =========== * * PROGRAM DCHKEE -* +* * *> \par Purpose: * ============= @@ -44,7 +44,7 @@ *> Test DGEESX *> *> DGG (Generalized Nonsymmetric Eigenvalue Problem): -*> Test DGGHRD, DGGBAL, DGGBAK, DHGEQZ, and DTGEVC +*> Test DGGHD3, DGGBAL, DGGBAK, DHGEQZ, and DTGEVC *> and the driver routines DGEGS and DGEGV *> *> DGS (Generalized Nonsymmetric Schur form Driver): @@ -493,38 +493,41 @@ *> line 8: MXBVAL, INTEGER array, dimension (NPARMS) *> The values for MAXB, used in determining minimum blocksize. *> -*> line 9: NBCOL, INTEGER array, dimension (NPARMS) +*> line 9: IACC22, INTEGER array, dimension (NPARMS) +*> select structured matrix multiply: 1 or 2) +*> +*> line 10: NBCOL, INTEGER array, dimension (NPARMS) *> The values for NBCOL, the minimum column dimension for *> blocks. *> -*> line 10: THRESH +*> line 11: THRESH *> Threshold value for the test ratios. Information will be *> printed about each test for which the test ratio is greater *> than or equal to the threshold. *> -*> line 11: TSTCHK, LOGICAL +*> line 12: TSTCHK, LOGICAL *> Flag indicating whether or not to test the LAPACK routines. *> -*> line 12: TSTDRV, LOGICAL +*> line 13: TSTDRV, LOGICAL *> Flag indicating whether or not to test the driver routines. *> -*> line 13: TSTERR, LOGICAL +*> line 14: TSTERR, LOGICAL *> Flag indicating whether or not to test the error exits for *> the LAPACK routines and driver routines. *> -*> line 14: NEWSD, INTEGER +*> line 15: NEWSD, INTEGER *> A code indicating how to set the random number seed. *> = 0: Set the seed to a default value before each run *> = 1: Initialize the seed to a default value only before the *> first run *> = 2: Like 1, but use the seed values on the next line *> -*> If line 14 was 2: +*> If line 15 was 2: *> -*> line 15: INTEGER array, dimension (4) +*> line 16: INTEGER array, dimension (4) *> Four integer values for the random number seed. *> -*> lines 15-EOF: Lines specifying matrix types, as for NEP. +*> lines 17-EOF: Lines specifying matrix types, as for NEP. *> The 3-character path name is 'DGG' for the generalized *> eigenvalue problem routines and driver routines. *> @@ -1027,10 +1030,10 @@ * 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 2013 * @@ -1076,7 +1079,7 @@ CHARACTER*80 LINE INTEGER I, I1, IC, INFO, ITMP, K, LENP, MAXTYP, NEWSD, $ NK, NN, NPARMS, NRHS, NTYPES, - $ VERS_MAJOR, VERS_MINOR, VERS_PATCH + $ VERS_MAJOR, VERS_MINOR, VERS_PATCH DOUBLE PRECISION EPS, S1, S2, THRESH, THRSHN * .. * .. Local Arrays .. @@ -1104,7 +1107,8 @@ $ DCKCSD, DCKGLM, DCKGQR, DCKGSV, DCKLSE, DDRGES, $ DDRGEV, DDRGSX, DDRGVX, DDRVBD, DDRVES, DDRVEV, $ DDRVGG, DDRVSG, DDRVST, DDRVSX, DDRVVX, DERRBD, - $ DERRED, DERRGG, DERRHS, DERRST, ILAVER, XLAENV + $ DERRED, DERRGG, DERRHS, DERRST, ILAVER, XLAENV, + $ DDRGES3, DDRGEV3 * .. * .. Intrinsic Functions .. INTRINSIC LEN, MIN @@ -1630,7 +1634,7 @@ * * Read the values for IACC22. * - IF( NEP ) THEN + IF( NEP .OR. DGG ) THEN READ( NIN, FMT = * )( IACC22( I ), I = 1, NPARMS ) DO 620 I = 1, NPARMS IF( IACC22( I ).LT.0 ) THEN @@ -2097,6 +2101,7 @@ * NBMIN = minimum block size * NS = number of shifts * MAXB = minimum submatrix size +* IACC22: structured matrix multiply * NBCOL = minimum column dimension for blocks * MAXTYP = 26 @@ -2109,6 +2114,7 @@ CALL XLAENV( 2, NBMIN( I ) ) CALL XLAENV( 4, NSVAL( I ) ) CALL XLAENV( 8, MXBVAL( I ) ) + CALL XLAENV( 16, IACC22( I ) ) CALL XLAENV( 5, NBCOL( I ) ) * IF( NEWSD.EQ.0 ) THEN @@ -2117,7 +2123,7 @@ 340 CONTINUE END IF WRITE( NOUT, FMT = 9996 )C3, NBVAL( I ), NBMIN( I ), - $ NSVAL( I ), MXBVAL( I ), NBCOL( I ) + $ NSVAL( I ), MXBVAL( I ), IACC22( I ), NBCOL( I ) TSTDIF = .FALSE. THRSHN = 10.D0 IF( TSTCHK ) THEN @@ -2167,9 +2173,18 @@ $ A( 1, 4 ), A( 1, 7 ), NMAX, A( 1, 8 ), $ D( 1, 1 ), D( 1, 2 ), D( 1, 3 ), WORK, LWORK, $ RESULT, LOGWRK, INFO ) + IF( INFO.NE.0 ) + $ WRITE( NOUT, FMT = 9980 )'DDRGES', INFO * +* Blocked version +* + CALL DDRGES3( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT, + $ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ), + $ A( 1, 4 ), A( 1, 7 ), NMAX, A( 1, 8 ), + $ D( 1, 1 ), D( 1, 2 ), D( 1, 3 ), WORK, LWORK, + $ RESULT, LOGWRK, INFO ) IF( INFO.NE.0 ) - $ WRITE( NOUT, FMT = 9980 )'DDRGES', INFO + $ WRITE( NOUT, FMT = 9980 )'DDRGES3', INFO END IF WRITE( NOUT, FMT = 9973 ) GO TO 10 @@ -2224,6 +2239,17 @@ $ WORK, LWORK, RESULT, INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'DDRGEV', INFO +* +* Blocked version +* + CALL DDRGEV3( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT, + $ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ), + $ A( 1, 4 ), A( 1, 7 ), NMAX, A( 1, 8 ), + $ A( 1, 9 ), NMAX, D( 1, 1 ), D( 1, 2 ), + $ D( 1, 3 ), D( 1, 4 ), D( 1, 5 ), D( 1, 6 ), + $ WORK, LWORK, RESULT, INFO ) + IF( INFO.NE.0 ) + $ WRITE( NOUT, FMT = 9980 )'DDRGEV3', INFO END IF WRITE( NOUT, FMT = 9973 ) GO TO 10 @@ -2395,7 +2421,7 @@ 9999 FORMAT( / ' Execution not attempted due to input errors' ) 9997 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4 ) 9996 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NS =', I4, - $ ', MAXB =', I4, ', NBCOL =', I4 ) + $ ', MAXB =', I4, ', IACC22 =', I4, ', NBCOL =', I4 ) 9995 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4, $ ', NRHS =', I4 ) 9994 FORMAT( / / ' End of tests' ) @@ -2451,7 +2477,7 @@ 9962 FORMAT( / ' Tests of the Generalized Nonsymmetric Eigenvalue ', $ 'Problem Expert Driver DGGEVX' ) 9961 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4, - $ ', INMIN=', I4, + $ ', INMIN=', I4, $ ', INWIN =', I4, ', INIBL =', I4, ', ISHFTS =', I4, $ ', IACC22 =', I4) 9960 FORMAT( / ' Tests of the CS Decomposition routines' ) diff --git a/TESTING/EIG/ddrges3.f b/TESTING/EIG/ddrges3.f new file mode 100644 index 0000000..7736301 --- /dev/null +++ b/TESTING/EIG/ddrges3.f @@ -0,0 +1,997 @@ +*> \brief \b DDRGES3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DDRGES3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, ALPHAR, +* ALPHAI, BETA, WORK, LWORK, RESULT, BWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL BWORK( * ), DOTYPE( * ) +* INTEGER ISEED( 4 ), NN( * ) +* DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), +* $ B( LDA, * ), BETA( * ), Q( LDQ, * ), +* $ RESULT( 13 ), S( LDA, * ), T( LDA, * ), +* $ WORK( * ), Z( LDQ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DDRGES3 checks the nonsymmetric generalized eigenvalue (Schur form) +*> problem driver DGGES3. +*> +*> DGGES3 factors A and B as Q S Z' and Q T Z' , where ' means +*> transpose, T is upper triangular, S is in generalized Schur form +*> (block upper triangular, with 1x1 and 2x2 blocks on the diagonal, +*> the 2x2 blocks corresponding to complex conjugate pairs of +*> generalized eigenvalues), and Q and Z are orthogonal. It also +*> computes the generalized eigenvalues (alpha(j),beta(j)), j=1,...,n, +*> Thus, w(j) = alpha(j)/beta(j) is a root of the characteristic +*> equation +*> det( A - w(j) B ) = 0 +*> Optionally it also reorder the eigenvalues so that a selected +*> cluster of eigenvalues appears in the leading diagonal block of the +*> Schur forms. +*> +*> When DDRGES3 is called, a number of matrix "sizes" ("N's") and a +*> number of matrix "TYPES" are specified. For each size ("N") +*> and each TYPE of matrix, a pair of matrices (A, B) will be generated +*> and used for testing. For each matrix pair, the following 13 tests +*> will be performed and compared with the threshhold THRESH except +*> the tests (5), (11) and (13). +*> +*> +*> (1) | A - Q S Z' | / ( |A| n ulp ) (no sorting of eigenvalues) +*> +*> +*> (2) | B - Q T Z' | / ( |B| n ulp ) (no sorting of eigenvalues) +*> +*> +*> (3) | I - QQ' | / ( n ulp ) (no sorting of eigenvalues) +*> +*> +*> (4) | I - ZZ' | / ( n ulp ) (no sorting of eigenvalues) +*> +*> (5) if A is in Schur form (i.e. quasi-triangular form) +*> (no sorting of eigenvalues) +*> +*> (6) if eigenvalues = diagonal blocks of the Schur form (S, T), +*> i.e., test the maximum over j of D(j) where: +*> +*> if alpha(j) is real: +*> |alpha(j) - S(j,j)| |beta(j) - T(j,j)| +*> D(j) = ------------------------ + ----------------------- +*> max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) +*> +*> if alpha(j) is complex: +*> | det( s S - w T ) | +*> D(j) = --------------------------------------------------- +*> ulp max( s norm(S), |w| norm(T) )*norm( s S - w T ) +*> +*> and S and T are here the 2 x 2 diagonal blocks of S and T +*> corresponding to the j-th and j+1-th eigenvalues. +*> (no sorting of eigenvalues) +*> +*> (7) | (A,B) - Q (S,T) Z' | / ( | (A,B) | n ulp ) +*> (with sorting of eigenvalues). +*> +*> (8) | I - QQ' | / ( n ulp ) (with sorting of eigenvalues). +*> +*> (9) | I - ZZ' | / ( n ulp ) (with sorting of eigenvalues). +*> +*> (10) if A is in Schur form (i.e. quasi-triangular form) +*> (with sorting of eigenvalues). +*> +*> (11) if eigenvalues = diagonal blocks of the Schur form (S, T), +*> i.e. test the maximum over j of D(j) where: +*> +*> if alpha(j) is real: +*> |alpha(j) - S(j,j)| |beta(j) - T(j,j)| +*> D(j) = ------------------------ + ----------------------- +*> max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) +*> +*> if alpha(j) is complex: +*> | det( s S - w T ) | +*> D(j) = --------------------------------------------------- +*> ulp max( s norm(S), |w| norm(T) )*norm( s S - w T ) +*> +*> and S and T are here the 2 x 2 diagonal blocks of S and T +*> corresponding to the j-th and j+1-th eigenvalues. +*> (with sorting of eigenvalues). +*> +*> (12) if sorting worked and SDIM is the number of eigenvalues +*> which were SELECTed. +*> +*> Test Matrices +*> ============= +*> +*> The sizes of the test matrices are specified by an array +*> NN(1:NSIZES); the value of each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if +*> DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) ( 0, 0 ) (a pair of zero matrices) +*> +*> (2) ( I, 0 ) (an identity and a zero matrix) +*> +*> (3) ( 0, I ) (an identity and a zero matrix) +*> +*> (4) ( I, I ) (a pair of identity matrices) +*> +*> t t +*> (5) ( J , J ) (a pair of transposed Jordan blocks) +*> +*> t ( I 0 ) +*> (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) +*> ( 0 I ) ( 0 J ) +*> and I is a k x k identity and J a (k+1)x(k+1) +*> Jordan block; k=(N-1)/2 +*> +*> (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal +*> matrix with those diagonal entries.) +*> (8) ( I, D ) +*> +*> (9) ( big*D, small*I ) where "big" is near overflow and small=1/big +*> +*> (10) ( small*D, big*I ) +*> +*> (11) ( big*I, small*D ) +*> +*> (12) ( small*I, big*D ) +*> +*> (13) ( big*D, big*I ) +*> +*> (14) ( small*D, small*I ) +*> +*> (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and +*> D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) +*> t t +*> (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. +*> +*> (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices +*> with random O(1) entries above the diagonal +*> and diagonal entries diag(T1) = +*> ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = +*> ( 0, N-3, N-4,..., 1, 0, 0 ) +*> +*> (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) +*> s = machine precision. +*> +*> (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) +*> +*> N-5 +*> (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) +*> +*> (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) +*> where r1,..., r(N-4) are random. +*> +*> (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular +*> matrices. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> DDRGES3 does nothing. NSIZES >= 0. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. NN >= 0. +*> \endverbatim +*> +*> \param[in] NTYPES +*> \verbatim +*> NTYPES is INTEGER +*> The number of elements in DOTYPE. If it is zero, DDRGES3 +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A on input. +*> This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> \endverbatim +*> +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> \endverbatim +*> +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to DDRGES3 to continue the same random number +*> sequence. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error is +*> scaled to be O(1), so THRESH should be a reasonably small +*> multiple of 1, e.g., 10 or 100. In particular, it should +*> not depend on the precision (single vs. double) or the size +*> of the matrix. THRESH >= 0. +*> \endverbatim +*> +*> \param[in] NOUNIT +*> \verbatim +*> NOUNIT is INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, +*> dimension(LDA, max(NN)) +*> Used to hold the original A matrix. Used as input only +*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and +*> DOTYPE(MAXTYP+1)=.TRUE. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A, B, S, and T. +*> It must be at least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, +*> dimension(LDA, max(NN)) +*> Used to hold the original B matrix. Used as input only +*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and +*> DOTYPE(MAXTYP+1)=.TRUE. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension (LDA, max(NN)) +*> The Schur form matrix computed from A by DGGES3. On exit, S +*> contains the Schur form matrix corresponding to the matrix +*> in A. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDA, max(NN)) +*> The upper triangular matrix computed from B by DGGES3. +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, dimension (LDQ, max(NN)) +*> The (left) orthogonal matrix computed by DGGES3. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of Q and Z. It must +*> be at least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension( LDQ, max(NN) ) +*> The (right) orthogonal matrix computed by DGGES3. +*> \endverbatim +*> +*> \param[out] ALPHAR +*> \verbatim +*> ALPHAR is DOUBLE PRECISION array, dimension (max(NN)) +*> \endverbatim +*> +*> \param[out] ALPHAI +*> \verbatim +*> ALPHAI is DOUBLE PRECISION array, dimension (max(NN)) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION array, dimension (max(NN)) +*> +*> The generalized eigenvalues of (A,B) computed by DGGES3. +*> ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th +*> generalized eigenvalue of A and B. +*> \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 >= MAX( 10*(N+1), 3*N*N ), where N is the largest +*> matrix dimension. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (15) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid overflow. +*> \endverbatim +*> +*> \param[out] BWORK +*> \verbatim +*> BWORK is LOGICAL 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: A routine returned an error code. INFO is the +*> absolute value of the INFO value returned. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date February 2015 +* +*> \ingroup double_eig +* +* ===================================================================== + SUBROUTINE DDRGES3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, ALPHAR, + $ ALPHAI, BETA, WORK, LWORK, RESULT, BWORK, + $ INFO ) +* +* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* February 2015 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL BWORK( * ), DOTYPE( * ) + INTEGER ISEED( 4 ), NN( * ) + DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), + $ B( LDA, * ), BETA( * ), Q( LDQ, * ), + $ RESULT( 13 ), S( LDA, * ), T( LDA, * ), + $ WORK( * ), Z( LDQ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 26 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN, ILABAD + CHARACTER SORT + INTEGER I, I1, IADD, IERR, IINFO, IN, ISORT, J, JC, JR, + $ JSIZE, JTYPE, KNTEIG, MAXWRK, MINWRK, MTYPES, + $ N, N1, NB, NERRS, NMATS, NMAX, NTEST, NTESTT, + $ RSUB, SDIM + DOUBLE PRECISION SAFMAX, SAFMIN, TEMP1, TEMP2, ULP, ULPINV +* .. +* .. Local Arrays .. + INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ), + $ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ), + $ KATYPE( MAXTYP ), KAZERO( MAXTYP ), + $ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ), + $ KBZERO( MAXTYP ), KCLASS( MAXTYP ), + $ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 ) + DOUBLE PRECISION RMAGN( 0: 3 ) +* .. +* .. External Functions .. + LOGICAL DLCTES + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLARND + EXTERNAL DLCTES, ILAENV, DLAMCH, DLARND +* .. +* .. External Subroutines .. + EXTERNAL ALASVM, DGET51, DGET53, DGET54, DGGES3, DLABAD, + $ DLACPY, DLARFG, DLASET, DLATM4, DORM2R, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SIGN +* .. +* .. Data statements .. + DATA KCLASS / 15*1, 10*2, 1*3 / + DATA KZ1 / 0, 1, 2, 1, 3, 3 / + DATA KZ2 / 0, 0, 1, 2, 1, 1 / + DATA KADD / 0, 0, 0, 0, 3, 2 / + DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4, + $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 / + DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4, + $ 1, 1, -4, 2, -4, 8*8, 0 / + DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3, + $ 4*5, 4*3, 1 / + DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4, + $ 4*6, 4*4, 1 / + DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3, + $ 2, 1 / + DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3, + $ 2, 1 / + DATA KTRIAN / 16*0, 10*1 / + DATA IASIGN / 6*0, 2, 0, 2*2, 2*0, 3*2, 0, 2, 3*0, + $ 5*2, 0 / + DATA IBSIGN / 7*0, 2, 2*0, 2*2, 2*0, 2, 0, 2, 9*0 / +* .. +* .. Executable Statements .. +* +* Check for errors +* + INFO = 0 +* + BADNN = .FALSE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( THRESH.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDQ.LE.1 .OR. LDQ.LT.NMAX ) THEN + INFO = -14 + END IF +* +* Compute workspace +* (Note: Comments in the code beginning "Workspace:" describe the +* minimal amount of workspace needed at that point in the code, +* as well as the preferred amount for good performance. +* NB refers to the optimal block size for the immediately +* following subroutine, as returned by ILAENV. +* + MINWRK = 1 + IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN + MINWRK = MAX( 10*( NMAX+1 ), 3*NMAX*NMAX ) + NB = MAX( 1, ILAENV( 1, 'DGEQRF', ' ', NMAX, NMAX, -1, -1 ), + $ ILAENV( 1, 'DORMQR', 'LT', NMAX, NMAX, NMAX, -1 ), + $ ILAENV( 1, 'DORGQR', ' ', NMAX, NMAX, NMAX, -1 ) ) + MAXWRK = MAX( 10*( NMAX+1 ), 2*NMAX+NMAX*NB, 3*NMAX*NMAX ) + WORK( 1 ) = MAXWRK + END IF +* + IF( LWORK.LT.MINWRK ) + $ INFO = -20 +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DDRGES3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* + SAFMIN = DLAMCH( 'Safe minimum' ) + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) + SAFMIN = SAFMIN / ULP + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULPINV = ONE / ULP +* +* The values RMAGN(2:3) depend on N, see below. +* + RMAGN( 0 ) = ZERO + RMAGN( 1 ) = ONE +* +* Loop over matrix sizes +* + NTESTT = 0 + NERRS = 0 + NMATS = 0 +* + DO 190 JSIZE = 1, NSIZES + N = NN( JSIZE ) + N1 = MAX( 1, N ) + RMAGN( 2 ) = SAFMAX*ULP / DBLE( N1 ) + RMAGN( 3 ) = SAFMIN*ULPINV*DBLE( N1 ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* +* Loop over matrix types +* + DO 180 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 180 + NMATS = NMATS + 1 + NTEST = 0 +* +* Save ISEED in case of an error. +* + DO 20 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 20 CONTINUE +* +* Initialize RESULT +* + DO 30 J = 1, 13 + RESULT( J ) = ZERO + 30 CONTINUE +* +* Generate test matrices A and B +* +* Description of control parameters: +* +* KZLASS: =1 means w/o rotation, =2 means w/ rotation, +* =3 means random. +* KATYPE: the "type" to be passed to DLATM4 for computing A. +* KAZERO: the pattern of zeros on the diagonal for A: +* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), +* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), +* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of +* non-zero entries.) +* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), +* =2: large, =3: small. +* IASIGN: 1 if the diagonal elements of A are to be +* multiplied by a random magnitude 1 number, =2 if +* randomly chosen diagonal blocks are to be rotated +* to form 2x2 blocks. +* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B. +* KTRIAN: =0: don't fill in the upper triangle, =1: do. +* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. +* RMAGN: used to implement KAMAGN and KBMAGN. +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 110 + IINFO = 0 + IF( KCLASS( JTYPE ).LT.3 ) THEN +* +* Generate A (w/o rotation) +* + IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN + IN = 2*( ( N-1 ) / 2 ) + 1 + IF( IN.NE.N ) + $ CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA ) + ELSE + IN = N + END IF + CALL DLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ), + $ KZ2( KAZERO( JTYPE ) ), IASIGN( JTYPE ), + $ RMAGN( KAMAGN( JTYPE ) ), ULP, + $ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2, + $ ISEED, A, LDA ) + IADD = KADD( KAZERO( JTYPE ) ) + IF( IADD.GT.0 .AND. IADD.LE.N ) + $ A( IADD, IADD ) = ONE +* +* Generate B (w/o rotation) +* + IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN + IN = 2*( ( N-1 ) / 2 ) + 1 + IF( IN.NE.N ) + $ CALL DLASET( 'Full', N, N, ZERO, ZERO, B, LDA ) + ELSE + IN = N + END IF + CALL DLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ), + $ KZ2( KBZERO( JTYPE ) ), IBSIGN( JTYPE ), + $ RMAGN( KBMAGN( JTYPE ) ), ONE, + $ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2, + $ ISEED, B, LDA ) + IADD = KADD( KBZERO( JTYPE ) ) + IF( IADD.NE.0 .AND. IADD.LE.N ) + $ B( IADD, IADD ) = ONE +* + IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN +* +* Include rotations +* +* Generate Q, Z as Householder transformations times +* a diagonal matrix. +* + DO 50 JC = 1, N - 1 + DO 40 JR = JC, N + Q( JR, JC ) = DLARND( 3, ISEED ) + Z( JR, JC ) = DLARND( 3, ISEED ) + 40 CONTINUE + CALL DLARFG( N+1-JC, Q( JC, JC ), Q( JC+1, JC ), 1, + $ WORK( JC ) ) + WORK( 2*N+JC ) = SIGN( ONE, Q( JC, JC ) ) + Q( JC, JC ) = ONE + CALL DLARFG( N+1-JC, Z( JC, JC ), Z( JC+1, JC ), 1, + $ WORK( N+JC ) ) + WORK( 3*N+JC ) = SIGN( ONE, Z( JC, JC ) ) + Z( JC, JC ) = ONE + 50 CONTINUE + Q( N, N ) = ONE + WORK( N ) = ZERO + WORK( 3*N ) = SIGN( ONE, DLARND( 2, ISEED ) ) + Z( N, N ) = ONE + WORK( 2*N ) = ZERO + WORK( 4*N ) = SIGN( ONE, DLARND( 2, ISEED ) ) +* +* Apply the diagonal matrices +* + DO 70 JC = 1, N + DO 60 JR = 1, N + A( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )* + $ A( JR, JC ) + B( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )* + $ B( JR, JC ) + 60 CONTINUE + 70 CONTINUE + CALL DORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, A, + $ LDA, WORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) + $ GO TO 100 + CALL DORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ), + $ A, LDA, WORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) + $ GO TO 100 + CALL DORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, B, + $ LDA, WORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) + $ GO TO 100 + CALL DORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ), + $ B, LDA, WORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) + $ GO TO 100 + END IF + ELSE +* +* Random matrices +* + DO 90 JC = 1, N + DO 80 JR = 1, N + A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )* + $ DLARND( 2, ISEED ) + B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )* + $ DLARND( 2, ISEED ) + 80 CONTINUE + 90 CONTINUE + END IF +* + 100 CONTINUE +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 110 CONTINUE +* + DO 120 I = 1, 13 + RESULT( I ) = -ONE + 120 CONTINUE +* +* Test with and without sorting of eigenvalues +* + DO 150 ISORT = 0, 1 + IF( ISORT.EQ.0 ) THEN + SORT = 'N' + RSUB = 0 + ELSE + SORT = 'S' + RSUB = 5 + END IF +* +* Call DGGES3 to compute H, T, Q, Z, alpha, and beta. +* + CALL DLACPY( 'Full', N, N, A, LDA, S, LDA ) + CALL DLACPY( 'Full', N, N, B, LDA, T, LDA ) + NTEST = 1 + RSUB + ISORT + RESULT( 1+RSUB+ISORT ) = ULPINV + CALL DGGES3( 'V', 'V', SORT, DLCTES, N, S, LDA, T, LDA, + $ SDIM, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDQ, + $ WORK, LWORK, BWORK, IINFO ) + IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN + RESULT( 1+RSUB+ISORT ) = ULPINV + WRITE( NOUNIT, FMT = 9999 )'DGGES3', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + GO TO 160 + END IF +* + NTEST = 4 + RSUB +* +* Do tests 1--4 (or tests 7--9 when reordering ) +* + IF( ISORT.EQ.0 ) THEN + CALL DGET51( 1, N, A, LDA, S, LDA, Q, LDQ, Z, LDQ, + $ WORK, RESULT( 1 ) ) + CALL DGET51( 1, N, B, LDA, T, LDA, Q, LDQ, Z, LDQ, + $ WORK, RESULT( 2 ) ) + ELSE + CALL DGET54( N, A, LDA, B, LDA, S, LDA, T, LDA, Q, + $ LDQ, Z, LDQ, WORK, RESULT( 7 ) ) + END IF + CALL DGET51( 3, N, A, LDA, T, LDA, Q, LDQ, Q, LDQ, WORK, + $ RESULT( 3+RSUB ) ) + CALL DGET51( 3, N, B, LDA, T, LDA, Z, LDQ, Z, LDQ, WORK, + $ RESULT( 4+RSUB ) ) +* +* Do test 5 and 6 (or Tests 10 and 11 when reordering): +* check Schur form of A and compare eigenvalues with +* diagonals. +* + NTEST = 6 + RSUB + TEMP1 = ZERO +* + DO 130 J = 1, N + ILABAD = .FALSE. + IF( ALPHAI( J ).EQ.ZERO ) THEN + TEMP2 = ( ABS( ALPHAR( J )-S( J, J ) ) / + $ MAX( SAFMIN, ABS( ALPHAR( J ) ), ABS( S( J, + $ J ) ) )+ABS( BETA( J )-T( J, J ) ) / + $ MAX( SAFMIN, ABS( BETA( J ) ), ABS( T( J, + $ J ) ) ) ) / ULP +* + IF( J.LT.N ) THEN + IF( S( J+1, J ).NE.ZERO ) THEN + ILABAD = .TRUE. + RESULT( 5+RSUB ) = ULPINV + END IF + END IF + IF( J.GT.1 ) THEN + IF( S( J, J-1 ).NE.ZERO ) THEN + ILABAD = .TRUE. + RESULT( 5+RSUB ) = ULPINV + END IF + END IF +* + ELSE + IF( ALPHAI( J ).GT.ZERO ) THEN + I1 = J + ELSE + I1 = J - 1 + END IF + IF( I1.LE.0 .OR. I1.GE.N ) THEN + ILABAD = .TRUE. + ELSE IF( I1.LT.N-1 ) THEN + IF( S( I1+2, I1+1 ).NE.ZERO ) THEN + ILABAD = .TRUE. + RESULT( 5+RSUB ) = ULPINV + END IF + ELSE IF( I1.GT.1 ) THEN + IF( S( I1, I1-1 ).NE.ZERO ) THEN + ILABAD = .TRUE. + RESULT( 5+RSUB ) = ULPINV + END IF + END IF + IF( .NOT.ILABAD ) THEN + CALL DGET53( S( I1, I1 ), LDA, T( I1, I1 ), LDA, + $ BETA( J ), ALPHAR( J ), + $ ALPHAI( J ), TEMP2, IERR ) + IF( IERR.GE.3 ) THEN + WRITE( NOUNIT, FMT = 9998 )IERR, J, N, + $ JTYPE, IOLDSD + INFO = ABS( IERR ) + END IF + ELSE + TEMP2 = ULPINV + END IF +* + END IF + TEMP1 = MAX( TEMP1, TEMP2 ) + IF( ILABAD ) THEN + WRITE( NOUNIT, FMT = 9997 )J, N, JTYPE, IOLDSD + END IF + 130 CONTINUE + RESULT( 6+RSUB ) = TEMP1 +* + IF( ISORT.GE.1 ) THEN +* +* Do test 12 +* + NTEST = 12 + RESULT( 12 ) = ZERO + KNTEIG = 0 + DO 140 I = 1, N + IF( DLCTES( ALPHAR( I ), ALPHAI( I ), + $ BETA( I ) ) .OR. DLCTES( ALPHAR( I ), + $ -ALPHAI( I ), BETA( I ) ) ) THEN + KNTEIG = KNTEIG + 1 + END IF + IF( I.LT.N ) THEN + IF( ( DLCTES( ALPHAR( I+1 ), ALPHAI( I+1 ), + $ BETA( I+1 ) ) .OR. DLCTES( ALPHAR( I+1 ), + $ -ALPHAI( I+1 ), BETA( I+1 ) ) ) .AND. + $ ( .NOT.( DLCTES( ALPHAR( I ), ALPHAI( I ), + $ BETA( I ) ) .OR. DLCTES( ALPHAR( I ), + $ -ALPHAI( I ), BETA( I ) ) ) ) .AND. + $ IINFO.NE.N+2 ) THEN + RESULT( 12 ) = ULPINV + END IF + END IF + 140 CONTINUE + IF( SDIM.NE.KNTEIG ) THEN + RESULT( 12 ) = ULPINV + END IF + END IF +* + 150 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + 160 CONTINUE +* + NTESTT = NTESTT + NTEST +* +* Print out tests which fail. +* + DO 170 JR = 1, NTEST + IF( RESULT( JR ).GE.THRESH ) THEN +* +* If this is the first test to fail, +* print a header to the data file. +* + IF( NERRS.EQ.0 ) THEN + WRITE( NOUNIT, FMT = 9996 )'DGS' +* +* Matrix types +* + WRITE( NOUNIT, FMT = 9995 ) + WRITE( NOUNIT, FMT = 9994 ) + WRITE( NOUNIT, FMT = 9993 )'Orthogonal' +* +* Tests performed +* + WRITE( NOUNIT, FMT = 9992 )'orthogonal', '''', + $ 'transpose', ( '''', J = 1, 8 ) +* + END IF + NERRS = NERRS + 1 + IF( RESULT( JR ).LT.10000.0D0 ) THEN + WRITE( NOUNIT, FMT = 9991 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + ELSE + WRITE( NOUNIT, FMT = 9990 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + END IF + END IF + 170 CONTINUE +* + 180 CONTINUE + 190 CONTINUE +* +* Summary +* + CALL ALASVM( 'DGS', NOUNIT, NERRS, NTESTT, 0 ) +* + WORK( 1 ) = MAXWRK +* + RETURN +* + 9999 FORMAT( ' DDRGES3: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', + $ I6, ', JTYPE=', I6, ', ISEED=(', 4( I4, ',' ), I5, ')' ) +* + 9998 FORMAT( ' DDRGES3: DGET53 returned INFO=', I1, ' for eigenvalue ', + $ I6, '.', / 9X, 'N=', I6, ', JTYPE=', I6, ', ISEED=(', + $ 4( I4, ',' ), I5, ')' ) +* + 9997 FORMAT( ' DDRGES3: S not in Schur form at eigenvalue ', I6, '.', + $ / 9X, 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), + $ I5, ')' ) +* + 9996 FORMAT( / 1X, A3, ' -- Real Generalized Schur form driver' ) +* + 9995 FORMAT( ' Matrix types (see DDRGES3 for details): ' ) +* + 9994 FORMAT( ' Special Matrices:', 23X, + $ '(J''=transposed Jordan block)', + $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ', + $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ', + $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I', + $ ') 11=(large*I, small*D) 13=(large*D, large*I)', / + $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ', + $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' ) + 9993 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:', + $ / ' 16=Transposed Jordan Blocks 19=geometric ', + $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ', + $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ', + $ 'alpha, beta=0,1 21=random alpha, beta=0,1', + $ / ' Large & Small Matrices:', / ' 22=(large, small) ', + $ '23=(small,large) 24=(small,small) 25=(large,large)', + $ / ' 26=random O(1) matrices.' ) +* + 9992 FORMAT( / ' Tests performed: (S is Schur, T is triangular, ', + $ 'Q and Z are ', A, ',', / 19X, + $ 'l and r are the appropriate left and right', / 19X, + $ 'eigenvectors, resp., a is alpha, b is beta, and', / 19X, A, + $ ' means ', A, '.)', / ' Without ordering: ', + $ / ' 1 = | A - Q S Z', A, + $ ' | / ( |A| n ulp ) 2 = | B - Q T Z', A, + $ ' | / ( |B| n ulp )', / ' 3 = | I - QQ', A, + $ ' | / ( n ulp ) 4 = | I - ZZ', A, + $ ' | / ( n ulp )', / ' 5 = A is in Schur form S', + $ / ' 6 = difference between (alpha,beta)', + $ ' and diagonals of (S,T)', / ' With ordering: ', + $ / ' 7 = | (A,B) - Q (S,T) Z', A, + $ ' | / ( |(A,B)| n ulp ) ', / ' 8 = | I - QQ', A, + $ ' | / ( n ulp ) 9 = | I - ZZ', A, + $ ' | / ( n ulp )', / ' 10 = A is in Schur form S', + $ / ' 11 = difference between (alpha,beta) and diagonals', + $ ' of (S,T)', / ' 12 = SDIM is the correct number of ', + $ 'selected eigenvalues', / ) + 9991 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I2, ' is', 0P, F8.2 ) + 9990 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I2, ' is', 1P, D10.3 ) +* +* End of DDRGES3 +* + END diff --git a/TESTING/EIG/ddrgev3.f b/TESTING/EIG/ddrgev3.f new file mode 100644 index 0000000..79f08b9 --- /dev/null +++ b/TESTING/EIG/ddrgev3.f @@ -0,0 +1,940 @@ +*> \brief \b DDRGEV3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DDRGEV3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, QE, LDQE, +* ALPHAR, ALPHAI, BETA, ALPHR1, ALPHI1, BETA1, +* WORK, LWORK, RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDQ, LDQE, LWORK, NOUNIT, NSIZES, +* $ NTYPES +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), NN( * ) +* DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), +* $ ALPHI1( * ), ALPHR1( * ), B( LDA, * ), +* $ BETA( * ), BETA1( * ), Q( LDQ, * ), +* $ QE( LDQE, * ), RESULT( * ), S( LDA, * ), +* $ T( LDA, * ), WORK( * ), Z( LDQ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DDRGEV3 checks the nonsymmetric generalized eigenvalue problem driver +*> routine DGGEV3. +*> +*> DGGEV3 computes for a pair of n-by-n nonsymmetric matrices (A,B) the +*> generalized eigenvalues and, optionally, the left and right +*> eigenvectors. +*> +*> A generalized eigenvalue for a pair of matrices (A,B) is a scalar w +*> or a ratio alpha/beta = w, such that A - w*B is singular. It is +*> usually represented as the pair (alpha,beta), as there is reasonable +*> interpretation for beta=0, and even for both being zero. +*> +*> A right generalized eigenvector corresponding to a generalized +*> eigenvalue w for a pair of matrices (A,B) is a vector r such that +*> (A - wB) * r = 0. A left generalized eigenvector is a vector l such +*> that l**H * (A - wB) = 0, where l**H is the conjugate-transpose of l. +*> +*> When DDRGEV3 is called, a number of matrix "sizes" ("n's") and a +*> number of matrix "types" are specified. For each size ("n") +*> and each type of matrix, a pair of matrices (A, B) will be generated +*> and used for testing. For each matrix pair, the following tests +*> will be performed and compared with the threshhold THRESH. +*> +*> Results from DGGEV3: +*> +*> (1) max over all left eigenvalue/-vector pairs (alpha/beta,l) of +*> +*> | VL**H * (beta A - alpha B) |/( ulp max(|beta A|, |alpha B|) ) +*> +*> where VL**H is the conjugate-transpose of VL. +*> +*> (2) | |VL(i)| - 1 | / ulp and whether largest component real +*> +*> VL(i) denotes the i-th column of VL. +*> +*> (3) max over all left eigenvalue/-vector pairs (alpha/beta,r) of +*> +*> | (beta A - alpha B) * VR | / ( ulp max(|beta A|, |alpha B|) ) +*> +*> (4) | |VR(i)| - 1 | / ulp and whether largest component real +*> +*> VR(i) denotes the i-th column of VR. +*> +*> (5) W(full) = W(partial) +*> W(full) denotes the eigenvalues computed when both l and r +*> are also computed, and W(partial) denotes the eigenvalues +*> computed when only W, only W and r, or only W and l are +*> computed. +*> +*> (6) VL(full) = VL(partial) +*> VL(full) denotes the left eigenvectors computed when both l +*> and r are computed, and VL(partial) denotes the result +*> when only l is computed. +*> +*> (7) VR(full) = VR(partial) +*> VR(full) denotes the right eigenvectors computed when both l +*> and r are also computed, and VR(partial) denotes the result +*> when only l is computed. +*> +*> +*> Test Matrices +*> ---- -------- +*> +*> The sizes of the test matrices are specified by an array +*> NN(1:NSIZES); the value of each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if +*> DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) ( 0, 0 ) (a pair of zero matrices) +*> +*> (2) ( I, 0 ) (an identity and a zero matrix) +*> +*> (3) ( 0, I ) (an identity and a zero matrix) +*> +*> (4) ( I, I ) (a pair of identity matrices) +*> +*> t t +*> (5) ( J , J ) (a pair of transposed Jordan blocks) +*> +*> t ( I 0 ) +*> (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) +*> ( 0 I ) ( 0 J ) +*> and I is a k x k identity and J a (k+1)x(k+1) +*> Jordan block; k=(N-1)/2 +*> +*> (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal +*> matrix with those diagonal entries.) +*> (8) ( I, D ) +*> +*> (9) ( big*D, small*I ) where "big" is near overflow and small=1/big +*> +*> (10) ( small*D, big*I ) +*> +*> (11) ( big*I, small*D ) +*> +*> (12) ( small*I, big*D ) +*> +*> (13) ( big*D, big*I ) +*> +*> (14) ( small*D, small*I ) +*> +*> (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and +*> D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) +*> t t +*> (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. +*> +*> (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices +*> with random O(1) entries above the diagonal +*> and diagonal entries diag(T1) = +*> ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = +*> ( 0, N-3, N-4,..., 1, 0, 0 ) +*> +*> (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) +*> s = machine precision. +*> +*> (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) +*> +*> N-5 +*> (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) +*> +*> (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) +*> where r1,..., r(N-4) are random. +*> +*> (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular +*> matrices. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> DDRGEV3 does nothing. NSIZES >= 0. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. NN >= 0. +*> \endverbatim +*> +*> \param[in] NTYPES +*> \verbatim +*> NTYPES is INTEGER +*> The number of elements in DOTYPE. If it is zero, DDRGEV3 +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> \endverbatim +*> +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> \endverbatim +*> +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to DDRGEV3 to continue the same random number +*> sequence. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error is +*> scaled to be O(1), so THRESH should be a reasonably small +*> multiple of 1, e.g., 10 or 100. In particular, it should +*> not depend on the precision (single vs. double) or the size +*> of the matrix. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NOUNIT +*> \verbatim +*> NOUNIT is INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IERR not equal to 0.) +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, +*> dimension(LDA, max(NN)) +*> Used to hold the original A matrix. Used as input only +*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and +*> DOTYPE(MAXTYP+1)=.TRUE. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A, B, S, and T. +*> It must be at least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, +*> dimension(LDA, max(NN)) +*> Used to hold the original B matrix. Used as input only +*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and +*> DOTYPE(MAXTYP+1)=.TRUE. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, +*> dimension (LDA, max(NN)) +*> The Schur form matrix computed from A by DGGEV3. On exit, S +*> contains the Schur form matrix corresponding to the matrix +*> in A. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, +*> dimension (LDA, max(NN)) +*> The upper triangular matrix computed from B by DGGEV3. +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is DOUBLE PRECISION array, +*> dimension (LDQ, max(NN)) +*> The (left) eigenvectors matrix computed by DGGEV3. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of Q and Z. It must +*> be at least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension( LDQ, max(NN) ) +*> The (right) orthogonal matrix computed by DGGEV3. +*> \endverbatim +*> +*> \param[out] QE +*> \verbatim +*> QE is DOUBLE PRECISION array, dimension( LDQ, max(NN) ) +*> QE holds the computed right or left eigenvectors. +*> \endverbatim +*> +*> \param[in] LDQE +*> \verbatim +*> LDQE is INTEGER +*> The leading dimension of QE. LDQE >= max(1,max(NN)). +*> \endverbatim +*> +*> \param[out] ALPHAR +*> \verbatim +*> ALPHAR is DOUBLE PRECISION array, dimension (max(NN)) +*> \endverbatim +*> +*> \param[out] ALPHAI +*> \verbatim +*> ALPHAI is DOUBLE PRECISION array, dimension (max(NN)) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION array, dimension (max(NN)) +*> +*> The generalized eigenvalues of (A,B) computed by DGGEV3. +*> ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th +*> generalized eigenvalue of A and B. +*> \endverbatim +*> +*> \param[out] ALPHR1 +*> \verbatim +*> ALPHR1 is DOUBLE PRECISION array, dimension (max(NN)) +*> \endverbatim +*> +*> \param[out] ALPHI1 +*> \verbatim +*> ALPHI1 is DOUBLE PRECISION array, dimension (max(NN)) +*> \endverbatim +*> +*> \param[out] BETA1 +*> \verbatim +*> BETA1 is DOUBLE PRECISION array, dimension (max(NN)) +*> +*> Like ALPHAR, ALPHAI, BETA, these arrays contain the +*> eigenvalues of A and B, but those computed when DGGEV3 only +*> computes a partial eigendecomposition, i.e. not the +*> eigenvalues and left and right eigenvectors. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The number of entries in WORK. LWORK >= MAX( 8*N, N*(N+1) ). +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (2) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid overflow. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: A routine returned an error code. INFO is the +*> absolute value of the INFO value returned. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date February 2015 +* +*> \ingroup double_eig +* +* ===================================================================== + SUBROUTINE DDRGEV3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, QE, LDQE, + $ ALPHAR, ALPHAI, BETA, ALPHR1, ALPHI1, BETA1, + $ WORK, LWORK, RESULT, INFO ) +* +* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* February 2015 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDQ, LDQE, LWORK, NOUNIT, NSIZES, + $ NTYPES + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), NN( * ) + DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), + $ ALPHI1( * ), ALPHR1( * ), B( LDA, * ), + $ BETA( * ), BETA1( * ), Q( LDQ, * ), + $ QE( LDQE, * ), RESULT( * ), S( LDA, * ), + $ T( LDA, * ), WORK( * ), Z( LDQ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 26 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + INTEGER I, IADD, IERR, IN, J, JC, JR, JSIZE, JTYPE, + $ MAXWRK, MINWRK, MTYPES, N, N1, NERRS, NMATS, + $ NMAX, NTESTT + DOUBLE PRECISION SAFMAX, SAFMIN, ULP, ULPINV +* .. +* .. Local Arrays .. + INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ), + $ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ), + $ KATYPE( MAXTYP ), KAZERO( MAXTYP ), + $ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ), + $ KBZERO( MAXTYP ), KCLASS( MAXTYP ), + $ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 ) + DOUBLE PRECISION RMAGN( 0: 3 ) +* .. +* .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLARND + EXTERNAL ILAENV, DLAMCH, DLARND +* .. +* .. External Subroutines .. + EXTERNAL ALASVM, DGET52, DGGEV3, DLABAD, DLACPY, DLARFG, + $ DLASET, DLATM4, DORM2R, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SIGN +* .. +* .. Data statements .. + DATA KCLASS / 15*1, 10*2, 1*3 / + DATA KZ1 / 0, 1, 2, 1, 3, 3 / + DATA KZ2 / 0, 0, 1, 2, 1, 1 / + DATA KADD / 0, 0, 0, 0, 3, 2 / + DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4, + $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 / + DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4, + $ 1, 1, -4, 2, -4, 8*8, 0 / + DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3, + $ 4*5, 4*3, 1 / + DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4, + $ 4*6, 4*4, 1 / + DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3, + $ 2, 1 / + DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3, + $ 2, 1 / + DATA KTRIAN / 16*0, 10*1 / + DATA IASIGN / 6*0, 2, 0, 2*2, 2*0, 3*2, 0, 2, 3*0, + $ 5*2, 0 / + DATA IBSIGN / 7*0, 2, 2*0, 2*2, 2*0, 2, 0, 2, 9*0 / +* .. +* .. Executable Statements .. +* +* Check for errors +* + INFO = 0 +* + BADNN = .FALSE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( THRESH.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDQ.LE.1 .OR. LDQ.LT.NMAX ) THEN + INFO = -14 + ELSE IF( LDQE.LE.1 .OR. LDQE.LT.NMAX ) THEN + INFO = -17 + END IF +* +* Compute workspace +* (Note: Comments in the code beginning "Workspace:" describe the +* minimal amount of workspace needed at that point in the code, +* as well as the preferred amount for good performance. +* NB refers to the optimal block size for the immediately +* following subroutine, as returned by ILAENV. +* + MINWRK = 1 + IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN + MINWRK = MAX( 1, 8*NMAX, NMAX*( NMAX+1 ) ) + MAXWRK = 7*NMAX + NMAX*ILAENV( 1, 'DGEQRF', ' ', NMAX, 1, NMAX, + $ 0 ) + MAXWRK = MAX( MAXWRK, NMAX*( NMAX+1 ) ) + WORK( 1 ) = MAXWRK + END IF +* + IF( LWORK.LT.MINWRK ) + $ INFO = -25 +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DDRGEV3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* + SAFMIN = DLAMCH( 'Safe minimum' ) + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) + SAFMIN = SAFMIN / ULP + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULPINV = ONE / ULP +* +* The values RMAGN(2:3) depend on N, see below. +* + RMAGN( 0 ) = ZERO + RMAGN( 1 ) = ONE +* +* Loop over sizes, types +* + NTESTT = 0 + NERRS = 0 + NMATS = 0 +* + DO 220 JSIZE = 1, NSIZES + N = NN( JSIZE ) + N1 = MAX( 1, N ) + RMAGN( 2 ) = SAFMAX*ULP / DBLE( N1 ) + RMAGN( 3 ) = SAFMIN*ULPINV*N1 +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 210 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 210 + NMATS = NMATS + 1 +* +* Save ISEED in case of an error. +* + DO 20 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 20 CONTINUE +* +* Generate test matrices A and B +* +* Description of control parameters: +* +* KZLASS: =1 means w/o rotation, =2 means w/ rotation, +* =3 means random. +* KATYPE: the "type" to be passed to DLATM4 for computing A. +* KAZERO: the pattern of zeros on the diagonal for A: +* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), +* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), +* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of +* non-zero entries.) +* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), +* =2: large, =3: small. +* IASIGN: 1 if the diagonal elements of A are to be +* multiplied by a random magnitude 1 number, =2 if +* randomly chosen diagonal blocks are to be rotated +* to form 2x2 blocks. +* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B. +* KTRIAN: =0: don't fill in the upper triangle, =1: do. +* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. +* RMAGN: used to implement KAMAGN and KBMAGN. +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 100 + IERR = 0 + IF( KCLASS( JTYPE ).LT.3 ) THEN +* +* Generate A (w/o rotation) +* + IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN + IN = 2*( ( N-1 ) / 2 ) + 1 + IF( IN.NE.N ) + $ CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA ) + ELSE + IN = N + END IF + CALL DLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ), + $ KZ2( KAZERO( JTYPE ) ), IASIGN( JTYPE ), + $ RMAGN( KAMAGN( JTYPE ) ), ULP, + $ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2, + $ ISEED, A, LDA ) + IADD = KADD( KAZERO( JTYPE ) ) + IF( IADD.GT.0 .AND. IADD.LE.N ) + $ A( IADD, IADD ) = ONE +* +* Generate B (w/o rotation) +* + IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN + IN = 2*( ( N-1 ) / 2 ) + 1 + IF( IN.NE.N ) + $ CALL DLASET( 'Full', N, N, ZERO, ZERO, B, LDA ) + ELSE + IN = N + END IF + CALL DLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ), + $ KZ2( KBZERO( JTYPE ) ), IBSIGN( JTYPE ), + $ RMAGN( KBMAGN( JTYPE ) ), ONE, + $ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2, + $ ISEED, B, LDA ) + IADD = KADD( KBZERO( JTYPE ) ) + IF( IADD.NE.0 .AND. IADD.LE.N ) + $ B( IADD, IADD ) = ONE +* + IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN +* +* Include rotations +* +* Generate Q, Z as Householder transformations times +* a diagonal matrix. +* + DO 40 JC = 1, N - 1 + DO 30 JR = JC, N + Q( JR, JC ) = DLARND( 3, ISEED ) + Z( JR, JC ) = DLARND( 3, ISEED ) + 30 CONTINUE + CALL DLARFG( N+1-JC, Q( JC, JC ), Q( JC+1, JC ), 1, + $ WORK( JC ) ) + WORK( 2*N+JC ) = SIGN( ONE, Q( JC, JC ) ) + Q( JC, JC ) = ONE + CALL DLARFG( N+1-JC, Z( JC, JC ), Z( JC+1, JC ), 1, + $ WORK( N+JC ) ) + WORK( 3*N+JC ) = SIGN( ONE, Z( JC, JC ) ) + Z( JC, JC ) = ONE + 40 CONTINUE + Q( N, N ) = ONE + WORK( N ) = ZERO + WORK( 3*N ) = SIGN( ONE, DLARND( 2, ISEED ) ) + Z( N, N ) = ONE + WORK( 2*N ) = ZERO + WORK( 4*N ) = SIGN( ONE, DLARND( 2, ISEED ) ) +* +* Apply the diagonal matrices +* + DO 60 JC = 1, N + DO 50 JR = 1, N + A( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )* + $ A( JR, JC ) + B( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )* + $ B( JR, JC ) + 50 CONTINUE + 60 CONTINUE + CALL DORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, A, + $ LDA, WORK( 2*N+1 ), IERR ) + IF( IERR.NE.0 ) + $ GO TO 90 + CALL DORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ), + $ A, LDA, WORK( 2*N+1 ), IERR ) + IF( IERR.NE.0 ) + $ GO TO 90 + CALL DORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, B, + $ LDA, WORK( 2*N+1 ), IERR ) + IF( IERR.NE.0 ) + $ GO TO 90 + CALL DORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ), + $ B, LDA, WORK( 2*N+1 ), IERR ) + IF( IERR.NE.0 ) + $ GO TO 90 + END IF + ELSE +* +* Random matrices +* + DO 80 JC = 1, N + DO 70 JR = 1, N + A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )* + $ DLARND( 2, ISEED ) + B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )* + $ DLARND( 2, ISEED ) + 70 CONTINUE + 80 CONTINUE + END IF +* + 90 CONTINUE +* + IF( IERR.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IERR, N, JTYPE, + $ IOLDSD + INFO = ABS( IERR ) + RETURN + END IF +* + 100 CONTINUE +* + DO 110 I = 1, 7 + RESULT( I ) = -ONE + 110 CONTINUE +* +* Call DGGEV3 to compute eigenvalues and eigenvectors. +* + CALL DLACPY( ' ', N, N, A, LDA, S, LDA ) + CALL DLACPY( ' ', N, N, B, LDA, T, LDA ) + CALL DGGEV3( 'V', 'V', N, S, LDA, T, LDA, ALPHAR, ALPHAI, + $ BETA, Q, LDQ, Z, LDQ, WORK, LWORK, IERR ) + IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN + RESULT( 1 ) = ULPINV + WRITE( NOUNIT, FMT = 9999 )'DGGEV31', IERR, N, JTYPE, + $ IOLDSD + INFO = ABS( IERR ) + GO TO 190 + END IF +* +* Do the tests (1) and (2) +* + CALL DGET52( .TRUE., N, A, LDA, B, LDA, Q, LDQ, ALPHAR, + $ ALPHAI, BETA, WORK, RESULT( 1 ) ) + IF( RESULT( 2 ).GT.THRESH ) THEN + WRITE( NOUNIT, FMT = 9998 )'Left', 'DGGEV31', + $ RESULT( 2 ), N, JTYPE, IOLDSD + END IF +* +* Do the tests (3) and (4) +* + CALL DGET52( .FALSE., N, A, LDA, B, LDA, Z, LDQ, ALPHAR, + $ ALPHAI, BETA, WORK, RESULT( 3 ) ) + IF( RESULT( 4 ).GT.THRESH ) THEN + WRITE( NOUNIT, FMT = 9998 )'Right', 'DGGEV31', + $ RESULT( 4 ), N, JTYPE, IOLDSD + END IF +* +* Do the test (5) +* + CALL DLACPY( ' ', N, N, A, LDA, S, LDA ) + CALL DLACPY( ' ', N, N, B, LDA, T, LDA ) + CALL DGGEV3( 'N', 'N', N, S, LDA, T, LDA, ALPHR1, ALPHI1, + $ BETA1, Q, LDQ, Z, LDQ, WORK, LWORK, IERR ) + IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN + RESULT( 1 ) = ULPINV + WRITE( NOUNIT, FMT = 9999 )'DGGEV32', IERR, N, JTYPE, + $ IOLDSD + INFO = ABS( IERR ) + GO TO 190 + END IF +* + DO 120 J = 1, N + IF( ALPHAR( J ).NE.ALPHR1( J ) .OR. ALPHAI( J ).NE. + $ ALPHI1( J ) .OR. BETA( J ).NE.BETA1( J ) )RESULT( 5 ) + $ = ULPINV + 120 CONTINUE +* +* Do the test (6): Compute eigenvalues and left eigenvectors, +* and test them +* + CALL DLACPY( ' ', N, N, A, LDA, S, LDA ) + CALL DLACPY( ' ', N, N, B, LDA, T, LDA ) + CALL DGGEV3( 'V', 'N', N, S, LDA, T, LDA, ALPHR1, ALPHI1, + $ BETA1, QE, LDQE, Z, LDQ, WORK, LWORK, IERR ) + IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN + RESULT( 1 ) = ULPINV + WRITE( NOUNIT, FMT = 9999 )'DGGEV33', IERR, N, JTYPE, + $ IOLDSD + INFO = ABS( IERR ) + GO TO 190 + END IF +* + DO 130 J = 1, N + IF( ALPHAR( J ).NE.ALPHR1( J ) .OR. ALPHAI( J ).NE. + $ ALPHI1( J ) .OR. BETA( J ).NE.BETA1( J ) )RESULT( 6 ) + $ = ULPINV + 130 CONTINUE +* + DO 150 J = 1, N + DO 140 JC = 1, N + IF( Q( J, JC ).NE.QE( J, JC ) ) + $ RESULT( 6 ) = ULPINV + 140 CONTINUE + 150 CONTINUE +* +* DO the test (7): Compute eigenvalues and right eigenvectors, +* and test them +* + CALL DLACPY( ' ', N, N, A, LDA, S, LDA ) + CALL DLACPY( ' ', N, N, B, LDA, T, LDA ) + CALL DGGEV3( 'N', 'V', N, S, LDA, T, LDA, ALPHR1, ALPHI1, + $ BETA1, Q, LDQ, QE, LDQE, WORK, LWORK, IERR ) + IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN + RESULT( 1 ) = ULPINV + WRITE( NOUNIT, FMT = 9999 )'DGGEV34', IERR, N, JTYPE, + $ IOLDSD + INFO = ABS( IERR ) + GO TO 190 + END IF +* + DO 160 J = 1, N + IF( ALPHAR( J ).NE.ALPHR1( J ) .OR. ALPHAI( J ).NE. + $ ALPHI1( J ) .OR. BETA( J ).NE.BETA1( J ) )RESULT( 7 ) + $ = ULPINV + 160 CONTINUE +* + DO 180 J = 1, N + DO 170 JC = 1, N + IF( Z( J, JC ).NE.QE( J, JC ) ) + $ RESULT( 7 ) = ULPINV + 170 CONTINUE + 180 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + 190 CONTINUE +* + NTESTT = NTESTT + 7 +* +* Print out tests which fail. +* + DO 200 JR = 1, 7 + IF( RESULT( JR ).GE.THRESH ) THEN +* +* If this is the first test to fail, +* print a header to the data file. +* + IF( NERRS.EQ.0 ) THEN + WRITE( NOUNIT, FMT = 9997 )'DGV' +* +* Matrix types +* + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 ) + WRITE( NOUNIT, FMT = 9994 )'Orthogonal' +* +* Tests performed +* + WRITE( NOUNIT, FMT = 9993 ) +* + END IF + NERRS = NERRS + 1 + IF( RESULT( JR ).LT.10000.0D0 ) THEN + WRITE( NOUNIT, FMT = 9992 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + ELSE + WRITE( NOUNIT, FMT = 9991 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + END IF + END IF + 200 CONTINUE +* + 210 CONTINUE + 220 CONTINUE +* +* Summary +* + CALL ALASVM( 'DGV', NOUNIT, NERRS, NTESTT, 0 ) +* + WORK( 1 ) = MAXWRK +* + RETURN +* + 9999 FORMAT( ' DDRGEV3: ', A, ' returned INFO=', I6, '.', / 3X, 'N=', + $ I6, ', JTYPE=', I6, ', ISEED=(', 4( I4, ',' ), I5, ')' ) +* + 9998 FORMAT( ' DDRGEV3: ', A, ' Eigenvectors from ', A, ' incorrectly ', + $ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 3X, + $ 'N=', I4, ', JTYPE=', I3, ', ISEED=(', 4( I4, ',' ), I5, + $ ')' ) +* + 9997 FORMAT( / 1X, A3, ' -- Real Generalized eigenvalue problem driver' + $ ) +* + 9996 FORMAT( ' Matrix types (see DDRGEV3 for details): ' ) +* + 9995 FORMAT( ' Special Matrices:', 23X, + $ '(J''=transposed Jordan block)', + $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ', + $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ', + $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I', + $ ') 11=(large*I, small*D) 13=(large*D, large*I)', / + $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ', + $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' ) + 9994 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:', + $ / ' 16=Transposed Jordan Blocks 19=geometric ', + $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ', + $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ', + $ 'alpha, beta=0,1 21=random alpha, beta=0,1', + $ / ' Large & Small Matrices:', / ' 22=(large, small) ', + $ '23=(small,large) 24=(small,small) 25=(large,large)', + $ / ' 26=random O(1) matrices.' ) +* + 9993 FORMAT( / ' Tests performed: ', + $ / ' 1 = max | ( b A - a B )''*l | / const.,', + $ / ' 2 = | |VR(i)| - 1 | / ulp,', + $ / ' 3 = max | ( b A - a B )*r | / const.', + $ / ' 4 = | |VL(i)| - 1 | / ulp,', + $ / ' 5 = 0 if W same no matter if r or l computed,', + $ / ' 6 = 0 if l same no matter if l computed,', + $ / ' 7 = 0 if r same no matter if r computed,', / 1X ) + 9992 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I2, ' is', 0P, F8.2 ) + 9991 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I2, ' is', 1P, D10.3 ) +* +* End of DDRGEV3 +* + END diff --git a/TESTING/EIG/derrgg.f b/TESTING/EIG/derrgg.f index 07e09a5..e43ce27 100644 --- a/TESTING/EIG/derrgg.f +++ b/TESTING/EIG/derrgg.f @@ -21,9 +21,10 @@ *> *> \verbatim *> -*> DERRGG tests the error exits for DGGES, DGGESX, DGGEV, DGGEVX, +*> DERRGG tests the error exits for DGGES, DGGESX, DGGEV, DGGEVX, *> DGGGLM, DGGHRD, DGGLSE, DGGQRF, DGGRQF, DGGSVD, DGGSVP, DHGEQZ, -*> DORCSD, DTGEVC, DTGEXC, DTGSEN, DTGSJA, DTGSNA, and DTGSYL. +*> DORCSD, DTGEVC, DTGEXC, DTGSEN, DTGSJA, DTGSNA, DGGES3, DGGEV3, +*> and DTGSYL. *> \endverbatim * * Arguments: @@ -97,7 +98,7 @@ EXTERNAL CHKXER, DGGES, DGGESX, DGGEV, DGGEVX, DGGGLM, $ DGGHRD, DGGLSE, DGGQRF, DGGRQF, DGGSVD, DGGSVP, $ DHGEQZ, DORCSD, DTGEVC, DTGEXC, DTGSEN, DTGSJA, - $ DTGSNA, DTGSYL + $ DTGSNA, DTGSYL, DGGHD3, DGGES3, DGGEV3 * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -170,6 +171,47 @@ CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK ) NT = NT + 9 * +* DGGHD3 +* + SRNAMT = 'DGGHD3' + INFOT = 1 + CALL DGGHD3( '/', 'N', 0, 1, 0, A, 1, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'DGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGGHD3( 'N', '/', 0, 1, 0, A, 1, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'DGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DGGHD3( 'N', 'N', -1, 0, 0, A, 1, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'DGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGGHD3( 'N', 'N', 0, 0, 0, A, 1, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'DGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGGHD3( 'N', 'N', 0, 1, 1, A, 1, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'DGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DGGHD3( 'N', 'N', 2, 1, 1, A, 1, B, 2, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'DGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DGGHD3( 'N', 'N', 2, 1, 1, A, 2, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'DGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DGGHD3( 'V', 'N', 2, 1, 1, A, 2, B, 2, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'DGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL DGGHD3( 'N', 'V', 2, 1, 1, A, 2, B, 2, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'DGGHD3', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * DHGEQZ * SRNAMT = 'DHGEQZ' @@ -662,6 +704,55 @@ CALL CHKXER( 'DGGES ', INFOT, NOUT, LERR, OK ) NT = NT + 11 * +* DGGES3 +* + SRNAMT = 'DGGES3 ' + INFOT = 1 + CALL DGGES3( '/', 'N', 'S', DLCTES, 1, A, 1, B, 1, SDIM, R1, + $ R2, R3, Q, 1, U, 1, W, 1, BW, INFO ) + CALL CHKXER( 'DGGES3 ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGGES3( 'N', '/', 'S', DLCTES, 1, A, 1, B, 1, SDIM, R1, + $ R2, R3, Q, 1, U, 1, W, 1, BW, INFO ) + CALL CHKXER( 'DGGES3 ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DGGES3( 'N', 'V', '/', DLCTES, 1, A, 1, B, 1, SDIM, R1, + $ R2, R3, Q, 1, U, 1, W, 1, BW, INFO ) + CALL CHKXER( 'DGGES3 ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGGES3( 'N', 'V', 'S', DLCTES, -1, A, 1, B, 1, SDIM, R1, + $ R2, R3, Q, 1, U, 1, W, 1, BW, INFO ) + CALL CHKXER( 'DGGES3 ', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DGGES3( 'N', 'V', 'S', DLCTES, 1, A, 0, B, 1, SDIM, R1, + $ R2, R3, Q, 1, U, 1, W, 1, BW, INFO ) + CALL CHKXER( 'DGGES3 ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DGGES3( 'N', 'V', 'S', DLCTES, 1, A, 1, B, 0, SDIM, R1, + $ R2, R3, Q, 1, U, 1, W, 1, BW, INFO ) + CALL CHKXER( 'DGGES3 ', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL DGGES3( 'N', 'V', 'S', DLCTES, 1, A, 1, B, 1, SDIM, R1, + $ R2, R3, Q, 0, U, 1, W, 1, BW, INFO ) + CALL CHKXER( 'DGGES3 ', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL DGGES3( 'V', 'V', 'S', DLCTES, 2, A, 2, B, 2, SDIM, R1, + $ R2, R3, Q, 1, U, 2, W, 1, BW, INFO ) + CALL CHKXER( 'DGGES3 ', INFOT, NOUT, LERR, OK ) + INFOT = 17 + CALL DGGES3( 'N', 'V', 'S', DLCTES, 1, A, 1, B, 1, SDIM, R1, + $ R2, R3, Q, 1, U, 0, W, 1, BW, INFO ) + CALL CHKXER( 'DGGES3 ', INFOT, NOUT, LERR, OK ) + INFOT = 17 + CALL DGGES3( 'V', 'V', 'S', DLCTES, 2, A, 2, B, 2, SDIM, R1, + $ R2, R3, Q, 2, U, 1, W, 1, BW, INFO ) + CALL CHKXER( 'DGGES3 ', INFOT, NOUT, LERR, OK ) + INFOT = 19 + CALL DGGES3( 'V', 'V', 'S', DLCTES, 2, A, 2, B, 2, SDIM, R1, + $ R2, R3, Q, 2, U, 2, W, 1, BW, INFO ) + CALL CHKXER( 'DGGES3 ', INFOT, NOUT, LERR, OK ) + NT = NT + 11 +* * DGGESX * SRNAMT = 'DGGESX' @@ -776,6 +867,51 @@ $ 1, INFO ) CALL CHKXER( 'DGGEV ', INFOT, NOUT, LERR, OK ) NT = NT + 10 +* +* DGGEV3 +* + SRNAMT = 'DGGEV3 ' + INFOT = 1 + CALL DGGEV3( '/', 'N', 1, A, 1, B, 1, R1, R2, R3, Q, 1, U, 1, + $ W, 1, INFO ) + CALL CHKXER( 'DGGEV3 ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGGEV3( 'N', '/', 1, A, 1, B, 1, R1, R2, R3, Q, 1, U, 1, + $ W, 1, INFO ) + CALL CHKXER( 'DGGEV3 ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DGGEV3( 'V', 'V', -1, A, 1, B, 1, R1, R2, R3, Q, 1, U, 1, + $ W, 1, INFO ) + CALL CHKXER( 'DGGEV3 ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGGEV3( 'V', 'V', 1, A, 0, B, 1, R1, R2, R3, Q, 1, U, 1, + $ W, 1, INFO ) + CALL CHKXER( 'DGGEV3 ', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DGGEV3( 'V', 'V', 1, A, 1, B, 0, R1, R2, R3, Q, 1, U, 1, + $ W, 1, INFO ) + CALL CHKXER( 'DGGEV3 ', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DGGEV3( 'N', 'V', 1, A, 1, B, 1, R1, R2, R3, Q, 0, U, 1, + $ W, 1, INFO ) + CALL CHKXER( 'DGGEV3 ', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DGGEV3( 'V', 'V', 2, A, 2, B, 2, R1, R2, R3, Q, 1, U, 2, + $ W, 1, INFO ) + CALL CHKXER( 'DGGEV3 ', INFOT, NOUT, LERR, OK ) + INFOT = 14 + CALL DGGEV3( 'V', 'N', 2, A, 2, B, 2, R1, R2, R3, Q, 2, U, 0, + $ W, 1, INFO ) + CALL CHKXER( 'DGGEV3 ', INFOT, NOUT, LERR, OK ) + INFOT = 14 + CALL DGGEV3( 'V', 'V', 2, A, 2, B, 2, R1, R2, R3, Q, 2, U, 1, + $ W, 1, INFO ) + CALL CHKXER( 'DGGEV3 ', INFOT, NOUT, LERR, OK ) + INFOT = 16 + CALL DGGEV3( 'V', 'V', 1, A, 1, B, 1, R1, R2, R3, Q, 1, U, 1, + $ W, 1, INFO ) + CALL CHKXER( 'DGGEV3 ', INFOT, NOUT, LERR, OK ) + NT = NT + 10 * * DGGEVX * diff --git a/TESTING/EIG/schkee.f b/TESTING/EIG/schkee.f index 5b6a9ba..d323d20 100644 --- a/TESTING/EIG/schkee.f +++ b/TESTING/EIG/schkee.f @@ -44,7 +44,7 @@ *> Test SGEESX *> *> SGG (Generalized Nonsymmetric Eigenvalue Problem): -*> Test SGGHRD, SGGBAL, SGGBAK, SHGEQZ, and STGEVC +*> Test SGGHD3, SGGBAL, SGGBAK, SHGEQZ, and STGEVC *> and the driver routines SGEGS and SGEGV *> *> SGS (Generalized Nonsymmetric Schur form Driver): @@ -493,38 +493,41 @@ *> line 8: MXBVAL, INTEGER array, dimension (NPARMS) *> The values for MAXB, used in determining minimum blocksize. *> -*> line 9: NBCOL, INTEGER array, dimension (NPARMS) +*> line 9: IACC22, INTEGER array, dimension (NPARMS) +*> select structured matrix multiply: 1 or 2) +*> +*> line 10: NBCOL, INTEGER array, dimension (NPARMS) *> The values for NBCOL, the minimum column dimension for *> blocks. *> -*> line 10: THRESH +*> line 11: THRESH *> Threshold value for the test ratios. Information will be *> printed about each test for which the test ratio is greater *> than or equal to the threshold. *> -*> line 11: TSTCHK, LOGICAL +*> line 12: TSTCHK, LOGICAL *> Flag indicating whether or not to test the LAPACK routines. *> -*> line 12: TSTDRV, LOGICAL +*> line 13: TSTDRV, LOGICAL *> Flag indicating whether or not to test the driver routines. *> -*> line 13: TSTERR, LOGICAL +*> line 14: TSTERR, LOGICAL *> Flag indicating whether or not to test the error exits for *> the LAPACK routines and driver routines. *> -*> line 14: NEWSD, INTEGER +*> line 15: NEWSD, INTEGER *> A code indicating how to set the random number seed. *> = 0: Set the seed to a default value before each run *> = 1: Initialize the seed to a default value only before the *> first run *> = 2: Like 1, but use the seed values on the next line *> -*> If line 14 was 2: +*> If line 15 was 2: *> -*> line 15: INTEGER array, dimension (4) +*> line 16: INTEGER array, dimension (4) *> Four integer values for the random number seed. *> -*> lines 15-EOF: Lines specifying matrix types, as for NEP. +*> lines 17-EOF: Lines specifying matrix types, as for NEP. *> The 3-character path name is 'SGG' for the generalized *> eigenvalue problem routines and driver routines. *> @@ -1104,7 +1107,8 @@ $ SCKCSD, SCKGLM, SCKGQR, SCKGSV, SCKLSE, SDRGES, $ SDRGEV, SDRGSX, SDRGVX, SDRVBD, SDRVES, SDRVEV, $ SDRVGG, SDRVSG, SDRVST, SDRVSX, SDRVVX, SERRBD, - $ SERRED, SERRGG, SERRHS, SERRST, ILAVER, XLAENV + $ SERRED, SERRGG, SERRHS, SERRST, ILAVER, XLAENV, + $ SDRGES3, SDRGEV3 * .. * .. Intrinsic Functions .. INTRINSIC LEN, MIN @@ -1630,7 +1634,7 @@ * * Read the values for IACC22. * - IF( NEP ) THEN + IF( NEP .OR. SGG ) THEN READ( NIN, FMT = * )( IACC22( I ), I = 1, NPARMS ) DO 620 I = 1, NPARMS IF( IACC22( I ).LT.0 ) THEN @@ -2097,6 +2101,7 @@ * NBMIN = minimum block size * NS = number of shifts * MAXB = minimum submatrix size +* IACC22: structured matrix multiply * NBCOL = minimum column dimension for blocks * MAXTYP = 26 @@ -2109,6 +2114,7 @@ CALL XLAENV( 2, NBMIN( I ) ) CALL XLAENV( 4, NSVAL( I ) ) CALL XLAENV( 8, MXBVAL( I ) ) + CALL XLAENV( 16, IACC22( I ) ) CALL XLAENV( 5, NBCOL( I ) ) * IF( NEWSD.EQ.0 ) THEN @@ -2117,7 +2123,7 @@ 340 CONTINUE END IF WRITE( NOUT, FMT = 9996 )C3, NBVAL( I ), NBMIN( I ), - $ NSVAL( I ), MXBVAL( I ), NBCOL( I ) + $ NSVAL( I ), MXBVAL( I ), IACC22( I ), NBCOL( I ) TSTDIF = .FALSE. THRSHN = 10. IF( TSTCHK ) THEN @@ -2170,6 +2176,17 @@ * IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'SDRGES', INFO +* +* Blocked version +* + CALL SDRGES3( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT, + $ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ), + $ A( 1, 4 ), A( 1, 7 ), NMAX, A( 1, 8 ), + $ D( 1, 1 ), D( 1, 2 ), D( 1, 3 ), WORK, LWORK, + $ RESULT, LOGWRK, INFO ) +* + IF( INFO.NE.0 ) + $ WRITE( NOUT, FMT = 9980 )'SDRGES3', INFO END IF WRITE( NOUT, FMT = 9973 ) GO TO 10 @@ -2224,6 +2241,17 @@ $ WORK, LWORK, RESULT, INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'SDRGEV', INFO +* +* Blocked version +* + CALL SDRGEV3( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT, + $ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ), + $ A( 1, 4 ), A( 1, 7 ), NMAX, A( 1, 8 ), + $ A( 1, 9 ), NMAX, D( 1, 1 ), D( 1, 2 ), + $ D( 1, 3 ), D( 1, 4 ), D( 1, 5 ), D( 1, 6 ), + $ WORK, LWORK, RESULT, INFO ) + IF( INFO.NE.0 ) + $ WRITE( NOUT, FMT = 9980 )'SDRGEV3', INFO END IF WRITE( NOUT, FMT = 9973 ) GO TO 10 @@ -2395,7 +2423,7 @@ 9999 FORMAT( / ' Execution not attempted due to input errors' ) 9997 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4 ) 9996 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NS =', I4, - $ ', MAXB =', I4, ', NBCOL =', I4 ) + $ ', MAXB =', I4, ', IACC22 =', I4, ', NBCOL =', I4 ) 9995 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4, $ ', NRHS =', I4 ) 9994 FORMAT( / / ' End of tests' ) diff --git a/TESTING/EIG/sdrges3.f b/TESTING/EIG/sdrges3.f new file mode 100644 index 0000000..6fed3c8 --- /dev/null +++ b/TESTING/EIG/sdrges3.f @@ -0,0 +1,997 @@ +*> \brief \b SDRGES3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SDRGES3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, ALPHAR, +* ALPHAI, BETA, WORK, LWORK, RESULT, BWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL BWORK( * ), DOTYPE( * ) +* INTEGER ISEED( 4 ), NN( * ) +* REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ), +* $ B( LDA, * ), BETA( * ), Q( LDQ, * ), +* $ RESULT( 13 ), S( LDA, * ), T( LDA, * ), +* $ WORK( * ), Z( LDQ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SDRGES3 checks the nonsymmetric generalized eigenvalue (Schur form) +*> problem driver SGGES3. +*> +*> SGGES3 factors A and B as Q S Z' and Q T Z' , where ' means +*> transpose, T is upper triangular, S is in generalized Schur form +*> (block upper triangular, with 1x1 and 2x2 blocks on the diagonal, +*> the 2x2 blocks corresponding to complex conjugate pairs of +*> generalized eigenvalues), and Q and Z are orthogonal. It also +*> computes the generalized eigenvalues (alpha(j),beta(j)), j=1,...,n, +*> Thus, w(j) = alpha(j)/beta(j) is a root of the characteristic +*> equation +*> det( A - w(j) B ) = 0 +*> Optionally it also reorder the eigenvalues so that a selected +*> cluster of eigenvalues appears in the leading diagonal block of the +*> Schur forms. +*> +*> When SDRGES3 is called, a number of matrix "sizes" ("N's") and a +*> number of matrix "TYPES" are specified. For each size ("N") +*> and each TYPE of matrix, a pair of matrices (A, B) will be generated +*> and used for testing. For each matrix pair, the following 13 tests +*> will be performed and compared with the threshhold THRESH except +*> the tests (5), (11) and (13). +*> +*> +*> (1) | A - Q S Z' | / ( |A| n ulp ) (no sorting of eigenvalues) +*> +*> +*> (2) | B - Q T Z' | / ( |B| n ulp ) (no sorting of eigenvalues) +*> +*> +*> (3) | I - QQ' | / ( n ulp ) (no sorting of eigenvalues) +*> +*> +*> (4) | I - ZZ' | / ( n ulp ) (no sorting of eigenvalues) +*> +*> (5) if A is in Schur form (i.e. quasi-triangular form) +*> (no sorting of eigenvalues) +*> +*> (6) if eigenvalues = diagonal blocks of the Schur form (S, T), +*> i.e., test the maximum over j of D(j) where: +*> +*> if alpha(j) is real: +*> |alpha(j) - S(j,j)| |beta(j) - T(j,j)| +*> D(j) = ------------------------ + ----------------------- +*> max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) +*> +*> if alpha(j) is complex: +*> | det( s S - w T ) | +*> D(j) = --------------------------------------------------- +*> ulp max( s norm(S), |w| norm(T) )*norm( s S - w T ) +*> +*> and S and T are here the 2 x 2 diagonal blocks of S and T +*> corresponding to the j-th and j+1-th eigenvalues. +*> (no sorting of eigenvalues) +*> +*> (7) | (A,B) - Q (S,T) Z' | / ( | (A,B) | n ulp ) +*> (with sorting of eigenvalues). +*> +*> (8) | I - QQ' | / ( n ulp ) (with sorting of eigenvalues). +*> +*> (9) | I - ZZ' | / ( n ulp ) (with sorting of eigenvalues). +*> +*> (10) if A is in Schur form (i.e. quasi-triangular form) +*> (with sorting of eigenvalues). +*> +*> (11) if eigenvalues = diagonal blocks of the Schur form (S, T), +*> i.e. test the maximum over j of D(j) where: +*> +*> if alpha(j) is real: +*> |alpha(j) - S(j,j)| |beta(j) - T(j,j)| +*> D(j) = ------------------------ + ----------------------- +*> max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) +*> +*> if alpha(j) is complex: +*> | det( s S - w T ) | +*> D(j) = --------------------------------------------------- +*> ulp max( s norm(S), |w| norm(T) )*norm( s S - w T ) +*> +*> and S and T are here the 2 x 2 diagonal blocks of S and T +*> corresponding to the j-th and j+1-th eigenvalues. +*> (with sorting of eigenvalues). +*> +*> (12) if sorting worked and SDIM is the number of eigenvalues +*> which were SELECTed. +*> +*> Test Matrices +*> ============= +*> +*> The sizes of the test matrices are specified by an array +*> NN(1:NSIZES); the value of each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if +*> DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) ( 0, 0 ) (a pair of zero matrices) +*> +*> (2) ( I, 0 ) (an identity and a zero matrix) +*> +*> (3) ( 0, I ) (an identity and a zero matrix) +*> +*> (4) ( I, I ) (a pair of identity matrices) +*> +*> t t +*> (5) ( J , J ) (a pair of transposed Jordan blocks) +*> +*> t ( I 0 ) +*> (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) +*> ( 0 I ) ( 0 J ) +*> and I is a k x k identity and J a (k+1)x(k+1) +*> Jordan block; k=(N-1)/2 +*> +*> (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal +*> matrix with those diagonal entries.) +*> (8) ( I, D ) +*> +*> (9) ( big*D, small*I ) where "big" is near overflow and small=1/big +*> +*> (10) ( small*D, big*I ) +*> +*> (11) ( big*I, small*D ) +*> +*> (12) ( small*I, big*D ) +*> +*> (13) ( big*D, big*I ) +*> +*> (14) ( small*D, small*I ) +*> +*> (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and +*> D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) +*> t t +*> (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. +*> +*> (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices +*> with random O(1) entries above the diagonal +*> and diagonal entries diag(T1) = +*> ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = +*> ( 0, N-3, N-4,..., 1, 0, 0 ) +*> +*> (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) +*> s = machine precision. +*> +*> (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) +*> +*> N-5 +*> (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) +*> +*> (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) +*> where r1,..., r(N-4) are random. +*> +*> (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular +*> matrices. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> SDRGES3 does nothing. NSIZES >= 0. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. NN >= 0. +*> \endverbatim +*> +*> \param[in] NTYPES +*> \verbatim +*> NTYPES is INTEGER +*> The number of elements in DOTYPE. If it is zero, SDRGES3 +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A on input. +*> This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> \endverbatim +*> +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> \endverbatim +*> +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to SDRGES3 to continue the same random number +*> sequence. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is REAL +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error is +*> scaled to be O(1), so THRESH should be a reasonably small +*> multiple of 1, e.g., 10 or 100. In particular, it should +*> not depend on the precision (single vs. double) or the size +*> of the matrix. THRESH >= 0. +*> \endverbatim +*> +*> \param[in] NOUNIT +*> \verbatim +*> NOUNIT is INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, +*> dimension(LDA, max(NN)) +*> Used to hold the original A matrix. Used as input only +*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and +*> DOTYPE(MAXTYP+1)=.TRUE. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A, B, S, and T. +*> It must be at least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, +*> dimension(LDA, max(NN)) +*> Used to hold the original B matrix. Used as input only +*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and +*> DOTYPE(MAXTYP+1)=.TRUE. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is REAL array, dimension (LDA, max(NN)) +*> The Schur form matrix computed from A by SGGES3. On exit, S +*> contains the Schur form matrix corresponding to the matrix +*> in A. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is REAL array, dimension (LDA, max(NN)) +*> The upper triangular matrix computed from B by SGGES3. +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is REAL array, dimension (LDQ, max(NN)) +*> The (left) orthogonal matrix computed by SGGES3. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of Q and Z. It must +*> be at least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is REAL array, dimension( LDQ, max(NN) ) +*> The (right) orthogonal matrix computed by SGGES3. +*> \endverbatim +*> +*> \param[out] ALPHAR +*> \verbatim +*> ALPHAR is REAL array, dimension (max(NN)) +*> \endverbatim +*> +*> \param[out] ALPHAI +*> \verbatim +*> ALPHAI is REAL array, dimension (max(NN)) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is REAL array, dimension (max(NN)) +*> +*> The generalized eigenvalues of (A,B) computed by SGGES3. +*> ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th +*> generalized eigenvalue of A and B. +*> \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 >= MAX( 10*(N+1), 3*N*N ), where N is the largest +*> matrix dimension. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (15) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid overflow. +*> \endverbatim +*> +*> \param[out] BWORK +*> \verbatim +*> BWORK is LOGICAL 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: A routine returned an error code. INFO is the +*> absolute value of the INFO value returned. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date February 2015 +* +*> \ingroup single_eig +* +* ===================================================================== + SUBROUTINE SDRGES3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, ALPHAR, + $ ALPHAI, BETA, WORK, LWORK, RESULT, BWORK, + $ INFO ) +* +* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* February 2015 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL BWORK( * ), DOTYPE( * ) + INTEGER ISEED( 4 ), NN( * ) + REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ), + $ B( LDA, * ), BETA( * ), Q( LDQ, * ), + $ RESULT( 13 ), S( LDA, * ), T( LDA, * ), + $ WORK( * ), Z( LDQ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 26 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN, ILABAD + CHARACTER SORT + INTEGER I, I1, IADD, IERR, IINFO, IN, ISORT, J, JC, JR, + $ JSIZE, JTYPE, KNTEIG, MAXWRK, MINWRK, MTYPES, + $ N, N1, NB, NERRS, NMATS, NMAX, NTEST, NTESTT, + $ RSUB, SDIM + REAL SAFMAX, SAFMIN, TEMP1, TEMP2, ULP, ULPINV +* .. +* .. Local Arrays .. + INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ), + $ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ), + $ KATYPE( MAXTYP ), KAZERO( MAXTYP ), + $ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ), + $ KBZERO( MAXTYP ), KCLASS( MAXTYP ), + $ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 ) + REAL RMAGN( 0: 3 ) +* .. +* .. External Functions .. + LOGICAL SLCTES + INTEGER ILAENV + REAL SLAMCH, SLARND + EXTERNAL SLCTES, ILAENV, SLAMCH, SLARND +* .. +* .. External Subroutines .. + EXTERNAL ALASVM, SGET51, SGET53, SGET54, SGGES3, SLABAD, + $ SLACPY, SLARFG, SLASET, SLATM4, SORM2R, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, REAL, SIGN +* .. +* .. Data statements .. + DATA KCLASS / 15*1, 10*2, 1*3 / + DATA KZ1 / 0, 1, 2, 1, 3, 3 / + DATA KZ2 / 0, 0, 1, 2, 1, 1 / + DATA KADD / 0, 0, 0, 0, 3, 2 / + DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4, + $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 / + DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4, + $ 1, 1, -4, 2, -4, 8*8, 0 / + DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3, + $ 4*5, 4*3, 1 / + DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4, + $ 4*6, 4*4, 1 / + DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3, + $ 2, 1 / + DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3, + $ 2, 1 / + DATA KTRIAN / 16*0, 10*1 / + DATA IASIGN / 6*0, 2, 0, 2*2, 2*0, 3*2, 0, 2, 3*0, + $ 5*2, 0 / + DATA IBSIGN / 7*0, 2, 2*0, 2*2, 2*0, 2, 0, 2, 9*0 / +* .. +* .. Executable Statements .. +* +* Check for errors +* + INFO = 0 +* + BADNN = .FALSE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( THRESH.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDQ.LE.1 .OR. LDQ.LT.NMAX ) THEN + INFO = -14 + END IF +* +* Compute workspace +* (Note: Comments in the code beginning "Workspace:" describe the +* minimal amount of workspace needed at that point in the code, +* as well as the preferred amount for good performance. +* NB refers to the optimal block size for the immediately +* following subroutine, as returned by ILAENV. +* + MINWRK = 1 + IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN + MINWRK = MAX( 10*( NMAX+1 ), 3*NMAX*NMAX ) + NB = MAX( 1, ILAENV( 1, 'SGEQRF', ' ', NMAX, NMAX, -1, -1 ), + $ ILAENV( 1, 'SORMQR', 'LT', NMAX, NMAX, NMAX, -1 ), + $ ILAENV( 1, 'SORGQR', ' ', NMAX, NMAX, NMAX, -1 ) ) + MAXWRK = MAX( 10*( NMAX+1 ), 2*NMAX+NMAX*NB, 3*NMAX*NMAX ) + WORK( 1 ) = MAXWRK + END IF +* + IF( LWORK.LT.MINWRK ) + $ INFO = -20 +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SDRGES3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* + SAFMIN = SLAMCH( 'Safe minimum' ) + ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) + SAFMIN = SAFMIN / ULP + SAFMAX = ONE / SAFMIN + CALL SLABAD( SAFMIN, SAFMAX ) + ULPINV = ONE / ULP +* +* The values RMAGN(2:3) depend on N, see below. +* + RMAGN( 0 ) = ZERO + RMAGN( 1 ) = ONE +* +* Loop over matrix sizes +* + NTESTT = 0 + NERRS = 0 + NMATS = 0 +* + DO 190 JSIZE = 1, NSIZES + N = NN( JSIZE ) + N1 = MAX( 1, N ) + RMAGN( 2 ) = SAFMAX*ULP / REAL( N1 ) + RMAGN( 3 ) = SAFMIN*ULPINV*REAL( N1 ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* +* Loop over matrix types +* + DO 180 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 180 + NMATS = NMATS + 1 + NTEST = 0 +* +* Save ISEED in case of an error. +* + DO 20 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 20 CONTINUE +* +* Initialize RESULT +* + DO 30 J = 1, 13 + RESULT( J ) = ZERO + 30 CONTINUE +* +* Generate test matrices A and B +* +* Description of control parameters: +* +* KCLASS: =1 means w/o rotation, =2 means w/ rotation, +* =3 means random. +* KATYPE: the "type" to be passed to SLATM4 for computing A. +* KAZERO: the pattern of zeros on the diagonal for A: +* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), +* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), +* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of +* non-zero entries.) +* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), +* =2: large, =3: small. +* IASIGN: 1 if the diagonal elements of A are to be +* multiplied by a random magnitude 1 number, =2 if +* randomly chosen diagonal blocks are to be rotated +* to form 2x2 blocks. +* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B. +* KTRIAN: =0: don't fill in the upper triangle, =1: do. +* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. +* RMAGN: used to implement KAMAGN and KBMAGN. +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 110 + IINFO = 0 + IF( KCLASS( JTYPE ).LT.3 ) THEN +* +* Generate A (w/o rotation) +* + IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN + IN = 2*( ( N-1 ) / 2 ) + 1 + IF( IN.NE.N ) + $ CALL SLASET( 'Full', N, N, ZERO, ZERO, A, LDA ) + ELSE + IN = N + END IF + CALL SLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ), + $ KZ2( KAZERO( JTYPE ) ), IASIGN( JTYPE ), + $ RMAGN( KAMAGN( JTYPE ) ), ULP, + $ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2, + $ ISEED, A, LDA ) + IADD = KADD( KAZERO( JTYPE ) ) + IF( IADD.GT.0 .AND. IADD.LE.N ) + $ A( IADD, IADD ) = ONE +* +* Generate B (w/o rotation) +* + IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN + IN = 2*( ( N-1 ) / 2 ) + 1 + IF( IN.NE.N ) + $ CALL SLASET( 'Full', N, N, ZERO, ZERO, B, LDA ) + ELSE + IN = N + END IF + CALL SLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ), + $ KZ2( KBZERO( JTYPE ) ), IBSIGN( JTYPE ), + $ RMAGN( KBMAGN( JTYPE ) ), ONE, + $ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2, + $ ISEED, B, LDA ) + IADD = KADD( KBZERO( JTYPE ) ) + IF( IADD.NE.0 .AND. IADD.LE.N ) + $ B( IADD, IADD ) = ONE +* + IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN +* +* Include rotations +* +* Generate Q, Z as Householder transformations times +* a diagonal matrix. +* + DO 50 JC = 1, N - 1 + DO 40 JR = JC, N + Q( JR, JC ) = SLARND( 3, ISEED ) + Z( JR, JC ) = SLARND( 3, ISEED ) + 40 CONTINUE + CALL SLARFG( N+1-JC, Q( JC, JC ), Q( JC+1, JC ), 1, + $ WORK( JC ) ) + WORK( 2*N+JC ) = SIGN( ONE, Q( JC, JC ) ) + Q( JC, JC ) = ONE + CALL SLARFG( N+1-JC, Z( JC, JC ), Z( JC+1, JC ), 1, + $ WORK( N+JC ) ) + WORK( 3*N+JC ) = SIGN( ONE, Z( JC, JC ) ) + Z( JC, JC ) = ONE + 50 CONTINUE + Q( N, N ) = ONE + WORK( N ) = ZERO + WORK( 3*N ) = SIGN( ONE, SLARND( 2, ISEED ) ) + Z( N, N ) = ONE + WORK( 2*N ) = ZERO + WORK( 4*N ) = SIGN( ONE, SLARND( 2, ISEED ) ) +* +* Apply the diagonal matrices +* + DO 70 JC = 1, N + DO 60 JR = 1, N + A( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )* + $ A( JR, JC ) + B( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )* + $ B( JR, JC ) + 60 CONTINUE + 70 CONTINUE + CALL SORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, A, + $ LDA, WORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) + $ GO TO 100 + CALL SORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ), + $ A, LDA, WORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) + $ GO TO 100 + CALL SORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, B, + $ LDA, WORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) + $ GO TO 100 + CALL SORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ), + $ B, LDA, WORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) + $ GO TO 100 + END IF + ELSE +* +* Random matrices +* + DO 90 JC = 1, N + DO 80 JR = 1, N + A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )* + $ SLARND( 2, ISEED ) + B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )* + $ SLARND( 2, ISEED ) + 80 CONTINUE + 90 CONTINUE + END IF +* + 100 CONTINUE +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 110 CONTINUE +* + DO 120 I = 1, 13 + RESULT( I ) = -ONE + 120 CONTINUE +* +* Test with and without sorting of eigenvalues +* + DO 150 ISORT = 0, 1 + IF( ISORT.EQ.0 ) THEN + SORT = 'N' + RSUB = 0 + ELSE + SORT = 'S' + RSUB = 5 + END IF +* +* Call SGGES3 to compute H, T, Q, Z, alpha, and beta. +* + CALL SLACPY( 'Full', N, N, A, LDA, S, LDA ) + CALL SLACPY( 'Full', N, N, B, LDA, T, LDA ) + NTEST = 1 + RSUB + ISORT + RESULT( 1+RSUB+ISORT ) = ULPINV + CALL SGGES3( 'V', 'V', SORT, SLCTES, N, S, LDA, T, LDA, + $ SDIM, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDQ, + $ WORK, LWORK, BWORK, IINFO ) + IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN + RESULT( 1+RSUB+ISORT ) = ULPINV + WRITE( NOUNIT, FMT = 9999 )'SGGES3', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + GO TO 160 + END IF +* + NTEST = 4 + RSUB +* +* Do tests 1--4 (or tests 7--9 when reordering ) +* + IF( ISORT.EQ.0 ) THEN + CALL SGET51( 1, N, A, LDA, S, LDA, Q, LDQ, Z, LDQ, + $ WORK, RESULT( 1 ) ) + CALL SGET51( 1, N, B, LDA, T, LDA, Q, LDQ, Z, LDQ, + $ WORK, RESULT( 2 ) ) + ELSE + CALL SGET54( N, A, LDA, B, LDA, S, LDA, T, LDA, Q, + $ LDQ, Z, LDQ, WORK, RESULT( 7 ) ) + END IF + CALL SGET51( 3, N, A, LDA, T, LDA, Q, LDQ, Q, LDQ, WORK, + $ RESULT( 3+RSUB ) ) + CALL SGET51( 3, N, B, LDA, T, LDA, Z, LDQ, Z, LDQ, WORK, + $ RESULT( 4+RSUB ) ) +* +* Do test 5 and 6 (or Tests 10 and 11 when reordering): +* check Schur form of A and compare eigenvalues with +* diagonals. +* + NTEST = 6 + RSUB + TEMP1 = ZERO +* + DO 130 J = 1, N + ILABAD = .FALSE. + IF( ALPHAI( J ).EQ.ZERO ) THEN + TEMP2 = ( ABS( ALPHAR( J )-S( J, J ) ) / + $ MAX( SAFMIN, ABS( ALPHAR( J ) ), ABS( S( J, + $ J ) ) )+ABS( BETA( J )-T( J, J ) ) / + $ MAX( SAFMIN, ABS( BETA( J ) ), ABS( T( J, + $ J ) ) ) ) / ULP +* + IF( J.LT.N ) THEN + IF( S( J+1, J ).NE.ZERO ) THEN + ILABAD = .TRUE. + RESULT( 5+RSUB ) = ULPINV + END IF + END IF + IF( J.GT.1 ) THEN + IF( S( J, J-1 ).NE.ZERO ) THEN + ILABAD = .TRUE. + RESULT( 5+RSUB ) = ULPINV + END IF + END IF +* + ELSE + IF( ALPHAI( J ).GT.ZERO ) THEN + I1 = J + ELSE + I1 = J - 1 + END IF + IF( I1.LE.0 .OR. I1.GE.N ) THEN + ILABAD = .TRUE. + ELSE IF( I1.LT.N-1 ) THEN + IF( S( I1+2, I1+1 ).NE.ZERO ) THEN + ILABAD = .TRUE. + RESULT( 5+RSUB ) = ULPINV + END IF + ELSE IF( I1.GT.1 ) THEN + IF( S( I1, I1-1 ).NE.ZERO ) THEN + ILABAD = .TRUE. + RESULT( 5+RSUB ) = ULPINV + END IF + END IF + IF( .NOT.ILABAD ) THEN + CALL SGET53( S( I1, I1 ), LDA, T( I1, I1 ), LDA, + $ BETA( J ), ALPHAR( J ), + $ ALPHAI( J ), TEMP2, IERR ) + IF( IERR.GE.3 ) THEN + WRITE( NOUNIT, FMT = 9998 )IERR, J, N, + $ JTYPE, IOLDSD + INFO = ABS( IERR ) + END IF + ELSE + TEMP2 = ULPINV + END IF +* + END IF + TEMP1 = MAX( TEMP1, TEMP2 ) + IF( ILABAD ) THEN + WRITE( NOUNIT, FMT = 9997 )J, N, JTYPE, IOLDSD + END IF + 130 CONTINUE + RESULT( 6+RSUB ) = TEMP1 +* + IF( ISORT.GE.1 ) THEN +* +* Do test 12 +* + NTEST = 12 + RESULT( 12 ) = ZERO + KNTEIG = 0 + DO 140 I = 1, N + IF( SLCTES( ALPHAR( I ), ALPHAI( I ), + $ BETA( I ) ) .OR. SLCTES( ALPHAR( I ), + $ -ALPHAI( I ), BETA( I ) ) ) THEN + KNTEIG = KNTEIG + 1 + END IF + IF( I.LT.N ) THEN + IF( ( SLCTES( ALPHAR( I+1 ), ALPHAI( I+1 ), + $ BETA( I+1 ) ) .OR. SLCTES( ALPHAR( I+1 ), + $ -ALPHAI( I+1 ), BETA( I+1 ) ) ) .AND. + $ ( .NOT.( SLCTES( ALPHAR( I ), ALPHAI( I ), + $ BETA( I ) ) .OR. SLCTES( ALPHAR( I ), + $ -ALPHAI( I ), BETA( I ) ) ) ) .AND. + $ IINFO.NE.N+2 ) THEN + RESULT( 12 ) = ULPINV + END IF + END IF + 140 CONTINUE + IF( SDIM.NE.KNTEIG ) THEN + RESULT( 12 ) = ULPINV + END IF + END IF +* + 150 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + 160 CONTINUE +* + NTESTT = NTESTT + NTEST +* +* Print out tests which fail. +* + DO 170 JR = 1, NTEST + IF( RESULT( JR ).GE.THRESH ) THEN +* +* If this is the first test to fail, +* print a header to the data file. +* + IF( NERRS.EQ.0 ) THEN + WRITE( NOUNIT, FMT = 9996 )'SGS' +* +* Matrix types +* + WRITE( NOUNIT, FMT = 9995 ) + WRITE( NOUNIT, FMT = 9994 ) + WRITE( NOUNIT, FMT = 9993 )'Orthogonal' +* +* Tests performed +* + WRITE( NOUNIT, FMT = 9992 )'orthogonal', '''', + $ 'transpose', ( '''', J = 1, 8 ) +* + END IF + NERRS = NERRS + 1 + IF( RESULT( JR ).LT.10000.0 ) THEN + WRITE( NOUNIT, FMT = 9991 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + ELSE + WRITE( NOUNIT, FMT = 9990 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + END IF + END IF + 170 CONTINUE +* + 180 CONTINUE + 190 CONTINUE +* +* Summary +* + CALL ALASVM( 'SGS', NOUNIT, NERRS, NTESTT, 0 ) +* + WORK( 1 ) = MAXWRK +* + RETURN +* + 9999 FORMAT( ' SDRGES3: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', + $ I6, ', JTYPE=', I6, ', ISEED=(', 4( I4, ',' ), I5, ')' ) +* + 9998 FORMAT( ' SDRGES3: SGET53 returned INFO=', I1, ' for eigenvalue ', + $ I6, '.', / 9X, 'N=', I6, ', JTYPE=', I6, ', ISEED=(', + $ 4( I4, ',' ), I5, ')' ) +* + 9997 FORMAT( ' SDRGES3: S not in Schur form at eigenvalue ', I6, '.', + $ / 9X, 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), + $ I5, ')' ) +* + 9996 FORMAT( / 1X, A3, ' -- Real Generalized Schur form driver' ) +* + 9995 FORMAT( ' Matrix types (see SDRGES3 for details): ' ) +* + 9994 FORMAT( ' Special Matrices:', 23X, + $ '(J''=transposed Jordan block)', + $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ', + $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ', + $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I', + $ ') 11=(large*I, small*D) 13=(large*D, large*I)', / + $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ', + $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' ) + 9993 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:', + $ / ' 16=Transposed Jordan Blocks 19=geometric ', + $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ', + $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ', + $ 'alpha, beta=0,1 21=random alpha, beta=0,1', + $ / ' Large & Small Matrices:', / ' 22=(large, small) ', + $ '23=(small,large) 24=(small,small) 25=(large,large)', + $ / ' 26=random O(1) matrices.' ) +* + 9992 FORMAT( / ' Tests performed: (S is Schur, T is triangular, ', + $ 'Q and Z are ', A, ',', / 19X, + $ 'l and r are the appropriate left and right', / 19X, + $ 'eigenvectors, resp., a is alpha, b is beta, and', / 19X, A, + $ ' means ', A, '.)', / ' Without ordering: ', + $ / ' 1 = | A - Q S Z', A, + $ ' | / ( |A| n ulp ) 2 = | B - Q T Z', A, + $ ' | / ( |B| n ulp )', / ' 3 = | I - QQ', A, + $ ' | / ( n ulp ) 4 = | I - ZZ', A, + $ ' | / ( n ulp )', / ' 5 = A is in Schur form S', + $ / ' 6 = difference between (alpha,beta)', + $ ' and diagonals of (S,T)', / ' With ordering: ', + $ / ' 7 = | (A,B) - Q (S,T) Z', A, + $ ' | / ( |(A,B)| n ulp ) ', / ' 8 = | I - QQ', A, + $ ' | / ( n ulp ) 9 = | I - ZZ', A, + $ ' | / ( n ulp )', / ' 10 = A is in Schur form S', + $ / ' 11 = difference between (alpha,beta) and diagonals', + $ ' of (S,T)', / ' 12 = SDIM is the correct number of ', + $ 'selected eigenvalues', / ) + 9991 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I2, ' is', 0P, F8.2 ) + 9990 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I2, ' is', 1P, E10.3 ) +* +* End of SDRGES3 +* + END diff --git a/TESTING/EIG/sdrgev3.f b/TESTING/EIG/sdrgev3.f new file mode 100644 index 0000000..29adafb --- /dev/null +++ b/TESTING/EIG/sdrgev3.f @@ -0,0 +1,941 @@ +*> \brief \b SDRGEV3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SDRGEV3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, QE, LDQE, +* ALPHAR, ALPHAI, BETA, ALPHR1, ALPHI1, BETA1, +* WORK, LWORK, RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDQ, LDQE, LWORK, NOUNIT, NSIZES, +* $ NTYPES +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), NN( * ) +* REAL A( LDA, * ), ALPHAI( * ), ALPHI1( * ), +* $ ALPHAR( * ), ALPHR1( * ), B( LDA, * ), +* $ BETA( * ), BETA1( * ), Q( LDQ, * ), +* $ QE( LDQE, * ), RESULT( * ), S( LDA, * ), +* $ T( LDA, * ), WORK( * ), Z( LDQ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SDRGEV3 checks the nonsymmetric generalized eigenvalue problem driver +*> routine SGGEV3. +*> +*> SGGEV3 computes for a pair of n-by-n nonsymmetric matrices (A,B) the +*> generalized eigenvalues and, optionally, the left and right +*> eigenvectors. +*> +*> A generalized eigenvalue for a pair of matrices (A,B) is a scalar w +*> or a ratio alpha/beta = w, such that A - w*B is singular. It is +*> usually represented as the pair (alpha,beta), as there is reasonable +*> interpretation for beta=0, and even for both being zero. +*> +*> A right generalized eigenvector corresponding to a generalized +*> eigenvalue w for a pair of matrices (A,B) is a vector r such that +*> (A - wB) * r = 0. A left generalized eigenvector is a vector l such +*> that l**H * (A - wB) = 0, where l**H is the conjugate-transpose of l. +*> +*> When SDRGEV3 is called, a number of matrix "sizes" ("n's") and a +*> number of matrix "types" are specified. For each size ("n") +*> and each type of matrix, a pair of matrices (A, B) will be generated +*> and used for testing. For each matrix pair, the following tests +*> will be performed and compared with the threshhold THRESH. +*> +*> Results from SGGEV3: +*> +*> (1) max over all left eigenvalue/-vector pairs (alpha/beta,l) of +*> +*> | VL**H * (beta A - alpha B) |/( ulp max(|beta A|, |alpha B|) ) +*> +*> where VL**H is the conjugate-transpose of VL. +*> +*> (2) | |VL(i)| - 1 | / ulp and whether largest component real +*> +*> VL(i) denotes the i-th column of VL. +*> +*> (3) max over all left eigenvalue/-vector pairs (alpha/beta,r) of +*> +*> | (beta A - alpha B) * VR | / ( ulp max(|beta A|, |alpha B|) ) +*> +*> (4) | |VR(i)| - 1 | / ulp and whether largest component real +*> +*> VR(i) denotes the i-th column of VR. +*> +*> (5) W(full) = W(partial) +*> W(full) denotes the eigenvalues computed when both l and r +*> are also computed, and W(partial) denotes the eigenvalues +*> computed when only W, only W and r, or only W and l are +*> computed. +*> +*> (6) VL(full) = VL(partial) +*> VL(full) denotes the left eigenvectors computed when both l +*> and r are computed, and VL(partial) denotes the result +*> when only l is computed. +*> +*> (7) VR(full) = VR(partial) +*> VR(full) denotes the right eigenvectors computed when both l +*> and r are also computed, and VR(partial) denotes the result +*> when only l is computed. +*> +*> +*> Test Matrices +*> ---- -------- +*> +*> The sizes of the test matrices are specified by an array +*> NN(1:NSIZES); the value of each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if +*> DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) ( 0, 0 ) (a pair of zero matrices) +*> +*> (2) ( I, 0 ) (an identity and a zero matrix) +*> +*> (3) ( 0, I ) (an identity and a zero matrix) +*> +*> (4) ( I, I ) (a pair of identity matrices) +*> +*> t t +*> (5) ( J , J ) (a pair of transposed Jordan blocks) +*> +*> t ( I 0 ) +*> (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) +*> ( 0 I ) ( 0 J ) +*> and I is a k x k identity and J a (k+1)x(k+1) +*> Jordan block; k=(N-1)/2 +*> +*> (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal +*> matrix with those diagonal entries.) +*> (8) ( I, D ) +*> +*> (9) ( big*D, small*I ) where "big" is near overflow and small=1/big +*> +*> (10) ( small*D, big*I ) +*> +*> (11) ( big*I, small*D ) +*> +*> (12) ( small*I, big*D ) +*> +*> (13) ( big*D, big*I ) +*> +*> (14) ( small*D, small*I ) +*> +*> (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and +*> D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) +*> t t +*> (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. +*> +*> (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices +*> with random O(1) entries above the diagonal +*> and diagonal entries diag(T1) = +*> ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = +*> ( 0, N-3, N-4,..., 1, 0, 0 ) +*> +*> (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) +*> s = machine precision. +*> +*> (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) +*> +*> N-5 +*> (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) +*> +*> (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) +*> where r1,..., r(N-4) are random. +*> +*> (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular +*> matrices. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> SDRGEV3 does nothing. NSIZES >= 0. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. NN >= 0. +*> \endverbatim +*> +*> \param[in] NTYPES +*> \verbatim +*> NTYPES is INTEGER +*> The number of elements in DOTYPE. If it is zero, SDRGEV3 +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> \endverbatim +*> +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> \endverbatim +*> +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to SDRGEV3 to continue the same random number +*> sequence. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is REAL +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error is +*> scaled to be O(1), so THRESH should be a reasonably small +*> multiple of 1, e.g., 10 or 100. In particular, it should +*> not depend on the precision (single vs. double) or the size +*> of the matrix. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NOUNIT +*> \verbatim +*> NOUNIT is INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IERR not equal to 0.) +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, +*> dimension(LDA, max(NN)) +*> Used to hold the original A matrix. Used as input only +*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and +*> DOTYPE(MAXTYP+1)=.TRUE. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A, B, S, and T. +*> It must be at least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, +*> dimension(LDA, max(NN)) +*> Used to hold the original B matrix. Used as input only +*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and +*> DOTYPE(MAXTYP+1)=.TRUE. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is REAL array, +*> dimension (LDA, max(NN)) +*> The Schur form matrix computed from A by SGGEV3. On exit, S +*> contains the Schur form matrix corresponding to the matrix +*> in A. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is REAL array, +*> dimension (LDA, max(NN)) +*> The upper triangular matrix computed from B by SGGEV3. +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is REAL array, +*> dimension (LDQ, max(NN)) +*> The (left) eigenvectors matrix computed by SGGEV3. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of Q and Z. It must +*> be at least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is REAL array, dimension( LDQ, max(NN) ) +*> The (right) orthogonal matrix computed by SGGEV3. +*> \endverbatim +*> +*> \param[out] QE +*> \verbatim +*> QE is REAL array, dimension( LDQ, max(NN) ) +*> QE holds the computed right or left eigenvectors. +*> \endverbatim +*> +*> \param[in] LDQE +*> \verbatim +*> LDQE is INTEGER +*> The leading dimension of QE. LDQE >= max(1,max(NN)). +*> \endverbatim +*> +*> \param[out] ALPHAR +*> \verbatim +*> ALPHAR is REAL array, dimension (max(NN)) +*> \endverbatim +*> +*> \param[out] ALPHAI +*> \verbatim +*> ALPHAI is REAL array, dimension (max(NN)) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is REAL array, dimension (max(NN)) +*> \verbatim +*> The generalized eigenvalues of (A,B) computed by SGGEV3. +*> ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th +*> generalized eigenvalue of A and B. +*> \endverbatim +*> +*> \param[out] ALPHR1 +*> \verbatim +*> ALPHR1 is REAL array, dimension (max(NN)) +*> \endverbatim +*> +*> \param[out] ALPHI1 +*> \verbatim +*> ALPHI1 is REAL array, dimension (max(NN)) +*> \endverbatim +*> +*> \param[out] BETA1 +*> \verbatim +*> BETA1 is REAL array, dimension (max(NN)) +*> +*> Like ALPHAR, ALPHAI, BETA, these arrays contain the +*> eigenvalues of A and B, but those computed when SGGEV3 only +*> computes a partial eigendecomposition, i.e. not the +*> eigenvalues and left and right eigenvectors. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The number of entries in WORK. LWORK >= MAX( 8*N, N*(N+1) ). +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (2) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid overflow. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: A routine returned an error code. INFO is the +*> absolute value of the INFO value returned. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date February 2015 +* +*> \ingroup single_eig +* +* ===================================================================== + SUBROUTINE SDRGEV3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, QE, LDQE, + $ ALPHAR, ALPHAI, BETA, ALPHR1, ALPHI1, BETA1, + $ WORK, LWORK, RESULT, INFO ) +* +* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* February 2015 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDQ, LDQE, LWORK, NOUNIT, NSIZES, + $ NTYPES + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), NN( * ) + REAL A( LDA, * ), ALPHAI( * ), ALPHI1( * ), + $ ALPHAR( * ), ALPHR1( * ), B( LDA, * ), + $ BETA( * ), BETA1( * ), Q( LDQ, * ), + $ QE( LDQE, * ), RESULT( * ), S( LDA, * ), + $ T( LDA, * ), WORK( * ), Z( LDQ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 26 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + INTEGER I, IADD, IERR, IN, J, JC, JR, JSIZE, JTYPE, + $ MAXWRK, MINWRK, MTYPES, N, N1, NERRS, NMATS, + $ NMAX, NTESTT + REAL SAFMAX, SAFMIN, ULP, ULPINV +* .. +* .. Local Arrays .. + INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ), + $ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ), + $ KATYPE( MAXTYP ), KAZERO( MAXTYP ), + $ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ), + $ KBZERO( MAXTYP ), KCLASS( MAXTYP ), + $ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 ) + REAL RMAGN( 0: 3 ) +* .. +* .. External Functions .. + INTEGER ILAENV + REAL SLAMCH, SLARND + EXTERNAL ILAENV, SLAMCH, SLARND +* .. +* .. External Subroutines .. + EXTERNAL ALASVM, SGET52, SGGEV3, SLABAD, SLACPY, SLARFG, + $ SLASET, SLATM4, SORM2R, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, REAL, SIGN +* .. +* .. Data statements .. + DATA KCLASS / 15*1, 10*2, 1*3 / + DATA KZ1 / 0, 1, 2, 1, 3, 3 / + DATA KZ2 / 0, 0, 1, 2, 1, 1 / + DATA KADD / 0, 0, 0, 0, 3, 2 / + DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4, + $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 / + DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4, + $ 1, 1, -4, 2, -4, 8*8, 0 / + DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3, + $ 4*5, 4*3, 1 / + DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4, + $ 4*6, 4*4, 1 / + DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3, + $ 2, 1 / + DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3, + $ 2, 1 / + DATA KTRIAN / 16*0, 10*1 / + DATA IASIGN / 6*0, 2, 0, 2*2, 2*0, 3*2, 0, 2, 3*0, + $ 5*2, 0 / + DATA IBSIGN / 7*0, 2, 2*0, 2*2, 2*0, 2, 0, 2, 9*0 / +* .. +* .. Executable Statements .. +* +* Check for errors +* + INFO = 0 +* + BADNN = .FALSE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( THRESH.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDQ.LE.1 .OR. LDQ.LT.NMAX ) THEN + INFO = -14 + ELSE IF( LDQE.LE.1 .OR. LDQE.LT.NMAX ) THEN + INFO = -17 + END IF +* +* Compute workspace +* (Note: Comments in the code beginning "Workspace:" describe the +* minimal amount of workspace needed at that point in the code, +* as well as the preferred amount for good performance. +* NB refers to the optimal block size for the immediately +* following subroutine, as returned by ILAENV. +* + MINWRK = 1 + IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN + MINWRK = MAX( 1, 8*NMAX, NMAX*( NMAX+1 ) ) + MAXWRK = 7*NMAX + NMAX*ILAENV( 1, 'SGEQRF', ' ', NMAX, 1, NMAX, + $ 0 ) + MAXWRK = MAX( MAXWRK, NMAX*( NMAX+1 ) ) + WORK( 1 ) = MAXWRK + END IF +* + IF( LWORK.LT.MINWRK ) + $ INFO = -25 +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SDRGEV3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* + SAFMIN = SLAMCH( 'Safe minimum' ) + ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) + SAFMIN = SAFMIN / ULP + SAFMAX = ONE / SAFMIN + CALL SLABAD( SAFMIN, SAFMAX ) + ULPINV = ONE / ULP +* +* The values RMAGN(2:3) depend on N, see below. +* + RMAGN( 0 ) = ZERO + RMAGN( 1 ) = ONE +* +* Loop over sizes, types +* + NTESTT = 0 + NERRS = 0 + NMATS = 0 +* + DO 220 JSIZE = 1, NSIZES + N = NN( JSIZE ) + N1 = MAX( 1, N ) + RMAGN( 2 ) = SAFMAX*ULP / REAL( N1 ) + RMAGN( 3 ) = SAFMIN*ULPINV*N1 +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 210 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 210 + NMATS = NMATS + 1 +* +* Save ISEED in case of an error. +* + DO 20 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 20 CONTINUE +* +* Generate test matrices A and B +* +* Description of control parameters: +* +* KCLASS: =1 means w/o rotation, =2 means w/ rotation, +* =3 means random. +* KATYPE: the "type" to be passed to SLATM4 for computing A. +* KAZERO: the pattern of zeros on the diagonal for A: +* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), +* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), +* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of +* non-zero entries.) +* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), +* =2: large, =3: small. +* IASIGN: 1 if the diagonal elements of A are to be +* multiplied by a random magnitude 1 number, =2 if +* randomly chosen diagonal blocks are to be rotated +* to form 2x2 blocks. +* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B. +* KTRIAN: =0: don't fill in the upper triangle, =1: do. +* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. +* RMAGN: used to implement KAMAGN and KBMAGN. +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 100 + IERR = 0 + IF( KCLASS( JTYPE ).LT.3 ) THEN +* +* Generate A (w/o rotation) +* + IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN + IN = 2*( ( N-1 ) / 2 ) + 1 + IF( IN.NE.N ) + $ CALL SLASET( 'Full', N, N, ZERO, ZERO, A, LDA ) + ELSE + IN = N + END IF + CALL SLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ), + $ KZ2( KAZERO( JTYPE ) ), IASIGN( JTYPE ), + $ RMAGN( KAMAGN( JTYPE ) ), ULP, + $ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2, + $ ISEED, A, LDA ) + IADD = KADD( KAZERO( JTYPE ) ) + IF( IADD.GT.0 .AND. IADD.LE.N ) + $ A( IADD, IADD ) = ONE +* +* Generate B (w/o rotation) +* + IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN + IN = 2*( ( N-1 ) / 2 ) + 1 + IF( IN.NE.N ) + $ CALL SLASET( 'Full', N, N, ZERO, ZERO, B, LDA ) + ELSE + IN = N + END IF + CALL SLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ), + $ KZ2( KBZERO( JTYPE ) ), IBSIGN( JTYPE ), + $ RMAGN( KBMAGN( JTYPE ) ), ONE, + $ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2, + $ ISEED, B, LDA ) + IADD = KADD( KBZERO( JTYPE ) ) + IF( IADD.NE.0 .AND. IADD.LE.N ) + $ B( IADD, IADD ) = ONE +* + IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN +* +* Include rotations +* +* Generate Q, Z as Householder transformations times +* a diagonal matrix. +* + DO 40 JC = 1, N - 1 + DO 30 JR = JC, N + Q( JR, JC ) = SLARND( 3, ISEED ) + Z( JR, JC ) = SLARND( 3, ISEED ) + 30 CONTINUE + CALL SLARFG( N+1-JC, Q( JC, JC ), Q( JC+1, JC ), 1, + $ WORK( JC ) ) + WORK( 2*N+JC ) = SIGN( ONE, Q( JC, JC ) ) + Q( JC, JC ) = ONE + CALL SLARFG( N+1-JC, Z( JC, JC ), Z( JC+1, JC ), 1, + $ WORK( N+JC ) ) + WORK( 3*N+JC ) = SIGN( ONE, Z( JC, JC ) ) + Z( JC, JC ) = ONE + 40 CONTINUE + Q( N, N ) = ONE + WORK( N ) = ZERO + WORK( 3*N ) = SIGN( ONE, SLARND( 2, ISEED ) ) + Z( N, N ) = ONE + WORK( 2*N ) = ZERO + WORK( 4*N ) = SIGN( ONE, SLARND( 2, ISEED ) ) +* +* Apply the diagonal matrices +* + DO 60 JC = 1, N + DO 50 JR = 1, N + A( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )* + $ A( JR, JC ) + B( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )* + $ B( JR, JC ) + 50 CONTINUE + 60 CONTINUE + CALL SORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, A, + $ LDA, WORK( 2*N+1 ), IERR ) + IF( IERR.NE.0 ) + $ GO TO 90 + CALL SORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ), + $ A, LDA, WORK( 2*N+1 ), IERR ) + IF( IERR.NE.0 ) + $ GO TO 90 + CALL SORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, B, + $ LDA, WORK( 2*N+1 ), IERR ) + IF( IERR.NE.0 ) + $ GO TO 90 + CALL SORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ), + $ B, LDA, WORK( 2*N+1 ), IERR ) + IF( IERR.NE.0 ) + $ GO TO 90 + END IF + ELSE +* +* Random matrices +* + DO 80 JC = 1, N + DO 70 JR = 1, N + A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )* + $ SLARND( 2, ISEED ) + B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )* + $ SLARND( 2, ISEED ) + 70 CONTINUE + 80 CONTINUE + END IF +* + 90 CONTINUE +* + IF( IERR.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IERR, N, JTYPE, + $ IOLDSD + INFO = ABS( IERR ) + RETURN + END IF +* + 100 CONTINUE +* + DO 110 I = 1, 7 + RESULT( I ) = -ONE + 110 CONTINUE +* +* Call SGGEV3 to compute eigenvalues and eigenvectors. +* + CALL SLACPY( ' ', N, N, A, LDA, S, LDA ) + CALL SLACPY( ' ', N, N, B, LDA, T, LDA ) + CALL SGGEV3( 'V', 'V', N, S, LDA, T, LDA, ALPHAR, ALPHAI, + $ BETA, Q, LDQ, Z, LDQ, WORK, LWORK, IERR ) + IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN + RESULT( 1 ) = ULPINV + WRITE( NOUNIT, FMT = 9999 )'SGGEV31', IERR, N, JTYPE, + $ IOLDSD + INFO = ABS( IERR ) + GO TO 190 + END IF +* +* Do the tests (1) and (2) +* + CALL SGET52( .TRUE., N, A, LDA, B, LDA, Q, LDQ, ALPHAR, + $ ALPHAI, BETA, WORK, RESULT( 1 ) ) + IF( RESULT( 2 ).GT.THRESH ) THEN + WRITE( NOUNIT, FMT = 9998 )'Left', 'SGGEV31', + $ RESULT( 2 ), N, JTYPE, IOLDSD + END IF +* +* Do the tests (3) and (4) +* + CALL SGET52( .FALSE., N, A, LDA, B, LDA, Z, LDQ, ALPHAR, + $ ALPHAI, BETA, WORK, RESULT( 3 ) ) + IF( RESULT( 4 ).GT.THRESH ) THEN + WRITE( NOUNIT, FMT = 9998 )'Right', 'SGGEV31', + $ RESULT( 4 ), N, JTYPE, IOLDSD + END IF +* +* Do the test (5) +* + CALL SLACPY( ' ', N, N, A, LDA, S, LDA ) + CALL SLACPY( ' ', N, N, B, LDA, T, LDA ) + CALL SGGEV3( 'N', 'N', N, S, LDA, T, LDA, ALPHR1, ALPHI1, + $ BETA1, Q, LDQ, Z, LDQ, WORK, LWORK, IERR ) + IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN + RESULT( 1 ) = ULPINV + WRITE( NOUNIT, FMT = 9999 )'SGGEV32', IERR, N, JTYPE, + $ IOLDSD + INFO = ABS( IERR ) + GO TO 190 + END IF +* + DO 120 J = 1, N + IF( ALPHAR( J ).NE.ALPHR1( J ) .OR. + $ BETA( J ).NE. BETA1( J ) ) THEN + RESULT( 5 ) = ULPINV + END IF + 120 CONTINUE +* +* Do the test (6): Compute eigenvalues and left eigenvectors, +* and test them +* + CALL SLACPY( ' ', N, N, A, LDA, S, LDA ) + CALL SLACPY( ' ', N, N, B, LDA, T, LDA ) + CALL SGGEV3( 'V', 'N', N, S, LDA, T, LDA, ALPHR1, ALPHI1, + $ BETA1, QE, LDQE, Z, LDQ, WORK, LWORK, IERR ) + IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN + RESULT( 1 ) = ULPINV + WRITE( NOUNIT, FMT = 9999 )'SGGEV33', IERR, N, JTYPE, + $ IOLDSD + INFO = ABS( IERR ) + GO TO 190 + END IF +* + DO 130 J = 1, N + IF( ALPHAR( J ).NE.ALPHR1( J ) .OR. ALPHAI( J ).NE. + $ ALPHI1( J ) .OR. BETA( J ).NE.BETA1( J ) ) + $ RESULT( 6 ) = ULPINV + 130 CONTINUE +* + DO 150 J = 1, N + DO 140 JC = 1, N + IF( Q( J, JC ).NE.QE( J, JC ) ) + $ RESULT( 6 ) = ULPINV + 140 CONTINUE + 150 CONTINUE +* +* DO the test (7): Compute eigenvalues and right eigenvectors, +* and test them +* + CALL SLACPY( ' ', N, N, A, LDA, S, LDA ) + CALL SLACPY( ' ', N, N, B, LDA, T, LDA ) + CALL SGGEV3( 'N', 'V', N, S, LDA, T, LDA, ALPHR1, ALPHI1, + $ BETA1, Q, LDQ, QE, LDQE, WORK, LWORK, IERR ) + IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN + RESULT( 1 ) = ULPINV + WRITE( NOUNIT, FMT = 9999 )'SGGEV34', IERR, N, JTYPE, + $ IOLDSD + INFO = ABS( IERR ) + GO TO 190 + END IF +* + DO 160 J = 1, N + IF( ALPHAR( J ).NE.ALPHR1( J ) .OR. ALPHAI( J ).NE. + $ ALPHI1( J ) .OR. BETA( J ).NE.BETA1( J ) ) + $ RESULT( 7 ) = ULPINV + 160 CONTINUE +* + DO 180 J = 1, N + DO 170 JC = 1, N + IF( Z( J, JC ).NE.QE( J, JC ) ) + $ RESULT( 7 ) = ULPINV + 170 CONTINUE + 180 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + 190 CONTINUE +* + NTESTT = NTESTT + 7 +* +* Print out tests which fail. +* + DO 200 JR = 1, 7 + IF( RESULT( JR ).GE.THRESH ) THEN +* +* If this is the first test to fail, +* print a header to the data file. +* + IF( NERRS.EQ.0 ) THEN + WRITE( NOUNIT, FMT = 9997 )'SGV' +* +* Matrix types +* + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 ) + WRITE( NOUNIT, FMT = 9994 )'Orthogonal' +* +* Tests performed +* + WRITE( NOUNIT, FMT = 9993 ) +* + END IF + NERRS = NERRS + 1 + IF( RESULT( JR ).LT.10000.0 ) THEN + WRITE( NOUNIT, FMT = 9992 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + ELSE + WRITE( NOUNIT, FMT = 9991 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + END IF + END IF + 200 CONTINUE +* + 210 CONTINUE + 220 CONTINUE +* +* Summary +* + CALL ALASVM( 'SGV', NOUNIT, NERRS, NTESTT, 0 ) +* + WORK( 1 ) = MAXWRK +* + RETURN +* + 9999 FORMAT( ' SDRGEV3: ', A, ' returned INFO=', I6, '.', / 3X, 'N=', + $ I6, ', JTYPE=', I6, ', ISEED=(', 4( I4, ',' ), I5, ')' ) +* + 9998 FORMAT( ' SDRGEV3: ', A, ' Eigenvectors from ', A, ' incorrectly ', + $ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 3X, + $ 'N=', I4, ', JTYPE=', I3, ', ISEED=(', 4( I4, ',' ), I5, + $ ')' ) +* + 9997 FORMAT( / 1X, A3, ' -- Real Generalized eigenvalue problem driver' + $ ) +* + 9996 FORMAT( ' Matrix types (see SDRGEV3 for details): ' ) +* + 9995 FORMAT( ' Special Matrices:', 23X, + $ '(J''=transposed Jordan block)', + $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ', + $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ', + $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I', + $ ') 11=(large*I, small*D) 13=(large*D, large*I)', / + $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ', + $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' ) + 9994 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:', + $ / ' 16=Transposed Jordan Blocks 19=geometric ', + $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ', + $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ', + $ 'alpha, beta=0,1 21=random alpha, beta=0,1', + $ / ' Large & Small Matrices:', / ' 22=(large, small) ', + $ '23=(small,large) 24=(small,small) 25=(large,large)', + $ / ' 26=random O(1) matrices.' ) +* + 9993 FORMAT( / ' Tests performed: ', + $ / ' 1 = max | ( b A - a B )''*l | / const.,', + $ / ' 2 = | |VR(i)| - 1 | / ulp,', + $ / ' 3 = max | ( b A - a B )*r | / const.', + $ / ' 4 = | |VL(i)| - 1 | / ulp,', + $ / ' 5 = 0 if W same no matter if r or l computed,', + $ / ' 6 = 0 if l same no matter if l computed,', + $ / ' 7 = 0 if r same no matter if r computed,', / 1X ) + 9992 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I2, ' is', 0P, F8.2 ) + 9991 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I2, ' is', 1P, E10.3 ) +* +* End of SDRGEV3 +* + END diff --git a/TESTING/EIG/serrgg.f b/TESTING/EIG/serrgg.f index f04f6a8..8961032 100644 --- a/TESTING/EIG/serrgg.f +++ b/TESTING/EIG/serrgg.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 SERRGG( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -22,8 +22,9 @@ *> \verbatim *> *> SERRGG tests the error exits for SGGES, SGGESX, SGGEV, SGGEVX, -*> SGGGLM, SGGHRD, SGGLSE, SGGQRF, SGGRQF, SGGSVD, SGGSVP, SHGEQZ, -*> SORCSD, STGEVC, STGEXC, STGSEN, STGSJA, STGSNA, and STGSYL. +*> SGGES3, SGGEV3, SGGGLM, SGGHRD, SGGLSE, SGGQRF, SGGRQF, SGGSVD, +*> SGGSVP, SHGEQZ, SORCSD, STGEVC, STGEXC, STGSEN, STGSJA, STGSNA, +*> and STGSYL. *> \endverbatim * * Arguments: @@ -44,10 +45,10 @@ * 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 * @@ -97,7 +98,7 @@ EXTERNAL CHKXER, SGGES, SGGESX, SGGEV, SGGEVX, SGGGLM, $ SGGHRD, SGGLSE, SGGQRF, SGGRQF, SGGSVD, SGGSVP, $ SHGEQZ, SORCSD, STGEVC, STGEXC, STGSEN, STGSJA, - $ STGSNA, STGSYL + $ STGSNA, STGSYL, SGGES3, SGGEV3, SGGHD3 * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -170,6 +171,47 @@ CALL CHKXER( 'SGGHRD', INFOT, NOUT, LERR, OK ) NT = NT + 9 * +* SGGHD3 +* + SRNAMT = 'SGGHD3' + INFOT = 1 + CALL SGGHD3( '/', 'N', 0, 1, 0, A, 1, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'SGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGGHD3( 'N', '/', 0, 1, 0, A, 1, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'SGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SGGHD3( 'N', 'N', -1, 0, 0, A, 1, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'SGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGGHD3( 'N', 'N', 0, 0, 0, A, 1, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'SGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGGHD3( 'N', 'N', 0, 1, 1, A, 1, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'SGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SGGHD3( 'N', 'N', 2, 1, 1, A, 1, B, 2, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'SGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SGGHD3( 'N', 'N', 2, 1, 1, A, 2, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'SGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SGGHD3( 'V', 'N', 2, 1, 1, A, 2, B, 2, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'SGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL SGGHD3( 'N', 'V', 2, 1, 1, A, 2, B, 2, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'SGGHD3', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * SHGEQZ * SRNAMT = 'SHGEQZ' @@ -503,56 +545,56 @@ $ -1, 0, 0, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, 1, A, - $ 1, W, LW, IW, INFO ) + $ 1, W, LW, IW, INFO ) CALL CHKXER( 'SORCSD', INFOT, NOUT, LERR, OK ) INFOT = 8 CALL SORCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, -1, 0, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, 1, A, - $ 1, W, LW, IW, INFO ) + $ 1, W, LW, IW, INFO ) CALL CHKXER( 'SORCSD', INFOT, NOUT, LERR, OK ) INFOT = 9 CALL SORCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, -1, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, 1, A, - $ 1, W, LW, IW, INFO ) + $ 1, W, LW, IW, INFO ) CALL CHKXER( 'SORCSD', INFOT, NOUT, LERR, OK ) INFOT = 11 CALL SORCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, -1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, 1, A, - $ 1, W, LW, IW, INFO ) + $ 1, W, LW, IW, INFO ) CALL CHKXER( 'SORCSD', INFOT, NOUT, LERR, OK ) INFOT = 20 CALL SORCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, $ 1, A, 1, A, 1, A, $ A, -1, A, 1, A, 1, A, - $ 1, W, LW, IW, INFO ) + $ 1, W, LW, IW, INFO ) CALL CHKXER( 'SORCSD', INFOT, NOUT, LERR, OK ) INFOT = 22 CALL SORCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, -1, A, 1, A, - $ 1, W, LW, IW, INFO ) + $ 1, W, LW, IW, INFO ) CALL CHKXER( 'SORCSD', INFOT, NOUT, LERR, OK ) INFOT = 24 CALL SORCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, -1, A, - $ 1, W, LW, IW, INFO ) + $ 1, W, LW, IW, INFO ) CALL CHKXER( 'SORCSD', INFOT, NOUT, LERR, OK ) INFOT = 26 CALL SORCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, 1, A, - $ -1, W, LW, IW, INFO ) + $ -1, W, LW, IW, INFO ) CALL CHKXER( 'SORCSD', INFOT, NOUT, LERR, OK ) NT = NT + 8 * @@ -662,6 +704,55 @@ CALL CHKXER( 'SGGES ', INFOT, NOUT, LERR, OK ) NT = NT + 11 * +* SGGES3 +* + SRNAMT = 'SGGES3' + INFOT = 1 + CALL SGGES3( '/', 'N', 'S', SLCTES, 1, A, 1, B, 1, SDIM, R1, + $ R2, R3, Q, 1, U, 1, W, 1, BW, INFO ) + CALL CHKXER( 'SGGES3 ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGGES3( 'N', '/', 'S', SLCTES, 1, A, 1, B, 1, SDIM, R1, + $ R2, R3, Q, 1, U, 1, W, 1, BW, INFO ) + CALL CHKXER( 'SGGES3 ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SGGES3( 'N', 'V', '/', SLCTES, 1, A, 1, B, 1, SDIM, R1, + $ R2, R3, Q, 1, U, 1, W, 1, BW, INFO ) + CALL CHKXER( 'SGGES3 ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGGES3( 'N', 'V', 'S', SLCTES, -1, A, 1, B, 1, SDIM, R1, + $ R2, R3, Q, 1, U, 1, W, 1, BW, INFO ) + CALL CHKXER( 'SGGES3 ', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SGGES3( 'N', 'V', 'S', SLCTES, 1, A, 0, B, 1, SDIM, R1, + $ R2, R3, Q, 1, U, 1, W, 1, BW, INFO ) + CALL CHKXER( 'SGGES3 ', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SGGES3( 'N', 'V', 'S', SLCTES, 1, A, 1, B, 0, SDIM, R1, + $ R2, R3, Q, 1, U, 1, W, 1, BW, INFO ) + CALL CHKXER( 'SGGES3 ', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL SGGES3( 'N', 'V', 'S', SLCTES, 1, A, 1, B, 1, SDIM, R1, + $ R2, R3, Q, 0, U, 1, W, 1, BW, INFO ) + CALL CHKXER( 'SGGES3 ', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL SGGES3( 'V', 'V', 'S', SLCTES, 2, A, 2, B, 2, SDIM, R1, + $ R2, R3, Q, 1, U, 2, W, 1, BW, INFO ) + CALL CHKXER( 'SGGES3 ', INFOT, NOUT, LERR, OK ) + INFOT = 17 + CALL SGGES3( 'N', 'V', 'S', SLCTES, 1, A, 1, B, 1, SDIM, R1, + $ R2, R3, Q, 1, U, 0, W, 1, BW, INFO ) + CALL CHKXER( 'SGGES3 ', INFOT, NOUT, LERR, OK ) + INFOT = 17 + CALL SGGES3( 'V', 'V', 'S', SLCTES, 2, A, 2, B, 2, SDIM, R1, + $ R2, R3, Q, 2, U, 1, W, 1, BW, INFO ) + CALL CHKXER( 'SGGES3 ', INFOT, NOUT, LERR, OK ) + INFOT = 19 + CALL SGGES3( 'V', 'V', 'S', SLCTES, 2, A, 2, B, 2, SDIM, R1, + $ R2, R3, Q, 2, U, 2, W, 1, BW, INFO ) + CALL CHKXER( 'SGGES3 ', INFOT, NOUT, LERR, OK ) + NT = NT + 11 +* * SGGESX * SRNAMT = 'SGGESX' @@ -777,6 +868,51 @@ CALL CHKXER( 'SGGEV ', INFOT, NOUT, LERR, OK ) NT = NT + 10 * +* SGGEV3 +* + SRNAMT = 'SGGEV3 ' + INFOT = 1 + CALL SGGEV3( '/', 'N', 1, A, 1, B, 1, R1, R2, R3, Q, 1, U, 1, + $ W, 1, INFO ) + CALL CHKXER( 'SGGEV3 ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGGEV3( 'N', '/', 1, A, 1, B, 1, R1, R2, R3, Q, 1, U, 1, + $ W, 1, INFO ) + CALL CHKXER( 'SGGEV3 ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SGGEV3( 'V', 'V', -1, A, 1, B, 1, R1, R2, R3, Q, 1, U, 1, + $ W, 1, INFO ) + CALL CHKXER( 'SGGEV3 ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGGEV3( 'V', 'V', 1, A, 0, B, 1, R1, R2, R3, Q, 1, U, 1, + $ W, 1, INFO ) + CALL CHKXER( 'SGGEV3 ', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SGGEV3( 'V', 'V', 1, A, 1, B, 0, R1, R2, R3, Q, 1, U, 1, + $ W, 1, INFO ) + CALL CHKXER( 'SGGEV3 ', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SGGEV3( 'N', 'V', 1, A, 1, B, 1, R1, R2, R3, Q, 0, U, 1, + $ W, 1, INFO ) + CALL CHKXER( 'SGGEV3 ', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SGGEV3( 'V', 'V', 2, A, 2, B, 2, R1, R2, R3, Q, 1, U, 2, + $ W, 1, INFO ) + CALL CHKXER( 'SGGEV3 ', INFOT, NOUT, LERR, OK ) + INFOT = 14 + CALL SGGEV3( 'V', 'N', 2, A, 2, B, 2, R1, R2, R3, Q, 2, U, 0, + $ W, 1, INFO ) + CALL CHKXER( 'SGGEV3 ', INFOT, NOUT, LERR, OK ) + INFOT = 14 + CALL SGGEV3( 'V', 'V', 2, A, 2, B, 2, R1, R2, R3, Q, 2, U, 1, + $ W, 1, INFO ) + CALL CHKXER( 'SGGEV3 ', INFOT, NOUT, LERR, OK ) + INFOT = 16 + CALL SGGEV3( 'V', 'V', 1, A, 1, B, 1, R1, R2, R3, Q, 1, U, 1, + $ W, 1, INFO ) + CALL CHKXER( 'SGGEV3 ', INFOT, NOUT, LERR, OK ) + NT = NT + 10 +* * SGGEVX * SRNAMT = 'SGGEVX' diff --git a/TESTING/EIG/zchkee.f b/TESTING/EIG/zchkee.f index ea58f37..7107da2 100644 --- a/TESTING/EIG/zchkee.f +++ b/TESTING/EIG/zchkee.f @@ -44,7 +44,7 @@ *> Test ZGEESX *> *> ZGG (Generalized Nonsymmetric Eigenvalue Problem): -*> Test ZGGHRD, ZGGBAL, ZGGBAK, ZHGEQZ, and ZTGEVC +*> Test ZGGHD3, ZGGBAL, ZGGBAK, ZHGEQZ, and ZTGEVC *> and the driver routines ZGEGS and ZGEGV *> *> ZGS (Generalized Nonsymmetric Schur form Driver): @@ -489,38 +489,41 @@ *> line 8: MXBVAL, INTEGER array, dimension (NPARMS) *> The values for MAXB, used in determining minimum blocksize. *> -*> line 9: NBCOL, INTEGER array, dimension (NPARMS) +*> line 9: IACC22, INTEGER array, dimension (NPARMS) +*> select structured matrix multiply: 1 or 2) +*> +*> line 10: NBCOL, INTEGER array, dimension (NPARMS) *> The values for NBCOL, the minimum column dimension for *> blocks. *> -*> line 10: THRESH +*> line 11: THRESH *> Threshold value for the test ratios. Information will be *> printed about each test for which the test ratio is greater *> than or equal to the threshold. *> -*> line 11: TSTCHK, LOGICAL +*> line 12: TSTCHK, LOGICAL *> Flag indicating whether or not to test the LAPACK routines. *> -*> line 12: TSTDRV, LOGICAL +*> line 13: TSTDRV, LOGICAL *> Flag indicating whether or not to test the driver routines. *> -*> line 13: TSTERR, LOGICAL +*> line 14: TSTERR, LOGICAL *> Flag indicating whether or not to test the error exits for *> the LAPACK routines and driver routines. *> -*> line 14: NEWSD, INTEGER +*> line 15: NEWSD, INTEGER *> A code indicating how to set the random number seed. *> = 0: Set the seed to a default value before each run *> = 1: Initialize the seed to a default value only before the *> first run *> = 2: Like 1, but use the seed values on the next line *> -*> If line 14 was 2: +*> If line 15 was 2: *> -*> line 15: INTEGER array, dimension (4) +*> line 16: INTEGER array, dimension (4) *> Four integer values for the random number seed. *> -*> lines 16-EOF: Lines specifying matrix types, as for NEP. +*> lines 17-EOF: Lines specifying matrix types, as for NEP. *> The 3-character path name is 'ZGG' for the generalized *> eigenvalue problem routines and driver routines. *> @@ -1100,7 +1103,8 @@ $ ZCHKST, ZCKCSD, ZCKGLM, ZCKGQR, ZCKGSV, ZCKLSE, $ ZDRGES, ZDRGEV, ZDRGSX, ZDRGVX, ZDRVBD, ZDRVES, $ ZDRVEV, ZDRVGG, ZDRVSG, ZDRVST, ZDRVSX, ZDRVVX, - $ ZERRBD, ZERRED, ZERRGG, ZERRHS, ZERRST, ILAVER + $ ZERRBD, ZERRED, ZERRGG, ZERRHS, ZERRST, ILAVER, + $ ZDRGES3, ZDRGEV3 * .. * .. Intrinsic Functions .. INTRINSIC LEN, MIN @@ -1621,7 +1625,7 @@ * * Read the values for IACC22. * - IF( NEP ) THEN + IF( NEP .OR. ZGG ) THEN READ( NIN, FMT = * )( IACC22( I ), I = 1, NPARMS ) DO 620 I = 1, NPARMS IF( IACC22( I ).LT.0 ) THEN @@ -2090,6 +2094,7 @@ * NBMIN = minimum block size * NS = number of shifts * MAXB = minimum submatrix size +* IACC22: structured matrix multiply * NBCOL = minimum column dimension for blocks * MAXTYP = 26 @@ -2102,6 +2107,7 @@ CALL XLAENV( 2, NBMIN( I ) ) CALL XLAENV( 4, NSVAL( I ) ) CALL XLAENV( 8, MXBVAL( I ) ) + CALL XLAENV( 16, IACC22( I ) ) CALL XLAENV( 5, NBCOL( I ) ) * IF( NEWSD.EQ.0 ) THEN @@ -2110,7 +2116,7 @@ 340 CONTINUE END IF WRITE( NOUT, FMT = 9996 )C3, NBVAL( I ), NBMIN( I ), - $ NSVAL( I ), MXBVAL( I ), NBCOL( I ) + $ NSVAL( I ), MXBVAL( I ), IACC22( I ), NBCOL( I ) TSTDIF = .FALSE. THRSHN = 10.D0 IF( TSTCHK ) THEN @@ -2162,6 +2168,17 @@ * IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'ZDRGES', INFO +* +* Blocked version +* + CALL ZDRGES3( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT, + $ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ), + $ A( 1, 4 ), A( 1, 7 ), NMAX, A( 1, 8 ), + $ DC( 1, 1 ), DC( 1, 2 ), WORK, LWORK, RWORK, + $ RESULT, LOGWRK, INFO ) +* + IF( INFO.NE.0 ) + $ WRITE( NOUT, FMT = 9980 )'ZDRGES3', INFO END IF WRITE( NOUT, FMT = 9973 ) GO TO 10 @@ -2206,7 +2223,7 @@ WRITE( NOUT, FMT = 9990 )C3 ELSE IF( TSTERR ) - $ CALL ZERRGG( C3, NOUT ) + $ CALL ZERRGG( C3, NOUT ) CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT ) CALL ZDRGEV( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT, $ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ), @@ -2216,6 +2233,17 @@ $ RESULT, INFO ) IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9980 )'ZDRGEV', INFO +* +* Blocked version +* + CALL ZDRGEV3( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT, + $ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ), + $ A( 1, 4 ), A( 1, 7 ), NMAX, A( 1, 8 ), + $ A( 1, 9 ), NMAX, DC( 1, 1 ), DC( 1, 2 ), + $ DC( 1, 3 ), DC( 1, 4 ), WORK, LWORK, RWORK, + $ RESULT, INFO ) + IF( INFO.NE.0 ) + $ WRITE( NOUT, FMT = 9980 )'ZDRGEV3', INFO END IF WRITE( NOUT, FMT = 9973 ) GO TO 10 @@ -2388,7 +2416,7 @@ 9999 FORMAT( / ' Execution not attempted due to input errors' ) 9997 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4 ) 9996 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NS =', I4, - $ ', MAXB =', I4, ', NBCOL =', I4 ) + $ ', MAXB =', I4, ', IACC22 =', I4, ', NBCOL =', I4 ) 9995 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4, $ ', NRHS =', I4 ) 9994 FORMAT( / / ' End of tests' ) diff --git a/TESTING/EIG/zdrges3.f b/TESTING/EIG/zdrges3.f new file mode 100644 index 0000000..9a42773 --- /dev/null +++ b/TESTING/EIG/zdrges3.f @@ -0,0 +1,940 @@ +*> \brief \b ZDRGES3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZDRGES3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, ALPHA, +* BETA, WORK, LWORK, RWORK, RESULT, BWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL BWORK( * ), DOTYPE( * ) +* INTEGER ISEED( 4 ), NN( * ) +* DOUBLE PRECISION RESULT( 13 ), RWORK( * ) +* COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDA, * ), +* $ BETA( * ), Q( LDQ, * ), S( LDA, * ), +* $ T( LDA, * ), WORK( * ), Z( LDQ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDRGES3 checks the nonsymmetric generalized eigenvalue (Schur form) +*> problem driver ZGGES3. +*> +*> ZGGES3 factors A and B as Q*S*Z' and Q*T*Z' , where ' means conjugate +*> transpose, S and T are upper triangular (i.e., in generalized Schur +*> form), and Q and Z are unitary. It also computes the generalized +*> eigenvalues (alpha(j),beta(j)), j=1,...,n. Thus, +*> w(j) = alpha(j)/beta(j) is a root of the characteristic equation +*> +*> det( A - w(j) B ) = 0 +*> +*> Optionally it also reorder the eigenvalues so that a selected +*> cluster of eigenvalues appears in the leading diagonal block of the +*> Schur forms. +*> +*> When ZDRGES3 is called, a number of matrix "sizes" ("N's") and a +*> number of matrix "TYPES" are specified. For each size ("N") +*> and each TYPE of matrix, a pair of matrices (A, B) will be generated +*> and used for testing. For each matrix pair, the following 13 tests +*> will be performed and compared with the threshhold THRESH except +*> the tests (5), (11) and (13). +*> +*> +*> (1) | A - Q S Z' | / ( |A| n ulp ) (no sorting of eigenvalues) +*> +*> +*> (2) | B - Q T Z' | / ( |B| n ulp ) (no sorting of eigenvalues) +*> +*> +*> (3) | I - QQ' | / ( n ulp ) (no sorting of eigenvalues) +*> +*> +*> (4) | I - ZZ' | / ( n ulp ) (no sorting of eigenvalues) +*> +*> (5) if A is in Schur form (i.e. triangular form) (no sorting of +*> eigenvalues) +*> +*> (6) if eigenvalues = diagonal elements of the Schur form (S, T), +*> i.e., test the maximum over j of D(j) where: +*> +*> |alpha(j) - S(j,j)| |beta(j) - T(j,j)| +*> D(j) = ------------------------ + ----------------------- +*> max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) +*> +*> (no sorting of eigenvalues) +*> +*> (7) | (A,B) - Q (S,T) Z' | / ( |(A,B)| n ulp ) +*> (with sorting of eigenvalues). +*> +*> (8) | I - QQ' | / ( n ulp ) (with sorting of eigenvalues). +*> +*> (9) | I - ZZ' | / ( n ulp ) (with sorting of eigenvalues). +*> +*> (10) if A is in Schur form (i.e. quasi-triangular form) +*> (with sorting of eigenvalues). +*> +*> (11) if eigenvalues = diagonal elements of the Schur form (S, T), +*> i.e. test the maximum over j of D(j) where: +*> +*> |alpha(j) - S(j,j)| |beta(j) - T(j,j)| +*> D(j) = ------------------------ + ----------------------- +*> max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) +*> +*> (with sorting of eigenvalues). +*> +*> (12) if sorting worked and SDIM is the number of eigenvalues +*> which were CELECTed. +*> +*> Test Matrices +*> ============= +*> +*> The sizes of the test matrices are specified by an array +*> NN(1:NSIZES); the value of each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if +*> DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) ( 0, 0 ) (a pair of zero matrices) +*> +*> (2) ( I, 0 ) (an identity and a zero matrix) +*> +*> (3) ( 0, I ) (an identity and a zero matrix) +*> +*> (4) ( I, I ) (a pair of identity matrices) +*> +*> t t +*> (5) ( J , J ) (a pair of transposed Jordan blocks) +*> +*> t ( I 0 ) +*> (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) +*> ( 0 I ) ( 0 J ) +*> and I is a k x k identity and J a (k+1)x(k+1) +*> Jordan block; k=(N-1)/2 +*> +*> (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal +*> matrix with those diagonal entries.) +*> (8) ( I, D ) +*> +*> (9) ( big*D, small*I ) where "big" is near overflow and small=1/big +*> +*> (10) ( small*D, big*I ) +*> +*> (11) ( big*I, small*D ) +*> +*> (12) ( small*I, big*D ) +*> +*> (13) ( big*D, big*I ) +*> +*> (14) ( small*D, small*I ) +*> +*> (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and +*> D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) +*> t t +*> (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. +*> +*> (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices +*> with random O(1) entries above the diagonal +*> and diagonal entries diag(T1) = +*> ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = +*> ( 0, N-3, N-4,..., 1, 0, 0 ) +*> +*> (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) +*> s = machine precision. +*> +*> (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) +*> +*> N-5 +*> (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) +*> +*> (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) +*> where r1,..., r(N-4) are random. +*> +*> (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular +*> matrices. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> DDRGES3 does nothing. NSIZES >= 0. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. NN >= 0. +*> \endverbatim +*> +*> \param[in] NTYPES +*> \verbatim +*> NTYPES is INTEGER +*> The number of elements in DOTYPE. If it is zero, DDRGES3 +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A on input. +*> This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> \endverbatim +*> +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> \endverbatim +*> +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to DDRGES3 to continue the same random number +*> sequence. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error is +*> scaled to be O(1), so THRESH should be a reasonably small +*> multiple of 1, e.g., 10 or 100. In particular, it should +*> not depend on the precision (single vs. double) or the size +*> of the matrix. THRESH >= 0. +*> \endverbatim +*> +*> \param[in] NOUNIT +*> \verbatim +*> NOUNIT is INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension(LDA, max(NN)) +*> Used to hold the original A matrix. Used as input only +*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and +*> DOTYPE(MAXTYP+1)=.TRUE. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A, B, S, and T. +*> It must be at least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension(LDA, max(NN)) +*> Used to hold the original B matrix. Used as input only +*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and +*> DOTYPE(MAXTYP+1)=.TRUE. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is COMPLEX*16 array, dimension (LDA, max(NN)) +*> The Schur form matrix computed from A by ZGGES3. On exit, S +*> contains the Schur form matrix corresponding to the matrix +*> in A. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX*16 array, dimension (LDA, max(NN)) +*> The upper triangular matrix computed from B by ZGGES3. +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is COMPLEX*16 array, dimension (LDQ, max(NN)) +*> The (left) orthogonal matrix computed by ZGGES3. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of Q and Z. It must +*> be at least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is COMPLEX*16 array, dimension( LDQ, max(NN) ) +*> The (right) orthogonal matrix computed by ZGGES3. +*> \endverbatim +*> +*> \param[out] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 array, dimension (max(NN)) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is COMPLEX*16 array, dimension (max(NN)) +*> +*> The generalized eigenvalues of (A,B) computed by ZGGES3. +*> ALPHA(k) / BETA(k) is the k-th generalized eigenvalue of A +*> and B. +*> \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 >= 3*N*N. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension ( 8*N ) +*> Real workspace. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (15) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid overflow. +*> \endverbatim +*> +*> \param[out] BWORK +*> \verbatim +*> BWORK is LOGICAL 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: A routine returned an error code. INFO is the +*> absolute value of the INFO value returned. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date February 2015 +* +*> \ingroup complex16_eig +* +* ===================================================================== + SUBROUTINE ZDRGES3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, ALPHA, + $ BETA, WORK, LWORK, RWORK, RESULT, BWORK, + $ INFO ) +* +* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* February 2015 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL BWORK( * ), DOTYPE( * ) + INTEGER ISEED( 4 ), NN( * ) + DOUBLE PRECISION RESULT( 13 ), RWORK( * ) + COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDA, * ), + $ BETA( * ), Q( LDQ, * ), S( LDA, * ), + $ T( LDA, * ), WORK( * ), Z( LDQ, * ) +* .. +* +* ===================================================================== +* +* .. 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 ) ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 26 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN, ILABAD + CHARACTER SORT + INTEGER I, IADD, IINFO, IN, ISORT, J, JC, JR, JSIZE, + $ JTYPE, KNTEIG, MAXWRK, MINWRK, MTYPES, N, N1, + $ NB, NERRS, NMATS, NMAX, NTEST, NTESTT, RSUB, + $ SDIM + DOUBLE PRECISION SAFMAX, SAFMIN, TEMP1, TEMP2, ULP, ULPINV + COMPLEX*16 CTEMP, X +* .. +* .. Local Arrays .. + LOGICAL LASIGN( MAXTYP ), LBSIGN( MAXTYP ) + INTEGER IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ), + $ KATYPE( MAXTYP ), KAZERO( MAXTYP ), + $ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ), + $ KBZERO( MAXTYP ), KCLASS( MAXTYP ), + $ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 ) + DOUBLE PRECISION RMAGN( 0: 3 ) +* .. +* .. External Functions .. + LOGICAL ZLCTES + INTEGER ILAENV + DOUBLE PRECISION DLAMCH + COMPLEX*16 ZLARND + EXTERNAL ZLCTES, ILAENV, DLAMCH, ZLARND +* .. +* .. External Subroutines .. + EXTERNAL ALASVM, DLABAD, XERBLA, ZGET51, ZGET54, ZGGES3, + $ ZLACPY, ZLARFG, ZLASET, ZLATM4, ZUNM2R +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SIGN +* .. +* .. Statement Functions .. + DOUBLE PRECISION ABS1 +* .. +* .. Statement Function definitions .. + ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) ) +* .. +* .. Data statements .. + DATA KCLASS / 15*1, 10*2, 1*3 / + DATA KZ1 / 0, 1, 2, 1, 3, 3 / + DATA KZ2 / 0, 0, 1, 2, 1, 1 / + DATA KADD / 0, 0, 0, 0, 3, 2 / + DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4, + $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 / + DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4, + $ 1, 1, -4, 2, -4, 8*8, 0 / + DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3, + $ 4*5, 4*3, 1 / + DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4, + $ 4*6, 4*4, 1 / + DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3, + $ 2, 1 / + DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3, + $ 2, 1 / + DATA KTRIAN / 16*0, 10*1 / + DATA LASIGN / 6*.FALSE., .TRUE., .FALSE., 2*.TRUE., + $ 2*.FALSE., 3*.TRUE., .FALSE., .TRUE., + $ 3*.FALSE., 5*.TRUE., .FALSE. / + DATA LBSIGN / 7*.FALSE., .TRUE., 2*.FALSE., + $ 2*.TRUE., 2*.FALSE., .TRUE., .FALSE., .TRUE., + $ 9*.FALSE. / +* .. +* .. Executable Statements .. +* +* Check for errors +* + INFO = 0 +* + BADNN = .FALSE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( THRESH.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDQ.LE.1 .OR. LDQ.LT.NMAX ) THEN + INFO = -14 + END IF +* +* Compute workspace +* (Note: Comments in the code beginning "Workspace:" describe the +* minimal amount of workspace needed at that point in the code, +* as well as the preferred amount for good performance. +* NB refers to the optimal block size for the immediately +* following subroutine, as returned by ILAENV. +* + MINWRK = 1 + IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN + MINWRK = 3*NMAX*NMAX + NB = MAX( 1, ILAENV( 1, 'ZGEQRF', ' ', NMAX, NMAX, -1, -1 ), + $ ILAENV( 1, 'ZUNMQR', 'LC', NMAX, NMAX, NMAX, -1 ), + $ ILAENV( 1, 'ZUNGQR', ' ', NMAX, NMAX, NMAX, -1 ) ) + MAXWRK = MAX( NMAX+NMAX*NB, 3*NMAX*NMAX ) + WORK( 1 ) = MAXWRK + END IF +* + IF( LWORK.LT.MINWRK ) + $ INFO = -19 +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZDRGES3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* + ULP = DLAMCH( 'Precision' ) + SAFMIN = DLAMCH( 'Safe minimum' ) + SAFMIN = SAFMIN / ULP + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULPINV = ONE / ULP +* +* The values RMAGN(2:3) depend on N, see below. +* + RMAGN( 0 ) = ZERO + RMAGN( 1 ) = ONE +* +* Loop over matrix sizes +* + NTESTT = 0 + NERRS = 0 + NMATS = 0 +* + DO 190 JSIZE = 1, NSIZES + N = NN( JSIZE ) + N1 = MAX( 1, N ) + RMAGN( 2 ) = SAFMAX*ULP / DBLE( N1 ) + RMAGN( 3 ) = SAFMIN*ULPINV*DBLE( N1 ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* +* Loop over matrix types +* + DO 180 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 180 + NMATS = NMATS + 1 + NTEST = 0 +* +* Save ISEED in case of an error. +* + DO 20 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 20 CONTINUE +* +* Initialize RESULT +* + DO 30 J = 1, 13 + RESULT( J ) = ZERO + 30 CONTINUE +* +* Generate test matrices A and B +* +* Description of control parameters: +* +* KZLASS: =1 means w/o rotation, =2 means w/ rotation, +* =3 means random. +* KATYPE: the "type" to be passed to ZLATM4 for computing A. +* KAZERO: the pattern of zeros on the diagonal for A: +* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), +* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), +* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of +* non-zero entries.) +* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), +* =2: large, =3: small. +* LASIGN: .TRUE. if the diagonal elements of A are to be +* multiplied by a random magnitude 1 number. +* KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B. +* KTRIAN: =0: don't fill in the upper triangle, =1: do. +* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. +* RMAGN: used to implement KAMAGN and KBMAGN. +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 110 + IINFO = 0 + IF( KCLASS( JTYPE ).LT.3 ) THEN +* +* Generate A (w/o rotation) +* + IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN + IN = 2*( ( N-1 ) / 2 ) + 1 + IF( IN.NE.N ) + $ CALL ZLASET( 'Full', N, N, CZERO, CZERO, A, LDA ) + ELSE + IN = N + END IF + CALL ZLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ), + $ KZ2( KAZERO( JTYPE ) ), LASIGN( JTYPE ), + $ RMAGN( KAMAGN( JTYPE ) ), ULP, + $ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2, + $ ISEED, A, LDA ) + IADD = KADD( KAZERO( JTYPE ) ) + IF( IADD.GT.0 .AND. IADD.LE.N ) + $ A( IADD, IADD ) = RMAGN( KAMAGN( JTYPE ) ) +* +* Generate B (w/o rotation) +* + IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN + IN = 2*( ( N-1 ) / 2 ) + 1 + IF( IN.NE.N ) + $ CALL ZLASET( 'Full', N, N, CZERO, CZERO, B, LDA ) + ELSE + IN = N + END IF + CALL ZLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ), + $ KZ2( KBZERO( JTYPE ) ), LBSIGN( JTYPE ), + $ RMAGN( KBMAGN( JTYPE ) ), ONE, + $ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2, + $ ISEED, B, LDA ) + IADD = KADD( KBZERO( JTYPE ) ) + IF( IADD.NE.0 .AND. IADD.LE.N ) + $ B( IADD, IADD ) = RMAGN( KBMAGN( JTYPE ) ) +* + IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN +* +* Include rotations +* +* Generate Q, Z as Householder transformations times +* a diagonal matrix. +* + DO 50 JC = 1, N - 1 + DO 40 JR = JC, N + Q( JR, JC ) = ZLARND( 3, ISEED ) + Z( JR, JC ) = ZLARND( 3, ISEED ) + 40 CONTINUE + CALL ZLARFG( N+1-JC, Q( JC, JC ), Q( JC+1, JC ), 1, + $ WORK( JC ) ) + WORK( 2*N+JC ) = SIGN( ONE, DBLE( Q( JC, JC ) ) ) + Q( JC, JC ) = CONE + CALL ZLARFG( N+1-JC, Z( JC, JC ), Z( JC+1, JC ), 1, + $ WORK( N+JC ) ) + WORK( 3*N+JC ) = SIGN( ONE, DBLE( Z( JC, JC ) ) ) + Z( JC, JC ) = CONE + 50 CONTINUE + CTEMP = ZLARND( 3, ISEED ) + Q( N, N ) = CONE + WORK( N ) = CZERO + WORK( 3*N ) = CTEMP / ABS( CTEMP ) + CTEMP = ZLARND( 3, ISEED ) + Z( N, N ) = CONE + WORK( 2*N ) = CZERO + WORK( 4*N ) = CTEMP / ABS( CTEMP ) +* +* Apply the diagonal matrices +* + DO 70 JC = 1, N + DO 60 JR = 1, N + A( JR, JC ) = WORK( 2*N+JR )* + $ DCONJG( WORK( 3*N+JC ) )* + $ A( JR, JC ) + B( JR, JC ) = WORK( 2*N+JR )* + $ DCONJG( WORK( 3*N+JC ) )* + $ B( JR, JC ) + 60 CONTINUE + 70 CONTINUE + CALL ZUNM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, A, + $ LDA, WORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) + $ GO TO 100 + CALL ZUNM2R( 'R', 'C', N, N, N-1, Z, LDQ, WORK( N+1 ), + $ A, LDA, WORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) + $ GO TO 100 + CALL ZUNM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, B, + $ LDA, WORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) + $ GO TO 100 + CALL ZUNM2R( 'R', 'C', N, N, N-1, Z, LDQ, WORK( N+1 ), + $ B, LDA, WORK( 2*N+1 ), IINFO ) + IF( IINFO.NE.0 ) + $ GO TO 100 + END IF + ELSE +* +* Random matrices +* + DO 90 JC = 1, N + DO 80 JR = 1, N + A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )* + $ ZLARND( 4, ISEED ) + B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )* + $ ZLARND( 4, ISEED ) + 80 CONTINUE + 90 CONTINUE + END IF +* + 100 CONTINUE +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 110 CONTINUE +* + DO 120 I = 1, 13 + RESULT( I ) = -ONE + 120 CONTINUE +* +* Test with and without sorting of eigenvalues +* + DO 150 ISORT = 0, 1 + IF( ISORT.EQ.0 ) THEN + SORT = 'N' + RSUB = 0 + ELSE + SORT = 'S' + RSUB = 5 + END IF +* +* Call ZGGES3 to compute H, T, Q, Z, alpha, and beta. +* + CALL ZLACPY( 'Full', N, N, A, LDA, S, LDA ) + CALL ZLACPY( 'Full', N, N, B, LDA, T, LDA ) + NTEST = 1 + RSUB + ISORT + RESULT( 1+RSUB+ISORT ) = ULPINV + CALL ZGGES3( 'V', 'V', SORT, ZLCTES, N, S, LDA, T, LDA, + $ SDIM, ALPHA, BETA, Q, LDQ, Z, LDQ, WORK, + $ LWORK, RWORK, BWORK, IINFO ) + IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN + RESULT( 1+RSUB+ISORT ) = ULPINV + WRITE( NOUNIT, FMT = 9999 )'ZGGES3', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + GO TO 160 + END IF +* + NTEST = 4 + RSUB +* +* Do tests 1--4 (or tests 7--9 when reordering ) +* + IF( ISORT.EQ.0 ) THEN + CALL ZGET51( 1, N, A, LDA, S, LDA, Q, LDQ, Z, LDQ, + $ WORK, RWORK, RESULT( 1 ) ) + CALL ZGET51( 1, N, B, LDA, T, LDA, Q, LDQ, Z, LDQ, + $ WORK, RWORK, RESULT( 2 ) ) + ELSE + CALL ZGET54( N, A, LDA, B, LDA, S, LDA, T, LDA, Q, + $ LDQ, Z, LDQ, WORK, RESULT( 2+RSUB ) ) + END IF +* + CALL ZGET51( 3, N, B, LDA, T, LDA, Q, LDQ, Q, LDQ, WORK, + $ RWORK, RESULT( 3+RSUB ) ) + CALL ZGET51( 3, N, B, LDA, T, LDA, Z, LDQ, Z, LDQ, WORK, + $ RWORK, RESULT( 4+RSUB ) ) +* +* Do test 5 and 6 (or Tests 10 and 11 when reordering): +* check Schur form of A and compare eigenvalues with +* diagonals. +* + NTEST = 6 + RSUB + TEMP1 = ZERO +* + DO 130 J = 1, N + ILABAD = .FALSE. + TEMP2 = ( ABS1( ALPHA( J )-S( J, J ) ) / + $ MAX( SAFMIN, ABS1( ALPHA( J ) ), ABS1( S( J, + $ J ) ) )+ABS1( BETA( J )-T( J, J ) ) / + $ MAX( SAFMIN, ABS1( BETA( J ) ), ABS1( T( J, + $ J ) ) ) ) / ULP +* + IF( J.LT.N ) THEN + IF( S( J+1, J ).NE.ZERO ) THEN + ILABAD = .TRUE. + RESULT( 5+RSUB ) = ULPINV + END IF + END IF + IF( J.GT.1 ) THEN + IF( S( J, J-1 ).NE.ZERO ) THEN + ILABAD = .TRUE. + RESULT( 5+RSUB ) = ULPINV + END IF + END IF + TEMP1 = MAX( TEMP1, TEMP2 ) + IF( ILABAD ) THEN + WRITE( NOUNIT, FMT = 9998 )J, N, JTYPE, IOLDSD + END IF + 130 CONTINUE + RESULT( 6+RSUB ) = TEMP1 +* + IF( ISORT.GE.1 ) THEN +* +* Do test 12 +* + NTEST = 12 + RESULT( 12 ) = ZERO + KNTEIG = 0 + DO 140 I = 1, N + IF( ZLCTES( ALPHA( I ), BETA( I ) ) ) + $ KNTEIG = KNTEIG + 1 + 140 CONTINUE + IF( SDIM.NE.KNTEIG ) + $ RESULT( 13 ) = ULPINV + END IF +* + 150 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + 160 CONTINUE +* + NTESTT = NTESTT + NTEST +* +* Print out tests which fail. +* + DO 170 JR = 1, NTEST + IF( RESULT( JR ).GE.THRESH ) THEN +* +* If this is the first test to fail, +* print a header to the data file. +* + IF( NERRS.EQ.0 ) THEN + WRITE( NOUNIT, FMT = 9997 )'ZGS' +* +* Matrix types +* + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 ) + WRITE( NOUNIT, FMT = 9994 )'Unitary' +* +* Tests performed +* + WRITE( NOUNIT, FMT = 9993 )'unitary', '''', + $ 'transpose', ( '''', J = 1, 8 ) +* + END IF + NERRS = NERRS + 1 + IF( RESULT( JR ).LT.10000.0D0 ) THEN + WRITE( NOUNIT, FMT = 9992 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + ELSE + WRITE( NOUNIT, FMT = 9991 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + END IF + END IF + 170 CONTINUE +* + 180 CONTINUE + 190 CONTINUE +* +* Summary +* + CALL ALASVM( 'ZGS', NOUNIT, NERRS, NTESTT, 0 ) +* + WORK( 1 ) = MAXWRK +* + RETURN +* + 9999 FORMAT( ' ZDRGES3: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', + $ I6, ', JTYPE=', I6, ', ISEED=(', 4( I4, ',' ), I5, ')' ) +* + 9998 FORMAT( ' ZDRGES3: S not in Schur form at eigenvalue ', I6, '.', + $ / 9X, 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), + $ I5, ')' ) +* + 9997 FORMAT( / 1X, A3, ' -- Complex Generalized Schur from problem ', + $ 'driver' ) +* + 9996 FORMAT( ' Matrix types (see ZDRGES3 for details): ' ) +* + 9995 FORMAT( ' Special Matrices:', 23X, + $ '(J''=transposed Jordan block)', + $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ', + $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ', + $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I', + $ ') 11=(large*I, small*D) 13=(large*D, large*I)', / + $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ', + $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' ) + 9994 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:', + $ / ' 16=Transposed Jordan Blocks 19=geometric ', + $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ', + $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ', + $ 'alpha, beta=0,1 21=random alpha, beta=0,1', + $ / ' Large & Small Matrices:', / ' 22=(large, small) ', + $ '23=(small,large) 24=(small,small) 25=(large,large)', + $ / ' 26=random O(1) matrices.' ) +* + 9993 FORMAT( / ' Tests performed: (S is Schur, T is triangular, ', + $ 'Q and Z are ', A, ',', / 19X, + $ 'l and r are the appropriate left and right', / 19X, + $ 'eigenvectors, resp., a is alpha, b is beta, and', / 19X, A, + $ ' means ', A, '.)', / ' Without ordering: ', + $ / ' 1 = | A - Q S Z', A, + $ ' | / ( |A| n ulp ) 2 = | B - Q T Z', A, + $ ' | / ( |B| n ulp )', / ' 3 = | I - QQ', A, + $ ' | / ( n ulp ) 4 = | I - ZZ', A, + $ ' | / ( n ulp )', / ' 5 = A is in Schur form S', + $ / ' 6 = difference between (alpha,beta)', + $ ' and diagonals of (S,T)', / ' With ordering: ', + $ / ' 7 = | (A,B) - Q (S,T) Z', A, ' | / ( |(A,B)| n ulp )', + $ / ' 8 = | I - QQ', A, + $ ' | / ( n ulp ) 9 = | I - ZZ', A, + $ ' | / ( n ulp )', / ' 10 = A is in Schur form S', + $ / ' 11 = difference between (alpha,beta) and diagonals', + $ ' of (S,T)', / ' 12 = SDIM is the correct number of ', + $ 'selected eigenvalues', / ) + 9992 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I2, ' is', 0P, F8.2 ) + 9991 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I2, ' is', 1P, D10.3 ) +* +* End of ZDRGES3 +* + END diff --git a/TESTING/EIG/zdrgev3.f b/TESTING/EIG/zdrgev3.f new file mode 100644 index 0000000..198bf33 --- /dev/null +++ b/TESTING/EIG/zdrgev3.f @@ -0,0 +1,939 @@ +*> \brief \b ZDRGEV3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZDRGEV3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, QE, LDQE, +* ALPHA, BETA, ALPHA1, BETA1, WORK, LWORK, RWORK, +* RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDQ, LDQE, LWORK, NOUNIT, NSIZES, +* $ NTYPES +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), NN( * ) +* DOUBLE PRECISION RESULT( * ), RWORK( * ) +* COMPLEX*16 A( LDA, * ), ALPHA( * ), ALPHA1( * ), +* $ B( LDA, * ), BETA( * ), BETA1( * ), +* $ Q( LDQ, * ), QE( LDQE, * ), S( LDA, * ), +* $ T( LDA, * ), WORK( * ), Z( LDQ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDRGEV3 checks the nonsymmetric generalized eigenvalue problem driver +*> routine ZGGEV3. +*> +*> ZGGEV3 computes for a pair of n-by-n nonsymmetric matrices (A,B) the +*> generalized eigenvalues and, optionally, the left and right +*> eigenvectors. +*> +*> A generalized eigenvalue for a pair of matrices (A,B) is a scalar w +*> or a ratio alpha/beta = w, such that A - w*B is singular. It is +*> usually represented as the pair (alpha,beta), as there is reasonable +*> interpretation for beta=0, and even for both being zero. +*> +*> A right generalized eigenvector corresponding to a generalized +*> eigenvalue w for a pair of matrices (A,B) is a vector r such that +*> (A - wB) * r = 0. A left generalized eigenvector is a vector l such +*> that l**H * (A - wB) = 0, where l**H is the conjugate-transpose of l. +*> +*> When ZDRGEV3 is called, a number of matrix "sizes" ("n's") and a +*> number of matrix "types" are specified. For each size ("n") +*> and each type of matrix, a pair of matrices (A, B) will be generated +*> and used for testing. For each matrix pair, the following tests +*> will be performed and compared with the threshhold THRESH. +*> +*> Results from ZGGEV3: +*> +*> (1) max over all left eigenvalue/-vector pairs (alpha/beta,l) of +*> +*> | VL**H * (beta A - alpha B) |/( ulp max(|beta A|, |alpha B|) ) +*> +*> where VL**H is the conjugate-transpose of VL. +*> +*> (2) | |VL(i)| - 1 | / ulp and whether largest component real +*> +*> VL(i) denotes the i-th column of VL. +*> +*> (3) max over all left eigenvalue/-vector pairs (alpha/beta,r) of +*> +*> | (beta A - alpha B) * VR | / ( ulp max(|beta A|, |alpha B|) ) +*> +*> (4) | |VR(i)| - 1 | / ulp and whether largest component real +*> +*> VR(i) denotes the i-th column of VR. +*> +*> (5) W(full) = W(partial) +*> W(full) denotes the eigenvalues computed when both l and r +*> are also computed, and W(partial) denotes the eigenvalues +*> computed when only W, only W and r, or only W and l are +*> computed. +*> +*> (6) VL(full) = VL(partial) +*> VL(full) denotes the left eigenvectors computed when both l +*> and r are computed, and VL(partial) denotes the result +*> when only l is computed. +*> +*> (7) VR(full) = VR(partial) +*> VR(full) denotes the right eigenvectors computed when both l +*> and r are also computed, and VR(partial) denotes the result +*> when only l is computed. +*> +*> +*> Test Matrices +*> ---- -------- +*> +*> The sizes of the test matrices are specified by an array +*> NN(1:NSIZES); the value of each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if +*> DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) ( 0, 0 ) (a pair of zero matrices) +*> +*> (2) ( I, 0 ) (an identity and a zero matrix) +*> +*> (3) ( 0, I ) (an identity and a zero matrix) +*> +*> (4) ( I, I ) (a pair of identity matrices) +*> +*> t t +*> (5) ( J , J ) (a pair of transposed Jordan blocks) +*> +*> t ( I 0 ) +*> (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) +*> ( 0 I ) ( 0 J ) +*> and I is a k x k identity and J a (k+1)x(k+1) +*> Jordan block; k=(N-1)/2 +*> +*> (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal +*> matrix with those diagonal entries.) +*> (8) ( I, D ) +*> +*> (9) ( big*D, small*I ) where "big" is near overflow and small=1/big +*> +*> (10) ( small*D, big*I ) +*> +*> (11) ( big*I, small*D ) +*> +*> (12) ( small*I, big*D ) +*> +*> (13) ( big*D, big*I ) +*> +*> (14) ( small*D, small*I ) +*> +*> (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and +*> D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) +*> t t +*> (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. +*> +*> (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices +*> with random O(1) entries above the diagonal +*> and diagonal entries diag(T1) = +*> ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = +*> ( 0, N-3, N-4,..., 1, 0, 0 ) +*> +*> (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) +*> s = machine precision. +*> +*> (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) +*> +*> N-5 +*> (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) +*> +*> (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) +*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) +*> where r1,..., r(N-4) are random. +*> +*> (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) +*> diag(T2) = ( 0, 1, ..., 1, 0, 0 ) +*> +*> (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular +*> matrices. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> ZDRGEV3 does nothing. NSIZES >= 0. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. NN >= 0. +*> \endverbatim +*> +*> \param[in] NTYPES +*> \verbatim +*> NTYPES is INTEGER +*> The number of elements in DOTYPE. If it is zero, ZDRGEV3 +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> \endverbatim +*> +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> \endverbatim +*> +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to ZDRGES to continue the same random number +*> sequence. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error is +*> scaled to be O(1), so THRESH should be a reasonably small +*> multiple of 1, e.g., 10 or 100. In particular, it should +*> not depend on the precision (single vs. double) or the size +*> of the matrix. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NOUNIT +*> \verbatim +*> NOUNIT is INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IERR not equal to 0.) +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension(LDA, max(NN)) +*> Used to hold the original A matrix. Used as input only +*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and +*> DOTYPE(MAXTYP+1)=.TRUE. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A, B, S, and T. +*> It must be at least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension(LDA, max(NN)) +*> Used to hold the original B matrix. Used as input only +*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and +*> DOTYPE(MAXTYP+1)=.TRUE. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is COMPLEX*16 array, dimension (LDA, max(NN)) +*> The Schur form matrix computed from A by ZGGEV3. On exit, S +*> contains the Schur form matrix corresponding to the matrix +*> in A. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX*16 array, dimension (LDA, max(NN)) +*> The upper triangular matrix computed from B by ZGGEV3. +*> \endverbatim +*> +*> \param[out] Q +*> \verbatim +*> Q is COMPLEX*16 array, dimension (LDQ, max(NN)) +*> The (left) eigenvectors matrix computed by ZGGEV3. +*> \endverbatim +*> +*> \param[in] LDQ +*> \verbatim +*> LDQ is INTEGER +*> The leading dimension of Q and Z. It must +*> be at least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is COMPLEX*16 array, dimension( LDQ, max(NN) ) +*> The (right) orthogonal matrix computed by ZGGEV3. +*> \endverbatim +*> +*> \param[out] QE +*> \verbatim +*> QE is COMPLEX*16 array, dimension( LDQ, max(NN) ) +*> QE holds the computed right or left eigenvectors. +*> \endverbatim +*> +*> \param[in] LDQE +*> \verbatim +*> LDQE is INTEGER +*> The leading dimension of QE. LDQE >= max(1,max(NN)). +*> \endverbatim +*> +*> \param[out] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 array, dimension (max(NN)) +*> \endverbatim +*> +*> \param[out] BETA +*> \verbatim +*> BETA is COMPLEX*16 array, dimension (max(NN)) +*> +*> The generalized eigenvalues of (A,B) computed by ZGGEV3. +*> ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th +*> generalized eigenvalue of A and B. +*> \endverbatim +*> +*> \param[out] ALPHA1 +*> \verbatim +*> ALPHA1 is COMPLEX*16 array, dimension (max(NN)) +*> \endverbatim +*> +*> \param[out] BETA1 +*> \verbatim +*> BETA1 is COMPLEX*16 array, dimension (max(NN)) +*> +*> Like ALPHAR, ALPHAI, BETA, these arrays contain the +*> eigenvalues of A and B, but those computed when ZGGEV3 only +*> computes a partial eigendecomposition, i.e. not the +*> eigenvalues and left and right eigenvectors. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The number of entries in WORK. LWORK >= N*(N+1) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (8*N) +*> Real workspace. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (2) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid overflow. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: A routine returned an error code. INFO is the +*> absolute value of the INFO value returned. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date Febuary 2015 +* +*> \ingroup complex16_eig +* +* ===================================================================== + SUBROUTINE ZDRGEV3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, QE, LDQE, + $ ALPHA, BETA, ALPHA1, BETA1, WORK, LWORK, + $ RWORK, RESULT, INFO ) +* +* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* February 2015 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDQ, LDQE, LWORK, NOUNIT, NSIZES, + $ NTYPES + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), NN( * ) + DOUBLE PRECISION RESULT( * ), RWORK( * ) + COMPLEX*16 A( LDA, * ), ALPHA( * ), ALPHA1( * ), + $ B( LDA, * ), BETA( * ), BETA1( * ), + $ Q( LDQ, * ), QE( LDQE, * ), S( LDA, * ), + $ T( LDA, * ), WORK( * ), Z( LDQ, * ) +* .. +* +* ===================================================================== +* +* .. 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 ) ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 26 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + INTEGER I, IADD, IERR, IN, J, JC, JR, JSIZE, JTYPE, + $ MAXWRK, MINWRK, MTYPES, N, N1, NB, NERRS, + $ NMATS, NMAX, NTESTT + DOUBLE PRECISION SAFMAX, SAFMIN, ULP, ULPINV + COMPLEX*16 CTEMP +* .. +* .. Local Arrays .. + LOGICAL LASIGN( MAXTYP ), LBSIGN( MAXTYP ) + INTEGER IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ), + $ KATYPE( MAXTYP ), KAZERO( MAXTYP ), + $ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ), + $ KBZERO( MAXTYP ), KCLASS( MAXTYP ), + $ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 ) + DOUBLE PRECISION RMAGN( 0: 3 ) +* .. +* .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DLAMCH + COMPLEX*16 ZLARND + EXTERNAL ILAENV, DLAMCH, ZLARND +* .. +* .. External Subroutines .. + EXTERNAL ALASVM, DLABAD, XERBLA, ZGET52, ZGGEV3, ZLACPY, + $ ZLARFG, ZLASET, ZLATM4, ZUNM2R +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, MAX, MIN, SIGN +* .. +* .. Data statements .. + DATA KCLASS / 15*1, 10*2, 1*3 / + DATA KZ1 / 0, 1, 2, 1, 3, 3 / + DATA KZ2 / 0, 0, 1, 2, 1, 1 / + DATA KADD / 0, 0, 0, 0, 3, 2 / + DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4, + $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 / + DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4, + $ 1, 1, -4, 2, -4, 8*8, 0 / + DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3, + $ 4*5, 4*3, 1 / + DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4, + $ 4*6, 4*4, 1 / + DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3, + $ 2, 1 / + DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3, + $ 2, 1 / + DATA KTRIAN / 16*0, 10*1 / + DATA LASIGN / 6*.FALSE., .TRUE., .FALSE., 2*.TRUE., + $ 2*.FALSE., 3*.TRUE., .FALSE., .TRUE., + $ 3*.FALSE., 5*.TRUE., .FALSE. / + DATA LBSIGN / 7*.FALSE., .TRUE., 2*.FALSE., + $ 2*.TRUE., 2*.FALSE., .TRUE., .FALSE., .TRUE., + $ 9*.FALSE. / +* .. +* .. Executable Statements .. +* +* Check for errors +* + INFO = 0 +* + BADNN = .FALSE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( THRESH.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDQ.LE.1 .OR. LDQ.LT.NMAX ) THEN + INFO = -14 + ELSE IF( LDQE.LE.1 .OR. LDQE.LT.NMAX ) THEN + INFO = -17 + END IF +* +* Compute workspace +* (Note: Comments in the code beginning "Workspace:" describe the +* minimal amount of workspace needed at that point in the code, +* as well as the preferred amount for good performance. +* NB refers to the optimal block size for the immediately +* following subroutine, as returned by ILAENV. +* + MINWRK = 1 + IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN + MINWRK = NMAX*( NMAX+1 ) + NB = MAX( 1, ILAENV( 1, 'ZGEQRF', ' ', NMAX, NMAX, -1, -1 ), + $ ILAENV( 1, 'ZUNMQR', 'LC', NMAX, NMAX, NMAX, -1 ), + $ ILAENV( 1, 'ZUNGQR', ' ', NMAX, NMAX, NMAX, -1 ) ) + MAXWRK = MAX( 2*NMAX, NMAX*( NB+1 ), NMAX*( NMAX+1 ) ) + WORK( 1 ) = MAXWRK + END IF +* + IF( LWORK.LT.MINWRK ) + $ INFO = -23 +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZDRGEV3', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* + ULP = DLAMCH( 'Precision' ) + SAFMIN = DLAMCH( 'Safe minimum' ) + SAFMIN = SAFMIN / ULP + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULPINV = ONE / ULP +* +* The values RMAGN(2:3) depend on N, see below. +* + RMAGN( 0 ) = ZERO + RMAGN( 1 ) = ONE +* +* Loop over sizes, types +* + NTESTT = 0 + NERRS = 0 + NMATS = 0 +* + DO 220 JSIZE = 1, NSIZES + N = NN( JSIZE ) + N1 = MAX( 1, N ) + RMAGN( 2 ) = SAFMAX*ULP / DBLE( N1 ) + RMAGN( 3 ) = SAFMIN*ULPINV*N1 +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 210 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 210 + NMATS = NMATS + 1 +* +* Save ISEED in case of an error. +* + DO 20 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 20 CONTINUE +* +* Generate test matrices A and B +* +* Description of control parameters: +* +* KZLASS: =1 means w/o rotation, =2 means w/ rotation, +* =3 means random. +* KATYPE: the "type" to be passed to ZLATM4 for computing A. +* KAZERO: the pattern of zeros on the diagonal for A: +* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), +* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), +* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of +* non-zero entries.) +* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), +* =2: large, =3: small. +* LASIGN: .TRUE. if the diagonal elements of A are to be +* multiplied by a random magnitude 1 number. +* KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B. +* KTRIAN: =0: don't fill in the upper triangle, =1: do. +* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. +* RMAGN: used to implement KAMAGN and KBMAGN. +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 100 + IERR = 0 + IF( KCLASS( JTYPE ).LT.3 ) THEN +* +* Generate A (w/o rotation) +* + IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN + IN = 2*( ( N-1 ) / 2 ) + 1 + IF( IN.NE.N ) + $ CALL ZLASET( 'Full', N, N, CZERO, CZERO, A, LDA ) + ELSE + IN = N + END IF + CALL ZLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ), + $ KZ2( KAZERO( JTYPE ) ), LASIGN( JTYPE ), + $ RMAGN( KAMAGN( JTYPE ) ), ULP, + $ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2, + $ ISEED, A, LDA ) + IADD = KADD( KAZERO( JTYPE ) ) + IF( IADD.GT.0 .AND. IADD.LE.N ) + $ A( IADD, IADD ) = RMAGN( KAMAGN( JTYPE ) ) +* +* Generate B (w/o rotation) +* + IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN + IN = 2*( ( N-1 ) / 2 ) + 1 + IF( IN.NE.N ) + $ CALL ZLASET( 'Full', N, N, CZERO, CZERO, B, LDA ) + ELSE + IN = N + END IF + CALL ZLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ), + $ KZ2( KBZERO( JTYPE ) ), LBSIGN( JTYPE ), + $ RMAGN( KBMAGN( JTYPE ) ), ONE, + $ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2, + $ ISEED, B, LDA ) + IADD = KADD( KBZERO( JTYPE ) ) + IF( IADD.NE.0 .AND. IADD.LE.N ) + $ B( IADD, IADD ) = RMAGN( KBMAGN( JTYPE ) ) +* + IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN +* +* Include rotations +* +* Generate Q, Z as Householder transformations times +* a diagonal matrix. +* + DO 40 JC = 1, N - 1 + DO 30 JR = JC, N + Q( JR, JC ) = ZLARND( 3, ISEED ) + Z( JR, JC ) = ZLARND( 3, ISEED ) + 30 CONTINUE + CALL ZLARFG( N+1-JC, Q( JC, JC ), Q( JC+1, JC ), 1, + $ WORK( JC ) ) + WORK( 2*N+JC ) = SIGN( ONE, DBLE( Q( JC, JC ) ) ) + Q( JC, JC ) = CONE + CALL ZLARFG( N+1-JC, Z( JC, JC ), Z( JC+1, JC ), 1, + $ WORK( N+JC ) ) + WORK( 3*N+JC ) = SIGN( ONE, DBLE( Z( JC, JC ) ) ) + Z( JC, JC ) = CONE + 40 CONTINUE + CTEMP = ZLARND( 3, ISEED ) + Q( N, N ) = CONE + WORK( N ) = CZERO + WORK( 3*N ) = CTEMP / ABS( CTEMP ) + CTEMP = ZLARND( 3, ISEED ) + Z( N, N ) = CONE + WORK( 2*N ) = CZERO + WORK( 4*N ) = CTEMP / ABS( CTEMP ) +* +* Apply the diagonal matrices +* + DO 60 JC = 1, N + DO 50 JR = 1, N + A( JR, JC ) = WORK( 2*N+JR )* + $ DCONJG( WORK( 3*N+JC ) )* + $ A( JR, JC ) + B( JR, JC ) = WORK( 2*N+JR )* + $ DCONJG( WORK( 3*N+JC ) )* + $ B( JR, JC ) + 50 CONTINUE + 60 CONTINUE + CALL ZUNM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, A, + $ LDA, WORK( 2*N+1 ), IERR ) + IF( IERR.NE.0 ) + $ GO TO 90 + CALL ZUNM2R( 'R', 'C', N, N, N-1, Z, LDQ, WORK( N+1 ), + $ A, LDA, WORK( 2*N+1 ), IERR ) + IF( IERR.NE.0 ) + $ GO TO 90 + CALL ZUNM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, B, + $ LDA, WORK( 2*N+1 ), IERR ) + IF( IERR.NE.0 ) + $ GO TO 90 + CALL ZUNM2R( 'R', 'C', N, N, N-1, Z, LDQ, WORK( N+1 ), + $ B, LDA, WORK( 2*N+1 ), IERR ) + IF( IERR.NE.0 ) + $ GO TO 90 + END IF + ELSE +* +* Random matrices +* + DO 80 JC = 1, N + DO 70 JR = 1, N + A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )* + $ ZLARND( 4, ISEED ) + B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )* + $ ZLARND( 4, ISEED ) + 70 CONTINUE + 80 CONTINUE + END IF +* + 90 CONTINUE +* + IF( IERR.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IERR, N, JTYPE, + $ IOLDSD + INFO = ABS( IERR ) + RETURN + END IF +* + 100 CONTINUE +* + DO 110 I = 1, 7 + RESULT( I ) = -ONE + 110 CONTINUE +* +* Call ZGGEV3 to compute eigenvalues and eigenvectors. +* + CALL ZLACPY( ' ', N, N, A, LDA, S, LDA ) + CALL ZLACPY( ' ', N, N, B, LDA, T, LDA ) + CALL ZGGEV3( 'V', 'V', N, S, LDA, T, LDA, ALPHA, BETA, Q, + $ LDQ, Z, LDQ, WORK, LWORK, RWORK, IERR ) + IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN + RESULT( 1 ) = ULPINV + WRITE( NOUNIT, FMT = 9999 )'ZGGEV31', IERR, N, JTYPE, + $ IOLDSD + INFO = ABS( IERR ) + GO TO 190 + END IF +* +* Do the tests (1) and (2) +* + CALL ZGET52( .TRUE., N, A, LDA, B, LDA, Q, LDQ, ALPHA, BETA, + $ WORK, RWORK, RESULT( 1 ) ) + IF( RESULT( 2 ).GT.THRESH ) THEN + WRITE( NOUNIT, FMT = 9998 )'Left', 'ZGGEV31', + $ RESULT( 2 ), N, JTYPE, IOLDSD + END IF +* +* Do the tests (3) and (4) +* + CALL ZGET52( .FALSE., N, A, LDA, B, LDA, Z, LDQ, ALPHA, + $ BETA, WORK, RWORK, RESULT( 3 ) ) + IF( RESULT( 4 ).GT.THRESH ) THEN + WRITE( NOUNIT, FMT = 9998 )'Right', 'ZGGEV31', + $ RESULT( 4 ), N, JTYPE, IOLDSD + END IF +* +* Do test (5) +* + CALL ZLACPY( ' ', N, N, A, LDA, S, LDA ) + CALL ZLACPY( ' ', N, N, B, LDA, T, LDA ) + CALL ZGGEV3( 'N', 'N', N, S, LDA, T, LDA, ALPHA1, BETA1, Q, + $ LDQ, Z, LDQ, WORK, LWORK, RWORK, IERR ) + IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN + RESULT( 1 ) = ULPINV + WRITE( NOUNIT, FMT = 9999 )'ZGGEV32', IERR, N, JTYPE, + $ IOLDSD + INFO = ABS( IERR ) + GO TO 190 + END IF +* + DO 120 J = 1, N + IF( ALPHA( J ).NE.ALPHA1( J ) .OR. BETA( J ).NE. + $ BETA1( J ) )RESULT( 5 ) = ULPINV + 120 CONTINUE +* +* Do test (6): Compute eigenvalues and left eigenvectors, +* and test them +* + CALL ZLACPY( ' ', N, N, A, LDA, S, LDA ) + CALL ZLACPY( ' ', N, N, B, LDA, T, LDA ) + CALL ZGGEV3( 'V', 'N', N, S, LDA, T, LDA, ALPHA1, BETA1, QE, + $ LDQE, Z, LDQ, WORK, LWORK, RWORK, IERR ) + IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN + RESULT( 1 ) = ULPINV + WRITE( NOUNIT, FMT = 9999 )'ZGGEV33', IERR, N, JTYPE, + $ IOLDSD + INFO = ABS( IERR ) + GO TO 190 + END IF +* + DO 130 J = 1, N + IF( ALPHA( J ).NE.ALPHA1( J ) .OR. BETA( J ).NE. + $ BETA1( J ) )RESULT( 6 ) = ULPINV + 130 CONTINUE +* + DO 150 J = 1, N + DO 140 JC = 1, N + IF( Q( J, JC ).NE.QE( J, JC ) ) + $ RESULT( 6 ) = ULPINV + 140 CONTINUE + 150 CONTINUE +* +* Do test (7): Compute eigenvalues and right eigenvectors, +* and test them +* + CALL ZLACPY( ' ', N, N, A, LDA, S, LDA ) + CALL ZLACPY( ' ', N, N, B, LDA, T, LDA ) + CALL ZGGEV3( 'N', 'V', N, S, LDA, T, LDA, ALPHA1, BETA1, Q, + $ LDQ, QE, LDQE, WORK, LWORK, RWORK, IERR ) + IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN + RESULT( 1 ) = ULPINV + WRITE( NOUNIT, FMT = 9999 )'ZGGEV34', IERR, N, JTYPE, + $ IOLDSD + INFO = ABS( IERR ) + GO TO 190 + END IF +* + DO 160 J = 1, N + IF( ALPHA( J ).NE.ALPHA1( J ) .OR. BETA( J ).NE. + $ BETA1( J ) )RESULT( 7 ) = ULPINV + 160 CONTINUE +* + DO 180 J = 1, N + DO 170 JC = 1, N + IF( Z( J, JC ).NE.QE( J, JC ) ) + $ RESULT( 7 ) = ULPINV + 170 CONTINUE + 180 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + 190 CONTINUE +* + NTESTT = NTESTT + 7 +* +* Print out tests which fail. +* + DO 200 JR = 1, 7 + IF( RESULT( JR ).GE.THRESH ) THEN +* +* If this is the first test to fail, +* print a header to the data file. +* + IF( NERRS.EQ.0 ) THEN + WRITE( NOUNIT, FMT = 9997 )'ZGV' +* +* Matrix types +* + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 ) + WRITE( NOUNIT, FMT = 9994 )'Orthogonal' +* +* Tests performed +* + WRITE( NOUNIT, FMT = 9993 ) +* + END IF + NERRS = NERRS + 1 + IF( RESULT( JR ).LT.10000.0D0 ) THEN + WRITE( NOUNIT, FMT = 9992 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + ELSE + WRITE( NOUNIT, FMT = 9991 )N, JTYPE, IOLDSD, JR, + $ RESULT( JR ) + END IF + END IF + 200 CONTINUE +* + 210 CONTINUE + 220 CONTINUE +* +* Summary +* + CALL ALASVM( 'ZGV3', NOUNIT, NERRS, NTESTT, 0 ) +* + WORK( 1 ) = MAXWRK +* + RETURN +* + 9999 FORMAT( ' ZDRGEV3: ', A, ' returned INFO=', I6, '.', / 3X, 'N=', + $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* + 9998 FORMAT( ' ZDRGEV3: ', A, ' Eigenvectors from ', A, ' incorrectly ', + $ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 3X, + $ 'N=', I4, ', JTYPE=', I3, ', ISEED=(', 3( I4, ',' ), I5, + $ ')' ) +* + 9997 FORMAT( / 1X, A3, ' -- Complex Generalized eigenvalue problem ', + $ 'driver' ) +* + 9996 FORMAT( ' Matrix types (see ZDRGEV3 for details): ' ) +* + 9995 FORMAT( ' Special Matrices:', 23X, + $ '(J''=transposed Jordan block)', + $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ', + $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ', + $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I', + $ ') 11=(large*I, small*D) 13=(large*D, large*I)', / + $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ', + $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' ) + 9994 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:', + $ / ' 16=Transposed Jordan Blocks 19=geometric ', + $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ', + $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ', + $ 'alpha, beta=0,1 21=random alpha, beta=0,1', + $ / ' Large & Small Matrices:', / ' 22=(large, small) ', + $ '23=(small,large) 24=(small,small) 25=(large,large)', + $ / ' 26=random O(1) matrices.' ) +* + 9993 FORMAT( / ' Tests performed: ', + $ / ' 1 = max | ( b A - a B )''*l | / const.,', + $ / ' 2 = | |VR(i)| - 1 | / ulp,', + $ / ' 3 = max | ( b A - a B )*r | / const.', + $ / ' 4 = | |VL(i)| - 1 | / ulp,', + $ / ' 5 = 0 if W same no matter if r or l computed,', + $ / ' 6 = 0 if l same no matter if l computed,', + $ / ' 7 = 0 if r same no matter if r computed,', / 1X ) + 9992 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I2, ' is', 0P, F8.2 ) + 9991 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', + $ 4( I4, ',' ), ' result ', I2, ' is', 1P, D10.3 ) +* +* End of ZDRGEV3 +* + END diff --git a/TESTING/EIG/zerrgg.f b/TESTING/EIG/zerrgg.f index a3f116a..5ed7ee6 100644 --- a/TESTING/EIG/zerrgg.f +++ b/TESTING/EIG/zerrgg.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 ZERRGG( PATH, NUNIT ) -* +* * .. Scalar Arguments .. * CHARACTER*3 PATH * INTEGER NUNIT * .. -* +* * *> \par Purpose: * ============= @@ -22,8 +22,9 @@ *> \verbatim *> *> ZERRGG tests the error exits for ZGGES, ZGGESX, ZGGEV, ZGGEVX, -*> ZGGGLM, ZGGHRD, ZGGLSE, ZGGQRF, ZGGRQF, ZGGSVD, ZGGSVP, ZHGEQZ, -*> ZTGEVC, ZTGEXC, ZTGSEN, ZTGSJA, ZTGSNA, ZTGSYL, and ZUNCSD. +*> ZGGES3, ZGGEV3, ZGGGLM, ZGGHRD, ZGGLSE, ZGGQRF, ZGGRQF, ZGGSVD, +*> ZGGSVP, ZHGEQZ, ZTGEVC, ZTGEXC, ZTGSEN, ZTGSJA, ZTGSNA, ZTGSYL, +*> and ZUNCSD. *> \endverbatim * * Arguments: @@ -44,10 +45,10 @@ * 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 * @@ -95,10 +96,10 @@ EXTERNAL LSAMEN, ZLCTES, ZLCTSX * .. * .. External Subroutines .. - EXTERNAL CHKXER, ZGGES, ZGGESX, ZGGEV, ZGGEVX, ZGGGLM, + EXTERNAL CHKXER, ZGGES, ZGGESX, ZGGEV, ZGGEVX, ZGGGLM, $ ZGGHRD, ZGGLSE, ZGGQRF, ZGGRQF, ZGGSVD, ZGGSVP, $ ZHGEQZ, ZTGEVC, ZTGEXC, ZTGSEN, ZTGSJA, ZTGSNA, - $ ZTGSYL, ZUNCSD + $ ZTGSYL, ZUNCSD, ZGGES3, ZGGEV3, ZGGHD3 * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -171,6 +172,47 @@ CALL CHKXER( 'ZGGHRD', INFOT, NOUT, LERR, OK ) NT = NT + 9 * +* ZGGHD3 +* + SRNAMT = 'ZGGHD3' + INFOT = 1 + CALL ZGGHD3( '/', 'N', 0, 1, 0, A, 1, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'ZGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGGHD3( 'N', '/', 0, 1, 0, A, 1, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'ZGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZGGHD3( 'N', 'N', -1, 0, 0, A, 1, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'ZGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGGHD3( 'N', 'N', 0, 0, 0, A, 1, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'ZGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGGHD3( 'N', 'N', 0, 1, 1, A, 1, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'ZGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZGGHD3( 'N', 'N', 2, 1, 1, A, 1, B, 2, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'ZGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZGGHD3( 'N', 'N', 2, 1, 1, A, 2, B, 1, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'ZGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZGGHD3( 'V', 'N', 2, 1, 1, A, 2, B, 2, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'ZGGHD3', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZGGHD3( 'N', 'V', 2, 1, 1, A, 2, B, 2, Q, 1, Z, 1, W, LW, + $ INFO ) + CALL CHKXER( 'ZGGHD3', INFOT, NOUT, LERR, OK ) + NT = NT + 9 +* * ZHGEQZ * SRNAMT = 'ZHGEQZ' @@ -520,56 +562,56 @@ $ -1, 0, 0, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, 1, A, - $ 1, W, LW, RW, LW, IW, INFO ) + $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'ZUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 8 CALL ZUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, -1, 0, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, 1, A, - $ 1, W, LW, RW, LW, IW, INFO ) + $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'ZUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, -1, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, 1, A, - $ 1, W, LW, RW, LW, IW, INFO ) + $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'ZUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, -1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, 1, A, - $ 1, W, LW, RW, LW, IW, INFO ) + $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'ZUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 20 CALL ZUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, $ 1, A, 1, A, 1, A, $ A, -1, A, 1, A, 1, A, - $ 1, W, LW, RW, LW, IW, INFO ) + $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'ZUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 22 CALL ZUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, -1, A, 1, A, - $ 1, W, LW, RW, LW, IW, INFO ) + $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'ZUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 24 CALL ZUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, -1, A, - $ 1, W, LW, RW, LW, IW, INFO ) + $ 1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'ZUNCSD', INFOT, NOUT, LERR, OK ) INFOT = 26 CALL ZUNCSD( 'Y', 'Y', 'Y', 'Y', 'N', 'N', $ 1, 1, 1, A, 1, A, $ 1, A, 1, A, 1, A, $ A, 1, A, 1, A, 1, A, - $ -1, W, LW, RW, LW, IW, INFO ) + $ -1, W, LW, RW, LW, IW, INFO ) CALL CHKXER( 'ZUNCSD', INFOT, NOUT, LERR, OK ) NT = NT + 8 * @@ -679,6 +721,55 @@ CALL CHKXER( 'ZGGES ', INFOT, NOUT, LERR, OK ) NT = NT + 11 * +* ZGGES3 +* + SRNAMT = 'ZGGES3' + INFOT = 1 + CALL ZGGES3( '/', 'N', 'S', ZLCTES, 1, A, 1, B, 1, SDIM, ALPHA, + $ BETA, Q, 1, U, 1, W, 1, RW, BW, INFO ) + CALL CHKXER( 'ZGGES3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGGES3( 'N', '/', 'S', ZLCTES, 1, A, 1, B, 1, SDIM, ALPHA, + $ BETA, Q, 1, U, 1, W, 1, RW, BW, INFO ) + CALL CHKXER( 'ZGGES3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZGGES3( 'N', 'V', '/', ZLCTES, 1, A, 1, B, 1, SDIM, ALPHA, + $ BETA, Q, 1, U, 1, W, 1, RW, BW, INFO ) + CALL CHKXER( 'ZGGES3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGGES3( 'N', 'V', 'S', ZLCTES, -1, A, 1, B, 1, SDIM, + $ ALPHA, BETA, Q, 1, U, 1, W, 1, RW, BW, INFO ) + CALL CHKXER( 'ZGGES3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZGGES3( 'N', 'V', 'S', ZLCTES, 1, A, 0, B, 1, SDIM, ALPHA, + $ BETA, Q, 1, U, 1, W, 1, RW, BW, INFO ) + CALL CHKXER( 'ZGGES3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZGGES3( 'N', 'V', 'S', ZLCTES, 1, A, 1, B, 0, SDIM, ALPHA, + $ BETA, Q, 1, U, 1, W, 1, RW, BW, INFO ) + CALL CHKXER( 'ZGGES3', INFOT, NOUT, LERR, OK ) + INFOT = 14 + CALL ZGGES3( 'N', 'V', 'S', ZLCTES, 1, A, 1, B, 1, SDIM, ALPHA, + $ BETA, Q, 0, U, 1, W, 1, RW, BW, INFO ) + CALL CHKXER( 'ZGGES3', INFOT, NOUT, LERR, OK ) + INFOT = 14 + CALL ZGGES3( 'V', 'V', 'S', ZLCTES, 2, A, 2, B, 2, SDIM, ALPHA, + $ BETA, Q, 1, U, 2, W, 1, RW, BW, INFO ) + CALL CHKXER( 'ZGGES3', INFOT, NOUT, LERR, OK ) + INFOT = 16 + CALL ZGGES3( 'N', 'V', 'S', ZLCTES, 1, A, 1, B, 1, SDIM, ALPHA, + $ BETA, Q, 1, U, 0, W, 1, RW, BW, INFO ) + CALL CHKXER( 'ZGGES3', INFOT, NOUT, LERR, OK ) + INFOT = 16 + CALL ZGGES3( 'V', 'V', 'S', ZLCTES, 2, A, 2, B, 2, SDIM, ALPHA, + $ BETA, Q, 2, U, 1, W, 1, RW, BW, INFO ) + CALL CHKXER( 'ZGGES3', INFOT, NOUT, LERR, OK ) + INFOT = 18 + CALL ZGGES3( 'V', 'V', 'S', ZLCTES, 2, A, 2, B, 2, SDIM, ALPHA, + $ BETA, Q, 2, U, 2, W, 1, RW, BW, INFO ) + CALL CHKXER( 'ZGGES3', INFOT, NOUT, LERR, OK ) + NT = NT + 11 +* * ZGGESX * SRNAMT = 'ZGGESX' @@ -794,6 +885,51 @@ CALL CHKXER( 'ZGGEV ', INFOT, NOUT, LERR, OK ) NT = NT + 10 * +* ZGGEV3 +* + SRNAMT = 'ZGGEV3' + INFOT = 1 + CALL ZGGEV3( '/', 'N', 1, A, 1, B, 1, ALPHA, BETA, Q, 1, U, 1, + $ W, 1, RW, INFO ) + CALL CHKXER( 'ZGGEV3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGGEV3( 'N', '/', 1, A, 1, B, 1, ALPHA, BETA, Q, 1, U, 1, + $ W, 1, RW, INFO ) + CALL CHKXER( 'ZGGEV3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZGGEV3( 'V', 'V', -1, A, 1, B, 1, ALPHA, BETA, Q, 1, U, 1, + $ W, 1, RW, INFO ) + CALL CHKXER( 'ZGGEV3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGGEV3( 'V', 'V', 1, A, 0, B, 1, ALPHA, BETA, Q, 1, U, 1, + $ W, 1, RW, INFO ) + CALL CHKXER( 'ZGGEV3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZGGEV3( 'V', 'V', 1, A, 1, B, 0, ALPHA, BETA, Q, 1, U, 1, + $ W, 1, RW, INFO ) + CALL CHKXER( 'ZGGEV3', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZGGEV3( 'N', 'V', 1, A, 1, B, 1, ALPHA, BETA, Q, 0, U, 1, + $ W, 1, RW, INFO ) + CALL CHKXER( 'ZGGEV3', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZGGEV3( 'V', 'V', 2, A, 2, B, 2, ALPHA, BETA, Q, 1, U, 2, + $ W, 1, RW, INFO ) + CALL CHKXER( 'ZGGEV3', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZGGEV3( 'V', 'N', 2, A, 2, B, 2, ALPHA, BETA, Q, 2, U, 0, + $ W, 1, RW, INFO ) + CALL CHKXER( 'ZGGEV3', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZGGEV3( 'V', 'V', 2, A, 2, B, 2, ALPHA, BETA, Q, 2, U, 1, + $ W, 1, RW, INFO ) + CALL CHKXER( 'ZGGEV3', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL ZGGEV3( 'V', 'V', 1, A, 1, B, 1, ALPHA, BETA, Q, 1, U, 1, + $ W, 1, RW, INFO ) + CALL CHKXER( 'ZGGEV3', INFOT, NOUT, LERR, OK ) + NT = NT + 10 +* * ZGGEVX * SRNAMT = 'ZGGEVX' diff --git a/TESTING/cgg.in b/TESTING/cgg.in index 8e44e45..790feed 100644 --- a/TESTING/cgg.in +++ b/TESTING/cgg.in @@ -1,15 +1,16 @@ CGG: Data file for testing Nonsymmetric Eigenvalue Problem routines -7 Number of values of N -0 1 2 3 5 10 16 Values of N (dimension) +7 Number of values of N +0 1 2 3 5 10 16 Values of N (dimension) 4 Number of parameter values 1 1 2 2 Values of NB (blocksize) 40 40 2 2 Values of NBMIN (minimum blocksize) 2 4 2 4 Values of NSHIFT (no. of shifts) 40 40 2 2 Values of MAXB (multishift crossover pt) +1 2 1 2 Values of IACC22 (struct. matrix mult.) 40 40 2 2 Values of NBCOL (minimum col. dimension) -20.0 Threshold value -T Put T to test the LAPACK routines -T Put T to test the driver routines -T Put T to test the error exits -1 Code to interpret the seed +20.0 Threshold value +T Put T to test the LAPACK routines +T Put T to test the driver routines +T Put T to test the error exits +1 Code to interpret the seed CGG 26 diff --git a/TESTING/dgg.in b/TESTING/dgg.in index fb83aac..fcc44c0 100644 --- a/TESTING/dgg.in +++ b/TESTING/dgg.in @@ -6,6 +6,7 @@ DGG: Data file for testing Nonsymmetric Eigenvalue Problem routines 40 40 2 2 Values of NBMIN (minimum blocksize) 2 4 2 4 Values of NSHIFT (no. of shifts) 40 40 2 2 Values of MAXB (multishift crossover pt) +1 2 1 2 Values of IACC22 (struct. matrix mult.) 40 40 2 2 Values of NBCOL (minimum col. dimension) 20.0 Threshold value T Put T to test the LAPACK routines diff --git a/TESTING/sgg.in b/TESTING/sgg.in index 367f961..162ba3e 100644 --- a/TESTING/sgg.in +++ b/TESTING/sgg.in @@ -6,6 +6,7 @@ SGG: Data file for testing Nonsymmetric Eigenvalue Problem routines 40 40 2 2 Values of NBMIN (minimum blocksize) 2 4 2 4 Values of NSHIFT (no. of shifts) 40 40 2 2 Values of MAXB (multishift crossover pt) +1 2 1 2 Values of IACC22 (struct. matrix mult.) 40 40 2 2 Values of NBCOL (minimum col. dimension) 20.0 Threshold value T Put T to test the LAPACK routines diff --git a/TESTING/zgg.in b/TESTING/zgg.in index 3937629..802e5dd 100644 --- a/TESTING/zgg.in +++ b/TESTING/zgg.in @@ -6,6 +6,7 @@ ZGG: Data file for testing Nonsymmetric Eigenvalue Problem routines 40 40 2 2 Values of NBMIN (minimum blocksize) 2 4 2 4 Values of NSHIFT (no. of shifts) 40 40 2 2 Values of MAXB (multishift crossover pt) +1 2 1 2 Values of IACC22 (struct. matrix mult.) 40 40 2 2 Values of NBCOL (minimum col. dimension) 20.0 Threshold value T Put T to test the LAPACK routines -- 2.7.4