aboutsummaryrefslogtreecommitdiff
path: root/SRC
diff options
context:
space:
mode:
authorphilippe.theveny <philippe.theveny@8a072113-8704-0410-8d35-dd094bca7971>2015-02-24 23:50:54 +0000
committerphilippe.theveny <philippe.theveny@8a072113-8704-0410-8d35-dd094bca7971>2015-02-24 23:50:54 +0000
commit6273f536d15680513e8cddfc4d8baa88ad2c64df (patch)
treea7f3303149eda2542ad7cf05fb470b60872e0161 /SRC
parentc95be035b79cca2ba9e68c961d537344c5390765 (diff)
Add xGGHD3: blocked Hessenberg reduction, code from Daniel Kressner.
Add xGGES3 and xGGEV3: computation of the Schur form, the Schur vectors, and the generalized eigenvalues using the blocked Hessenberg reduction.
Diffstat (limited to 'SRC')
-rw-r--r--SRC/CMakeLists.txt28
-rw-r--r--SRC/Makefile28
-rw-r--r--SRC/cgges3.f597
-rw-r--r--SRC/cggev3.f560
-rw-r--r--SRC/cgghd3.f901
-rw-r--r--SRC/cunm22.f440
-rw-r--r--SRC/dgges3.f674
-rw-r--r--SRC/dggev3.f594
-rw-r--r--SRC/dgghd3.f898
-rw-r--r--SRC/dorm22.f441
-rw-r--r--SRC/ilaenv.f23
-rw-r--r--SRC/iparmq.f109
-rw-r--r--SRC/sgges3.f671
-rw-r--r--SRC/sggev3.f589
-rw-r--r--SRC/sgghd3.f898
-rw-r--r--SRC/sorm22.f441
-rw-r--r--SRC/zgges3.f595
-rw-r--r--SRC/zggev3.f559
-rw-r--r--SRC/zgghd3.f896
-rw-r--r--SRC/zunm22.f440
20 files changed, 10338 insertions, 44 deletions
diff --git a/SRC/CMakeLists.txt b/SRC/CMakeLists.txt
index d618d6e0..8ea4f5fd 100644
--- a/SRC/CMakeLists.txt
+++ b/SRC/CMakeLists.txt
@@ -98,8 +98,9 @@ set(SLASRC
sgeqp3.f sgeqpf.f sgeqr2.f sgeqr2p.f sgeqrf.f sgeqrfp.f sgerfs.f sgerq2.f sgerqf.f
sgesc2.f sgesdd.f sgesv.f sgesvd.f sgesvx.f sgetc2.f sgetf2.f
sgetrf.f sgetri.f
- sgetrs.f sggbak.f sggbal.f sgges.f sggesx.f sggev.f sggevx.f
- sggglm.f sgghrd.f sgglse.f sggqrf.f
+ sgetrs.f sggbak.f sggbal.f
+ sgges.f sgges3.f sggesx.f sggev.f sggev3.f sggevx.f
+ sggglm.f sgghrd.f sgghd3.f sgglse.f sggqrf.f
sggrqf.f sggsvd.f sggsvp.f sgtcon.f sgtrfs.f sgtsv.f
sgtsvx.f sgttrf.f sgttrs.f sgtts2.f shgeqz.f
shsein.f shseqr.f slabrd.f slacon.f slacn2.f
@@ -117,7 +118,7 @@ set(SLASRC
slatbs.f slatdf.f slatps.f slatrd.f slatrs.f slatrz.f slatzm.f
slauu2.f slauum.f sopgtr.f sopmtr.f sorg2l.f sorg2r.f
sorgbr.f sorghr.f sorgl2.f sorglq.f sorgql.f sorgqr.f sorgr2.f
- sorgrq.f sorgtr.f sorm2l.f sorm2r.f
+ sorgrq.f sorgtr.f sorm2l.f sorm2r.f sorm22.f
sormbr.f sormhr.f sorml2.f sormlq.f sormql.f sormqr.f sormr2.f
sormr3.f sormrq.f sormrz.f sormtr.f spbcon.f spbequ.f spbrfs.f
spbstf.f spbsv.f spbsvx.f
@@ -171,8 +172,9 @@ set(CLASRC
cgeqpf.f cgeqr2.f cgeqr2p.f cgeqrf.f cgeqrfp.f cgerfs.f cgerq2.f cgerqf.f
cgesc2.f cgesdd.f cgesv.f cgesvd.f cgesvx.f cgetc2.f cgetf2.f cgetrf.f
cgetri.f cgetrs.f
- cggbak.f cggbal.f cgges.f cggesx.f cggev.f cggevx.f cggglm.f
- cgghrd.f cgglse.f cggqrf.f cggrqf.f
+ cggbak.f cggbal.f
+ cgges.f cgges3.f cggesx.f cggev.f cggev3.f cggevx.f
+ cggglm.f cgghrd.f cgghd3.f cgglse.f cggqrf.f cggrqf.f
cggsvd.f cggsvp.f
cgtcon.f cgtrfs.f cgtsv.f cgtsvx.f cgttrf.f cgttrs.f cgtts2.f chbev.f
chbevd.f chbevx.f chbgst.f chbgv.f chbgvd.f chbgvx.f chbtrd.f
@@ -220,7 +222,7 @@ set(CLASRC
ctptrs.f ctrcon.f ctrevc.f ctrexc.f ctrrfs.f ctrsen.f ctrsna.f
ctrsyl.f ctrti2.f ctrtri.f ctrtrs.f ctzrqf.f ctzrzf.f cung2l.f cung2r.f
cungbr.f cunghr.f cungl2.f cunglq.f cungql.f cungqr.f cungr2.f
- cungrq.f cungtr.f cunm2l.f cunm2r.f cunmbr.f cunmhr.f cunml2.f
+ cungrq.f cungtr.f cunm2l.f cunm2r.f cunmbr.f cunmhr.f cunml2.f cunm22.f
cunmlq.f cunmql.f cunmqr.f cunmr2.f cunmr3.f cunmrq.f cunmrz.f
cunmtr.f cupgtr.f cupmtr.f icmax1.f scsum1.f cstemr.f
chfrk.f ctfttp.f clanhf.f cpftrf.f cpftri.f cpftrs.f ctfsm.f ctftri.f
@@ -254,8 +256,9 @@ set(DLASRC
dgeqp3.f dgeqpf.f dgeqr2.f dgeqr2p.f dgeqrf.f dgeqrfp.f dgerfs.f dgerq2.f dgerqf.f
dgesc2.f dgesdd.f dgesv.f dgesvd.f dgesvx.f dgetc2.f dgetf2.f
dgetrf.f dgetri.f
- dgetrs.f dggbak.f dggbal.f dgges.f dggesx.f dggev.f dggevx.f
- dggglm.f dgghrd.f dgglse.f dggqrf.f
+ dgetrs.f dggbak.f dggbal.f
+ dgges.f dgges3.f dggesx.f dggev.f dggev3.f dggevx.f
+ dggglm.f dgghrd.f dgghd3.f dgglse.f dggqrf.f
dggrqf.f dggsvd.f dggsvp.f dgtcon.f dgtrfs.f dgtsv.f
dgtsvx.f dgttrf.f dgttrs.f dgtts2.f dhgeqz.f
dhsein.f dhseqr.f dlabrd.f dlacon.f dlacn2.f
@@ -273,7 +276,7 @@ set(DLASRC
dlatbs.f dlatdf.f dlatps.f dlatrd.f dlatrs.f dlatrz.f dlatzm.f dlauu2.f
dlauum.f dopgtr.f dopmtr.f dorg2l.f dorg2r.f
dorgbr.f dorghr.f dorgl2.f dorglq.f dorgql.f dorgqr.f dorgr2.f
- dorgrq.f dorgtr.f dorm2l.f dorm2r.f
+ dorgrq.f dorgtr.f dorm2l.f dorm2r.f dorm22.f
dormbr.f dormhr.f dorml2.f dormlq.f dormql.f dormqr.f dormr2.f
dormr3.f dormrq.f dormrz.f dormtr.f dpbcon.f dpbequ.f dpbrfs.f
dpbstf.f dpbsv.f dpbsvx.f
@@ -326,8 +329,9 @@ set(ZLASRC
zgeqpf.f zgeqr2.f zgeqr2p.f zgeqrf.f zgeqrfp.f zgerfs.f zgerq2.f zgerqf.f
zgesc2.f zgesdd.f zgesv.f zgesvd.f zgesvx.f zgetc2.f zgetf2.f zgetrf.f
zgetri.f zgetrs.f
- zggbak.f zggbal.f zgges.f zggesx.f zggev.f zggevx.f zggglm.f
- zgghrd.f zgglse.f zggqrf.f zggrqf.f
+ zggbak.f zggbal.f
+ zgges.f zgges3.f zggesx.f zggev.f zggev3.f zggevx.f
+ zggglm.f zgghrd.f zgghd3.f zgglse.f zggqrf.f zggrqf.f
zggsvd.f zggsvp.f
zgtcon.f zgtrfs.f zgtsv.f zgtsvx.f zgttrf.f zgttrs.f zgtts2.f zhbev.f
zhbevd.f zhbevx.f zhbgst.f zhbgv.f zhbgvd.f zhbgvx.f zhbtrd.f
@@ -378,7 +382,7 @@ set(ZLASRC
ztptrs.f ztrcon.f ztrevc.f ztrexc.f ztrrfs.f ztrsen.f ztrsna.f
ztrsyl.f ztrti2.f ztrtri.f ztrtrs.f ztzrqf.f ztzrzf.f zung2l.f
zung2r.f zungbr.f zunghr.f zungl2.f zunglq.f zungql.f zungqr.f zungr2.f
- zungrq.f zungtr.f zunm2l.f zunm2r.f zunmbr.f zunmhr.f zunml2.f
+ zungrq.f zungtr.f zunm2l.f zunm2r.f zunmbr.f zunmhr.f zunml2.f zunm22.f
zunmlq.f zunmql.f zunmqr.f zunmr2.f zunmr3.f zunmrq.f zunmrz.f
zunmtr.f zupgtr.f
zupmtr.f izmax1.f dzsum1.f zstemr.f
diff --git a/SRC/Makefile b/SRC/Makefile
index f3eaa533..30946da5 100644
--- a/SRC/Makefile
+++ b/SRC/Makefile
@@ -103,8 +103,9 @@ SLASRC = \
sgeqp3.o sgeqpf.o sgeqr2.o sgeqr2p.o sgeqrf.o sgeqrfp.o sgerfs.o \
sgerq2.o sgerqf.o sgesc2.o sgesdd.o sgesv.o sgesvd.o sgesvx.o \
sgetc2.o sgetf2.o sgetri.o \
- sggbak.o sggbal.o sgges.o sggesx.o sggev.o sggevx.o \
- sggglm.o sgghrd.o sgglse.o sggqrf.o \
+ sggbak.o sggbal.o sgges.o sgges3.o sggesx.o \
+ sggev.o sggev3.o sggevx.o \
+ sggglm.o sgghrd.o sgghd3.o sgglse.o sggqrf.o \
sggrqf.o sggsvd.o sggsvp.o sgtcon.o sgtrfs.o sgtsv.o \
sgtsvx.o sgttrf.o sgttrs.o sgtts2.o shgeqz.o \
shsein.o shseqr.o slabrd.o slacon.o slacn2.o \
@@ -122,7 +123,7 @@ SLASRC = \
slatbs.o slatdf.o slatps.o slatrd.o slatrs.o slatrz.o slatzm.o \
slauu2.o slauum.o sopgtr.o sopmtr.o sorg2l.o sorg2r.o \
sorgbr.o sorghr.o sorgl2.o sorglq.o sorgql.o sorgqr.o sorgr2.o \
- sorgrq.o sorgtr.o sorm2l.o sorm2r.o \
+ sorgrq.o sorgtr.o sorm2l.o sorm2r.o sorm22.o \
sormbr.o sormhr.o sorml2.o sormlq.o sormql.o sormqr.o sormr2.o \
sormr3.o sormrq.o sormrz.o sormtr.o spbcon.o spbequ.o spbrfs.o \
spbstf.o spbsv.o spbsvx.o \
@@ -178,8 +179,9 @@ CLASRC = \
cgeqpf.o cgeqr2.o cgeqr2p.o cgeqrf.o cgeqrfp.o cgerfs.o \
cgerq2.o cgerqf.o cgesc2.o cgesdd.o cgesv.o cgesvd.o \
cgesvx.o cgetc2.o cgetf2.o cgetri.o \
- cggbak.o cggbal.o cgges.o cggesx.o cggev.o cggevx.o cggglm.o \
- cgghrd.o cgglse.o cggqrf.o cggrqf.o \
+ cggbak.o cggbal.o cgges.o cgges3.o cggesx.o \
+ cggev.o cggev3.o cggevx.o \
+ cgghrd.o cgghd3.o cgglse.o cggqrf.o cggrqf.o \
cggsvd.o cggsvp.o \
cgtcon.o cgtrfs.o cgtsv.o cgtsvx.o cgttrf.o cgttrs.o cgtts2.o chbev.o \
chbevd.o chbevx.o chbgst.o chbgv.o chbgvd.o chbgvx.o chbtrd.o \
@@ -227,7 +229,7 @@ CLASRC = \
ctptrs.o ctrcon.o ctrevc.o ctrexc.o ctrrfs.o ctrsen.o ctrsna.o \
ctrsyl.o ctrti2.o ctrtri.o ctrtrs.o ctzrqf.o ctzrzf.o cung2l.o cung2r.o \
cungbr.o cunghr.o cungl2.o cunglq.o cungql.o cungqr.o cungr2.o \
- cungrq.o cungtr.o cunm2l.o cunm2r.o cunmbr.o cunmhr.o cunml2.o \
+ cungrq.o cungtr.o cunm2l.o cunm2r.o cunmbr.o cunmhr.o cunml2.o cunm22.o \
cunmlq.o cunmql.o cunmqr.o cunmr2.o cunmr3.o cunmrq.o cunmrz.o \
cunmtr.o cupgtr.o cupmtr.o icmax1.o scsum1.o cstemr.o \
chfrk.o ctfttp.o clanhf.o cpftrf.o cpftri.o cpftrs.o ctfsm.o ctftri.o \
@@ -263,8 +265,9 @@ DLASRC = \
dgeqp3.o dgeqpf.o dgeqr2.o dgeqr2p.o dgeqrf.o dgeqrfp.o dgerfs.o \
dgerq2.o dgerqf.o dgesc2.o dgesdd.o dgesv.o dgesvd.o dgesvx.o \
dgetc2.o dgetf2.o dgetrf.o dgetri.o \
- dgetrs.o dggbak.o dggbal.o dgges.o dggesx.o dggev.o dggevx.o \
- dggglm.o dgghrd.o dgglse.o dggqrf.o \
+ dgetrs.o dggbak.o dggbal.o dgges.o dgges3.o dggesx.o \
+ dggev.o dggev3.o dggevx.o \
+ dggglm.o dgghrd.o dgghd3.o dgglse.o dggqrf.o \
dggrqf.o dggsvd.o dggsvp.o dgtcon.o dgtrfs.o dgtsv.o \
dgtsvx.o dgttrf.o dgttrs.o dgtts2.o dhgeqz.o \
dhsein.o dhseqr.o dlabrd.o dlacon.o dlacn2.o \
@@ -282,7 +285,7 @@ DLASRC = \
dlatbs.o dlatdf.o dlatps.o dlatrd.o dlatrs.o dlatrz.o dlatzm.o dlauu2.o \
dlauum.o dopgtr.o dopmtr.o dorg2l.o dorg2r.o \
dorgbr.o dorghr.o dorgl2.o dorglq.o dorgql.o dorgqr.o dorgr2.o \
- dorgrq.o dorgtr.o dorm2l.o dorm2r.o \
+ dorgrq.o dorgtr.o dorm2l.o dorm2r.o dorm22.o \
dormbr.o dormhr.o dorml2.o dormlq.o dormql.o dormqr.o dormr2.o \
dormr3.o dormrq.o dormrz.o dormtr.o dpbcon.o dpbequ.o dpbrfs.o \
dpbstf.o dpbsv.o dpbsvx.o \
@@ -337,8 +340,9 @@ ZLASRC = \
zgeqpf.o zgeqr2.o zgeqr2p.o zgeqrf.o zgeqrfp.o zgerfs.o zgerq2.o zgerqf.o \
zgesc2.o zgesdd.o zgesv.o zgesvd.o zgesvx.o zgetc2.o zgetf2.o zgetrf.o \
zgetri.o zgetrs.o \
- zggbak.o zggbal.o zgges.o zggesx.o zggev.o zggevx.o zggglm.o \
- zgghrd.o zgglse.o zggqrf.o zggrqf.o \
+ zggbak.o zggbal.o zgges.o zgges3.o zggesx.o \
+ zggev.o zggev3.o zggevx.o zggglm.o \
+ zgghrd.o zgghd3.o zgglse.o zggqrf.o zggrqf.o \
zggsvd.o zggsvp.o \
zgtcon.o zgtrfs.o zgtsv.o zgtsvx.o zgttrf.o zgttrs.o zgtts2.o zhbev.o \
zhbevd.o zhbevx.o zhbgst.o zhbgv.o zhbgvd.o zhbgvx.o zhbtrd.o \
@@ -389,7 +393,7 @@ ZLASRC = \
ztptrs.o ztrcon.o ztrevc.o ztrexc.o ztrrfs.o ztrsen.o ztrsna.o \
ztrsyl.o ztrti2.o ztrtri.o ztrtrs.o ztzrqf.o ztzrzf.o zung2l.o \
zung2r.o zungbr.o zunghr.o zungl2.o zunglq.o zungql.o zungqr.o zungr2.o \
- zungrq.o zungtr.o zunm2l.o zunm2r.o zunmbr.o zunmhr.o zunml2.o \
+ zungrq.o zungtr.o zunm2l.o zunm2r.o zunmbr.o zunmhr.o zunml2.o zunm22.o \
zunmlq.o zunmql.o zunmqr.o zunmr2.o zunmr3.o zunmrq.o zunmrz.o \
zunmtr.o zupgtr.o \
zupmtr.o izmax1.o dzsum1.o zstemr.o \
diff --git a/SRC/cgges3.f b/SRC/cgges3.f
new file mode 100644
index 00000000..ab603de5
--- /dev/null
+++ b/SRC/cgges3.f
@@ -0,0 +1,597 @@
+*> \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
diff --git a/SRC/cggev3.f b/SRC/cggev3.f
new file mode 100644
index 00000000..5d8c7f8a
--- /dev/null
+++ b/SRC/cggev3.f
@@ -0,0 +1,560 @@
+*> \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
diff --git a/SRC/cgghd3.f b/SRC/cgghd3.f
new file mode 100644
index 00000000..347d799f
--- /dev/null
+++ b/SRC/cgghd3.f
@@ -0,0 +1,901 @@
+*> \brief \b CGGHD3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CGGHD3 + dependencies
+*> <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
diff --git a/SRC/cunm22.f b/SRC/cunm22.f
new file mode 100644
index 00000000..85c2269a
--- /dev/null
+++ b/SRC/cunm22.f
@@ -0,0 +1,440 @@
+*> \brief \b CUNM22 multiplies a general matrix by a banded unitary matrix.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CUNM22 + dependencies
+*> <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
diff --git a/SRC/dgges3.f b/SRC/dgges3.f
new file mode 100644
index 00000000..41d2ea0e
--- /dev/null
+++ b/SRC/dgges3.f
@@ -0,0 +1,674 @@
+*> \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
diff --git a/SRC/dggev3.f b/SRC/dggev3.f
new file mode 100644
index 00000000..43a853df
--- /dev/null
+++ b/SRC/dggev3.f
@@ -0,0 +1,594 @@
+*> \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
diff --git a/SRC/dgghd3.f b/SRC/dgghd3.f
new file mode 100644
index 00000000..7bed5cc4
--- /dev/null
+++ b/SRC/dgghd3.f
@@ -0,0 +1,898 @@
+*> \brief \b DGGHD3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DGGHD3 + dependencies
+*> <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
diff --git a/SRC/dorm22.f b/SRC/dorm22.f
new file mode 100644
index 00000000..ac79e1e7
--- /dev/null
+++ b/SRC/dorm22.f
@@ -0,0 +1,441 @@
+*> \brief \b DORM22 multiplies a general matrix by a banded orthogonal matrix.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DORM22 + dependencies
+*> <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
diff --git a/SRC/ilaenv.f b/SRC/ilaenv.f
index 867464de..010b5ed6 100644
--- a/SRC/ilaenv.f
+++ b/SRC/ilaenv.f
@@ -82,7 +82,7 @@
*> =10: ieee NaN arithmetic can be trusted not to trap
*> =11: infinity arithmetic can be trusted not to trap
*> 12 <= ISPEC <= 16:
-*> xHSEQR or one of its subroutines,
+*> xHSEQR or related subroutines,
*> see IPARMQ for detailed explanation
*> \endverbatim
*>
@@ -410,6 +410,15 @@
IF( C3.EQ.'EBZ' ) THEN
NB = 1
END IF
+ ELSE IF( C2.EQ.'GG' ) THEN
+ NB = 32
+ IF( C3.EQ.'HD3' ) THEN
+ IF( SNAME ) THEN
+ NB = 32
+ ELSE
+ NB = 32
+ END IF
+ END IF
END IF
ILAENV = NB
RETURN
@@ -488,6 +497,11 @@
NBMIN = 2
END IF
END IF
+ ELSE IF( C2.EQ.'GG' ) THEN
+ NBMIN = 2
+ IF( C3.EQ.'HD3' ) THEN
+ NBMIN = 2
+ END IF
END IF
ILAENV = NBMIN
RETURN
@@ -542,6 +556,11 @@
NX = 128
END IF
END IF
+ ELSE IF( C2.EQ.'GG' ) THEN
+ NX = 128
+ IF( C3.EQ.'HD3' ) THEN
+ NX = 128
+ END IF
END IF
ILAENV = NX
RETURN
@@ -614,7 +633,7 @@
*
160 CONTINUE
*
-* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines.
+* 12 <= ISPEC <= 16: xHSEQR or related subroutines.
*
ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
RETURN
diff --git a/SRC/iparmq.f b/SRC/iparmq.f
index bd5bd7a0..581e1cb1 100644
--- a/SRC/iparmq.f
+++ b/SRC/iparmq.f
@@ -31,7 +31,8 @@
*> \verbatim
*>
*> This program sets problem and machine dependent parameters
-*> useful for xHSEQR and its subroutines. It is called whenever
+*> useful for xHSEQR and related subroutines for eigenvalue
+*> problems. It is called whenever
*> ILAENV is called with 12 <= ISPEC <= 16
*> \endverbatim
*
@@ -75,19 +76,26 @@
*>
*> ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the
*> following meanings.
-*> 0: During the multi-shift QR sweep,
-*> xLAQR5 does not accumulate reflections and
-*> does not use matrix-matrix multiply to
-*> update the far-from-diagonal matrix
-*> entries.
-*> 1: During the multi-shift QR sweep,
-*> xLAQR5 and/or xLAQRaccumulates reflections and uses
-*> matrix-matrix multiply to update the
+*> 0: During the multi-shift QR/QZ sweep,
+*> blocked eigenvalue reordering, blocked
+*> Hessenberg-triangular reduction,
+*> reflections and/or rotations are not
+*> accumulated when updating the
*> far-from-diagonal matrix entries.
-*> 2: During the multi-shift QR sweep.
-*> xLAQR5 accumulates reflections and takes
-*> advantage of 2-by-2 block structure during
-*> matrix-matrix multiplies.
+*> 1: During the multi-shift QR/QZ sweep,
+*> blocked eigenvalue reordering, blocked
+*> Hessenberg-triangular reduction,
+*> reflections and/or rotations are
+*> accumulated, and matrix-matrix
+*> multiplication is used to update the
+*> far-from-diagonal matrix entries.
+*> 2: During the multi-shift QR/QZ sweep,
+*> blocked eigenvalue reordering, blocked
+*> Hessenberg-triangular reduction,
+*> reflections and/or rotations are
+*> accumulated, and 2-by-2 block structure
+*> is exploited during matrix-matrix
+*> multiplies.
*> (If xTRMM is slower than xGEMM, then
*> IPARMQ(ISPEC=16)=1 may be more efficient than
*> IPARMQ(ISPEC=16)=2 despite the greater level of
@@ -236,6 +244,8 @@
* ..
* .. Local Scalars ..
INTEGER NH, NS
+ INTEGER I, IC, IZ
+ CHARACTER SUBNAM*6
* ..
* .. Intrinsic Functions ..
INTRINSIC LOG, MAX, MOD, NINT, REAL
@@ -305,11 +315,74 @@
* . by making this choice dependent also upon the
* . NH=IHI-ILO+1.
*
- IPARMQ = 0
- IF( NS.GE.KACMIN )
- $ IPARMQ = 1
- IF( NS.GE.K22MIN )
- $ IPARMQ = 2
+*
+* Convert NAME to upper case if the first character is lower case.
+*
+ ILAENV = 0
+ SUBNAM = NAME
+ IC = ICHAR( SUBNAM( 1: 1 ) )
+ IZ = ICHAR( 'Z' )
+ IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN
+*
+* ASCII character set
+*
+ IF( IC.GE.97 .AND. IC.LE.122 ) THEN
+ SUBNAM( 1: 1 ) = CHAR( IC-32 )
+ DO I = 2, 6
+ IC = ICHAR( SUBNAM( I: I ) )
+ IF( IC.GE.97 .AND. IC.LE.122 )
+ $ SUBNAM( I: I ) = CHAR( IC-32 )
+ END DO
+ END IF
+*
+ ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN
+*
+* EBCDIC character set
+*
+ IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
+ $ ( IC.GE.145 .AND. IC.LE.153 ) .OR.
+ $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN
+ SUBNAM( 1: 1 ) = CHAR( IC+64 )
+ DO I = 2, 6
+ IC = ICHAR( SUBNAM( I: I ) )
+ IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
+ $ ( IC.GE.145 .AND. IC.LE.153 ) .OR.
+ $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I:
+ $ I ) = CHAR( IC+64 )
+ END DO
+ END IF
+*
+ ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN
+*
+* Prime machines: ASCII+128
+*
+ IF( IC.GE.225 .AND. IC.LE.250 ) THEN
+ SUBNAM( 1: 1 ) = CHAR( IC-32 )
+ DO I = 2, 6
+ IC = ICHAR( SUBNAM( I: I ) )
+ IF( IC.GE.225 .AND. IC.LE.250 )
+ $ SUBNAM( I: I ) = CHAR( IC-32 )
+ END DO
+ END IF
+ END IF
+*
+ IF( SUBNAM( 2:6 ).EQ.'GGHRD' .OR.
+ $ SUBNAM( 2:6 ).EQ.'GGHD3' ) THEN
+ IPARMQ = 1
+ IF( NH.GE.K22MIN )
+ $ IPARMQ = 2
+ ELSE IF ( SUBNAM( 4:6 ).EQ.'EXC' ) THEN
+ IF( NH.GE.KACMIN )
+ $ IPARMQ = 1
+ IF( NH.GE.K22MIN )
+ $ IPARMQ = 2
+ ELSE IF ( SUBNAM( 2:6 ).EQ.'HSEQR' .OR.
+ $ SUBNAM( 2:5 ).EQ.'LAQR' ) THEN
+ IF( NS.GE.KACMIN )
+ $ IPARMQ = 1
+ IF( NS.GE.K22MIN )
+ $ IPARMQ = 2
+ END IF
*
ELSE
* ===== invalid value of ispec =====
diff --git a/SRC/sgges3.f b/SRC/sgges3.f
new file mode 100644
index 00000000..81ab96c4
--- /dev/null
+++ b/SRC/sgges3.f
@@ -0,0 +1,671 @@
+*> \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
diff --git a/SRC/sggev3.f b/SRC/sggev3.f
new file mode 100644
index 00000000..7a253ad1
--- /dev/null
+++ b/SRC/sggev3.f
@@ -0,0 +1,589 @@
+*> \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
diff --git a/SRC/sgghd3.f b/SRC/sgghd3.f
new file mode 100644
index 00000000..bf91f559
--- /dev/null
+++ b/SRC/sgghd3.f
@@ -0,0 +1,898 @@
+*> \brief \b SGGHD3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SGGHRD + dependencies
+*> <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
diff --git a/SRC/sorm22.f b/SRC/sorm22.f
new file mode 100644
index 00000000..fdb5cd8b
--- /dev/null
+++ b/SRC/sorm22.f
@@ -0,0 +1,441 @@
+*> \brief \b SORM22 multiplies a general matrix by a banded orthogonal matrix.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SORM22 + dependencies
+*> <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
diff --git a/SRC/zgges3.f b/SRC/zgges3.f
new file mode 100644
index 00000000..d4455148
--- /dev/null
+++ b/SRC/zgges3.f
@@ -0,0 +1,595 @@
+*> \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
diff --git a/SRC/zggev3.f b/SRC/zggev3.f
new file mode 100644
index 00000000..1c4e832a
--- /dev/null
+++ b/SRC/zggev3.f
@@ -0,0 +1,559 @@
+*> \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
diff --git a/SRC/zgghd3.f b/SRC/zgghd3.f
new file mode 100644
index 00000000..55952a4b
--- /dev/null
+++ b/SRC/zgghd3.f
@@ -0,0 +1,896 @@
+*> \brief \b ZGGHD3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZGGHD3 + dependencies
+*> <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
diff --git a/SRC/zunm22.f b/SRC/zunm22.f
new file mode 100644
index 00000000..468d7d8c
--- /dev/null
+++ b/SRC/zunm22.f
@@ -0,0 +1,440 @@
+*> \brief \b ZUNM22 multiplies a general matrix by a banded unitary matrix.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZUNM22 + dependencies
+*> <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
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-05 18:40:10 +0000