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,
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,
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 );
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,
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,
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,
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,
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 );
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,
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,
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,
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,
#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)
#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)
#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)
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,
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,
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,
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
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
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
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
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 \
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 \
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 \
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 \
--- /dev/null
+/*****************************************************************************
+ 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;
+}
--- /dev/null
+/*****************************************************************************
+ 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;
+}
--- /dev/null
+/*****************************************************************************
+ 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;
+}
--- /dev/null
+/*****************************************************************************
+ 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;
+}
--- /dev/null
+/*****************************************************************************
+ 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;
+}
--- /dev/null
+/*****************************************************************************
+ 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;
+}
--- /dev/null
+/*****************************************************************************
+ 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;
+}
--- /dev/null
+/*****************************************************************************
+ 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;
+}
--- /dev/null
+/*****************************************************************************
+ 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;
+}
--- /dev/null
+/*****************************************************************************
+ 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;
+}
--- /dev/null
+/*****************************************************************************
+ 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;
+}
--- /dev/null
+/*****************************************************************************
+ 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;
+}
--- /dev/null
+/*****************************************************************************
+ 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;
+}
--- /dev/null
+/*****************************************************************************
+ 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;
+}
--- /dev/null
+/*****************************************************************************
+ 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;
+}
--- /dev/null
+/*****************************************************************************
+ 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;
+}
--- /dev/null
+/*****************************************************************************
+ 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;
+}
--- /dev/null
+/*****************************************************************************
+ 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;
+}
--- /dev/null
+/*****************************************************************************
+ 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;
+}
--- /dev/null
+/*****************************************************************************
+ 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;
+}
--- /dev/null
+/*****************************************************************************
+ 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;
+}
--- /dev/null
+/*****************************************************************************
+ 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;
+}
--- /dev/null
+/*****************************************************************************
+ 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;
+}
--- /dev/null
+/*****************************************************************************
+ 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;
+}
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
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
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
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
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
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
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
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
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 \
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 \
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 \
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 \
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 \
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 \
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 \
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 \
--- /dev/null
+*> \brief <b> CGGES3 computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices (blocked algorithm)</b>
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CGGES3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cgges3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cgges3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cgges3.f">
+*> [TXT]</a>
+*> \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
--- /dev/null
+*> \brief <b> CGGEV3 computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices (blocked algorithm)</b>
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CGGEV3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cggev3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cggev3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cggev3.f">
+*> [TXT]</a>
+*> \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
--- /dev/null
+*> \brief \b CGGHD3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CGGHD3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cgghd3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cgghd3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cgghd3.f">
+*> [TXT]</a>
+*> \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
--- /dev/null
+*> \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
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cunm22.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cunm22.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cunm22.f">
+*> [TXT]</a>
+*> \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
--- /dev/null
+*> \brief <b> DGGES3 computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices (blocked algorithm)</b>
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DGGES3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgges3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgges3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgges3.f">
+*> [TXT]</a>
+*> \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
--- /dev/null
+*> \brief <b> DGGEV3 computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices (blocked algorithm)</b>
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DGGEV3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dggev3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dggev3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dggev3.f">
+*> [TXT]</a>
+*> \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
--- /dev/null
+*> \brief \b DGGHD3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DGGHD3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgghd3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgghd3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgghd3.f">
+*> [TXT]</a>
+*> \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
--- /dev/null
+*> \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
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorm22.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorm22.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorm22.f">
+*> [TXT]</a>
+*> \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
*> =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
*>
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
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
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
*
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
*> \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
*
*>
*> 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
* ..
* .. Local Scalars ..
INTEGER NH, NS
+ INTEGER I, IC, IZ
+ CHARACTER SUBNAM*6
* ..
* .. Intrinsic Functions ..
INTRINSIC LOG, MAX, MOD, NINT, REAL
* . 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 =====
--- /dev/null
+*> \brief <b> SGGES3 computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices (blocked algorithm)</b>
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SGGES3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sgges3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sgges3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sgges3.f">
+*> [TXT]</a>
+*> \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
--- /dev/null
+*> \brief <b> SGGEV3 computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices (blocked algorithm)</b>
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SGGEV3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sggev3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sggev3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sggev3.f">
+*> [TXT]</a>
+*> \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
--- /dev/null
+*> \brief \b SGGHD3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SGGHRD + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sgghd3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sgghd3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sgghd3.f">
+*> [TXT]</a>
+*> \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
--- /dev/null
+*> \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
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sorm22.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sorm22.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sorm22.f">
+*> [TXT]</a>
+*> \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
--- /dev/null
+*> \brief <b> ZGGES3 computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices (blocked algorithm)</b>
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZGGES3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgges3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgges3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgges3.f">
+*> [TXT]</a>
+*> \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
--- /dev/null
+*> \brief <b> ZGGEV3 computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices (blocked algorithm)</b>
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZGGEV3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zggev3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zggev3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zggev3.f">
+*> [TXT]</a>
+*> \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
--- /dev/null
+*> \brief \b ZGGHD3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZGGHD3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgghd3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgghd3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgghd3.f">
+*> [TXT]</a>
+*> \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
--- /dev/null
+*> \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
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunm22.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunm22.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunm22.f">
+*> [TXT]</a>
+*> \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
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
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
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
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 )
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 \
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 \
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 \
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 \
*> 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):
*> 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.
*>
$ 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
*
* 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
* NBMIN = minimum block size
* NS = number of shifts
* MAXB = minimum submatrix size
+* IACC22: structured matrix multiply
* NBCOL = minimum column dimension for blocks
*
MAXTYP = 26
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
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
*
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
$ 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
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' )
--- /dev/null
+*> \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
--- /dev/null
+*> \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
*
* =========== 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:
* =============
*> \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:
* 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
*
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
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'
$ -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
*
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'
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'
*
* =========== 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:
* =============
*> 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):
*> 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.
*>
* 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
*
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 ..
$ 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
*
* 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
* NBMIN = minimum block size
* NS = number of shifts
* MAXB = minimum submatrix size
+* IACC22: structured matrix multiply
* NBCOL = minimum column dimension for blocks
*
MAXTYP = 26
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
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
$ 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
$ 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
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' )
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' )
--- /dev/null
+*> \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
--- /dev/null
+*> \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
*>
*> \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:
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
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'
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'
$ 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
*
*> 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):
*> 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.
*>
$ 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
*
* 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
* NBMIN = minimum block size
* NS = number of shifts
* MAXB = minimum submatrix size
+* IACC22: structured matrix multiply
* NBCOL = minimum column dimension for blocks
*
MAXTYP = 26
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
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
*
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
$ 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
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' )
--- /dev/null
+*> \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
--- /dev/null
+*> \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
*
* =========== 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:
* =============
*> \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:
* 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
*
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
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'
$ -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
*
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'
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'
*> 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):
*> 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.
*>
$ 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
*
* 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
* NBMIN = minimum block size
* NS = number of shifts
* MAXB = minimum submatrix size
+* IACC22: structured matrix multiply
* NBCOL = minimum column dimension for blocks
*
MAXTYP = 26
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
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
*
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
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 ),
$ 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
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' )
--- /dev/null
+*> \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
--- /dev/null
+*> \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
*
* =========== 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:
* =============
*> \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:
* 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
*
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
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'
$ -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
*
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'
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'
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
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
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
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
projects / platform / upstream / lapack.git / commitdiff