📄 stgevc.c
字号:
#include "blaswrap.h"
/* -- translated by f2c (version 19990503).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
#include "f2c.h"
/* Common Block Declarations */
struct {
real ops, itcnt;
} latime_;
#define latime_1 latime_
/* Table of constant values */
static logical c_true = TRUE_;
static integer c__2 = 2;
static real c_b35 = 1.f;
static integer c__1 = 1;
static real c_b37 = 0.f;
static logical c_false = FALSE_;
/* Subroutine */ int stgevc_(char *side, char *howmny, logical *select,
integer *n, real *a, integer *lda, real *b, integer *ldb, real *vl,
integer *ldvl, real *vr, integer *ldvr, integer *mm, integer *m, real
*work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
vr_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4, r__5, r__6;
/* Local variables */
static integer ibeg, ieig, iend;
static real dmin__, temp, suma[4] /* was [2][2] */, sumb[4] /*
was [2][2] */, xmax, opst, cim2a, cim2b, cre2a, cre2b;
extern /* Subroutine */ int slag2_(real *, integer *, real *, integer *,
real *, real *, real *, real *, real *, real *);
static real temp2, bdiag[2];
static integer i__, j;
static real acoef, scale;
static logical ilall;
static integer iside;
static real sbeta;
extern logical lsame_(char *, char *);
static logical il2by2;
static integer iinfo, in2by2;
static real small;
static logical compl;
static real anorm, bnorm;
static logical compr;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *), slaln2_(logical *, integer *, integer *, real *, real *,
real *, integer *, real *, real *, real *, integer *, real *,
real *, real *, integer *, real *, real *, integer *);
static real temp2i, temp2r;
static integer ja;
static logical ilabad, ilbbad;
static integer jc, je, na;
static real acoefa, bcoefa, cimaga, cimagb;
static logical ilback;
static integer im;
static real bcoefi, ascale, bscale, creala;
static integer jr;
static real crealb;
extern /* Subroutine */ int slabad_(real *, real *);
static real bcoefr;
static integer jw, nw;
extern doublereal slamch_(char *);
static real salfar, safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real xscale, bignum;
static logical ilcomp;
static real opssca;
static logical ilcplx;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *);
static integer ihwmny;
static real big;
static logical lsa, lsb;
static real ulp, sum[4] /* was [2][2] */;
#define suma_ref(a_1,a_2) suma[(a_2)*2 + a_1 - 3]
#define sumb_ref(a_1,a_2) sumb[(a_2)*2 + a_1 - 3]
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define vl_ref(a_1,a_2) vl[(a_2)*vl_dim1 + a_1]
#define vr_ref(a_1,a_2) vr[(a_2)*vr_dim1 + a_1]
#define sum_ref(a_1,a_2) sum[(a_2)*2 + a_1 - 3]
/* -- LAPACK routine (instrumented to count operations, version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
---------------------- Begin Timing Code -------------------------
Common block to return operation count and iteration count
ITCNT is initialized to 0, OPS is only incremented
OPST is used to accumulate small contributions to OPS
to avoid roundoff error
----------------------- End Timing Code --------------------------
Purpose
=======
STGEVC computes some or all of the right and/or left generalized
eigenvectors of a pair of real upper triangular matrices (A,B).
The right generalized eigenvector x and the left generalized
eigenvector y of (A,B) corresponding to a generalized eigenvalue
w are defined by:
(A - wB) * x = 0 and y**H * (A - wB) = 0
where y**H denotes the conjugate tranpose of y.
If an eigenvalue w is determined by zero diagonal elements of both A
and B, a unit vector is returned as the corresponding eigenvector.
If all eigenvectors are requested, the routine may either return
the matrices X and/or Y of right or left eigenvectors of (A,B), or
the products Z*X and/or Q*Y, where Z and Q are input orthogonal
matrices. If (A,B) was obtained from the generalized real-Schur
factorization of an original pair of matrices
(A0,B0) = (Q*A*Z**H,Q*B*Z**H),
then Z*X and Q*Y are the matrices of right or left eigenvectors of
A.
A must be block upper triangular, with 1-by-1 and 2-by-2 diagonal
blocks. Corresponding to each 2-by-2 diagonal block is a complex
conjugate pair of eigenvalues and eigenvectors; only one
eigenvector of the pair is computed, namely the one corresponding
to the eigenvalue with positive imaginary part.
Arguments
=========
SIDE (input) CHARACTER*1
= 'R': compute right eigenvectors only;
= 'L': compute left eigenvectors only;
= 'B': compute both right and left eigenvectors.
HOWMNY (input) CHARACTER*1
= 'A': compute all right and/or left eigenvectors;
= 'B': compute all right and/or left eigenvectors, and
backtransform them using the input matrices supplied
in VR and/or VL;
= 'S': compute selected right and/or left eigenvectors,
specified by the logical array SELECT.
SELECT (input) LOGICAL array, dimension (N)
If HOWMNY='S', SELECT specifies the eigenvectors to be
computed.
If HOWMNY='A' or 'B', SELECT is not referenced.
To select the real eigenvector corresponding to the real
eigenvalue w(j), SELECT(j) must be set to .TRUE. To select
the complex eigenvector corresponding to a complex conjugate
pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must
be set to .TRUE..
N (input) INTEGER
The order of the matrices A and B. N >= 0.
A (input) REAL array, dimension (LDA,N)
The upper quasi-triangular matrix A.
LDA (input) INTEGER
The leading dimension of array A. LDA >= max(1,N).
B (input) REAL array, dimension (LDB,N)
The upper triangular matrix B. If A has a 2-by-2 diagonal
block, then the corresponding 2-by-2 block of B must be
diagonal with positive elements.
LDB (input) INTEGER
The leading dimension of array B. LDB >= max(1,N).
VL (input/output) REAL array, dimension (LDVL,MM)
On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
contain an N-by-N matrix Q (usually the orthogonal matrix Q
of left Schur vectors returned by SHGEQZ).
On exit, if SIDE = 'L' or 'B', VL contains:
if HOWMNY = 'A', the matrix Y of left eigenvectors of (A,B);
if HOWMNY = 'B', the matrix Q*Y;
if HOWMNY = 'S', the left eigenvectors of (A,B) specified by
SELECT, stored consecutively in the columns of
VL, in the same order as their eigenvalues.
If SIDE = 'R', VL is not referenced.
A complex eigenvector corresponding to a complex eigenvalue
is stored in two consecutive columns, the first holding the
real part, and the second the imaginary part.
LDVL (input) INTEGER
The leading dimension of array VL.
LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
VR (input/output) REAL array, dimension (LDVR,MM)
On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
contain an N-by-N matrix Q (usually the orthogonal matrix Z
of right Schur vectors returned by SHGEQZ).
On exit, if SIDE = 'R' or 'B', VR contains:
if HOWMNY = 'A', the matrix X of right eigenvectors of (A,B);
if HOWMNY = 'B', the matrix Z*X;
if HOWMNY = 'S', the right eigenvectors of (A,B) specified by
SELECT, stored consecutively in the columns of
VR, in the same order as their eigenvalues.
If SIDE = 'L', VR is not referenced.
A complex eigenvector corresponding to a complex eigenvalue
is stored in two consecutive columns, the first holding the
real part and the second the imaginary part.
LDVR (input) INTEGER
The leading dimension of the array VR.
LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
MM (input) INTEGER
The number of columns in the arrays VL and/or VR. MM >= M.
M (output) INTEGER
The number of columns in the arrays VL and/or VR actually
used to store the eigenvectors. If HOWMNY = 'A' or 'B', M
is set to N. Each selected real eigenvector occupies one
column and each selected complex eigenvector occupies two
columns.
WORK (workspace) REAL array, dimension (6*N)
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: the 2-by-2 block (INFO:INFO+1) does not have a complex
eigenvalue.
Further Details
===============
Allocation of workspace:
---------- -- ---------
WORK( j ) = 1-norm of j-th column of A, above the diagonal
WORK( N+j ) = 1-norm of j-th column of B, above the diagonal
WORK( 2*N+1:3*N ) = real part of eigenvector
WORK( 3*N+1:4*N ) = imaginary part of eigenvector
WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector
WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector
Rowwise vs. columnwise solution methods:
------- -- ---------- -------- -------
Finding a generalized eigenvector consists basically of solving the
singular triangular system
(A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left)
Consider finding the i-th right eigenvector (assume all eigenvalues
are real). The equation to be solved is:
n i
0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1
k=j k=j
where C = (A - w B) (The components v(i+1:n) are 0.)
The "rowwise" method is:
(1) v(i) := 1
for j = i-1,. . .,1:
i
(2) compute s = - sum C(j,k) v(k) and
k=j+1
(3) v(j) := s / C(j,j)
Step 2 is sometimes called the "dot product" step, since it is an
inner product between the j-th row and the portion of the eigenvector
that has been computed so far.
The "columnwise" method consists basically in doing the sums
for all the rows in parallel. As each v(j) is computed, the
contribution of v(j) times the j-th column of C is added to the
partial sums. Since FORTRAN arrays are stored columnwise, this has
the advantage that at each step, the elements of C that are accessed
are adjacent to one another, whereas with the rowwise method, the
elements accessed at a step are spaced LDA (and LDB) words apart.
When finding left eigenvectors, the matrix in question is the
transpose of the one in storage, so the rowwise method then
actually accesses columns of A and B at each step, and so is the
preferred method.
=====================================================================
Decode and Test the input parameters
Parameter adjustments */
--select;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1 * 1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1 * 1;
vr -= vr_offset;
--work;
/* Function Body */
if (lsame_(howmny, "A")) {
ihwmny = 1;
ilall = TRUE_;
ilback = FALSE_;
} else if (lsame_(howmny, "S")) {
ihwmny = 2;
ilall = FALSE_;
ilback = FALSE_;
} else if (lsame_(howmny, "B") || lsame_(howmny,
"T")) {
ihwmny = 3;
ilall = TRUE_;
ilback = TRUE_;
} else {
ihwmny = -1;
ilall = TRUE_;
}
if (lsame_(side, "R")) {
iside = 1;
compl = FALSE_;
compr = TRUE_;
} else if (lsame_(side, "L")) {
iside = 2;
compl = TRUE_;
compr = FALSE_;
} else if (lsame_(side, "B")) {
iside = 3;
compl = TRUE_;
compr = TRUE_;
} else {
iside = -1;
}
*info = 0;
if (iside < 0) {
*info = -1;
} else if (ihwmny < 0) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldb < max(1,*n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("STGEVC", &i__1);
return 0;
}
/* Count the number of eigenvectors to be computed */
if (! ilall) {
im = 0;
ilcplx = FALSE_;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (ilcplx) {
ilcplx = FALSE_;
goto L10;
}
if (j < *n) {
if (a_ref(j + 1, j) != 0.f) {
ilcplx = TRUE_;
}
}
if (ilcplx) {
if (select[j] || select[j + 1]) {
im += 2;
}
} else {
if (select[j]) {
++im;
}
}
L10:
;
}
} else {
im = *n;
}
/* Check 2-by-2 diagonal blocks of A, B */
ilabad = FALSE_;
ilbbad = FALSE_;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
if (a_ref(j + 1, j) != 0.f) {
if (b_ref(j, j) == 0.f || b_ref(j + 1, j + 1) == 0.f || b_ref(j,
j + 1) != 0.f) {
ilbbad = TRUE_;
}
if (j < *n - 1) {
if (a_ref(j + 2, j + 1) != 0.f) {
ilabad = TRUE_;
}
}
}
/* L20: */
}
if (ilabad) {
*info = -5;
} else if (ilbbad) {
*info = -7;
} else if (compl && *ldvl < *n || *ldvl < 1) {
*info = -10;
} else if (compr && *ldvr < *n || *ldvr < 1) {
*info = -12;
} else if (*mm < im) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("STGEVC", &i__1);
return 0;
}
/* Quick return if possible */
*m = im;
if (*n == 0) {
return 0;
}
/* Machine Constants */
safmin = slamch_("Safe minimum");
big = 1.f / safmin;
slabad_(&safmin, &big);
ulp = slamch_("Epsilon") * slamch_("Base");
small = safmin * *n / ulp;
big = 1.f / small;
bignum = 1.f / (safmin * *n);
/* Compute the 1-norm of each column of the strictly upper triangular
part (i.e., excluding all elements belonging to the diagonal
blocks) of A and B to check for possible overflow in the
triangular solver. */
anorm = (r__1 = a_ref(1, 1), dabs(r__1));
if (*n > 1) {
anorm += (r__1 = a_ref(2, 1), dabs(r__1));
}
bnorm = (r__1 = b_ref(1, 1), dabs(r__1));
work[1] = 0.f;
work[*n + 1] = 0.f;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
temp = 0.f;
temp2 = 0.f;
if (a_ref(j, j - 1) == 0.f) {
iend = j - 1;
} else {
iend = j - 2;
}
i__2 = iend;
for (i__ = 1; i__ <= i__2; ++i__) {
temp += (r__1 = a_ref(i__, j), dabs(r__1));
temp2 += (r__1 = b_ref(i__, j), dabs(r__1));
/* L30: */
}
work[j] = temp;
work[*n + j] = temp2;
/* Computing MIN */
i__3 = j + 1;
i__2 = min(i__3,*n);
for (i__ = iend + 1; i__ <= i__2; ++i__) {
temp += (r__1 = a_ref(i__, j), dabs(r__1));
temp2 += (r__1 = b_ref(i__, j), dabs(r__1));
/* L40: */
}
anorm = dmax(anorm,temp);
bnorm = dmax(bnorm,temp2);
/* L50: */
}
ascale = 1.f / dmax(anorm,safmin);
bscale = 1.f / dmax(bnorm,safmin);
/* ---------------------- Begin Timing Code -------------------------
Computing 2nd power */
i__1 = *n;
latime_1.ops += (real) (i__1 * i__1 + *n * 3 + 6);
/* ----------------------- End Timing Code --------------------------
Left eigenvectors */
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -