void test_qr_method_sym()
{
std::size_t sz = 220;
viennacl::matrix<ScalarType, MatrixLayout> Q = viennacl::identity_matrix<ScalarType>(sz);
std::vector<ScalarType> d(sz), e(sz), d_ref(sz), e_ref(sz);
std::cout << "Testing matrix of size " << sz << "-by-" << sz << std::endl << std::endl;
// Initialize diagonal and superdiagonal elements
for(unsigned int i = 0; i < sz; ++i)
{
d[i] = ((float)(i % 9)) - 4.5f;
e[i] = ((float)(i % 5)) - 4.5f;
}
e[0] = 0.0f;
d_ref = d;
e_ref = e;
//---Run the tql2 algorithm-----------------------------------
viennacl::linalg::tql2(Q, d, e);
// ---Test the computed eigenvalues and eigenvectors
if(!test_eigen_val_vec<MatrixLayout>(Q, d, d_ref, e_ref))
exit(EXIT_FAILURE);
/*
for( unsigned int i = 0; i < sz; ++i)
std::cout << "Eigenvalue " << i << "= " << d[i] << std::endl;
*/
}
/* Subroutine */ int sget52_(logical *left, integer *n, real *a, integer *lda,
real *b, integer *ldb, real *e, integer *lde, real *alphar, real *
alphai, real *beta, real *work, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, e_dim1, e_offset, i__1, i__2;
real r__1, r__2, r__3, r__4;
/* Local variables */
static integer jvec;
static real temp1;
static integer j;
static real acoef, scale, abmax, salfi, sbeta, salfr, anorm, bnorm, enorm;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *);
static char trans[1];
static real bcoefi, bcoefr, alfmax;
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
static real safmin;
static char normab[1];
static real safmax, betmax, enrmer;
static logical ilcplx;
static real errnrm, ulp;
#define e_ref(a_1,a_2) e[(a_2)*e_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SGET52 does an eigenvector check for the generalized eigenvalue
problem.
The basic test for right eigenvectors is:
| b(j) A E(j) - a(j) B E(j) |
RESULT(1) = max -------------------------------
j n ulp max( |b(j) A|, |a(j) B| )
using the 1-norm. Here, a(j)/b(j) = w is the j-th generalized
eigenvalue of A - w B, or, equivalently, b(j)/a(j) = m is the j-th
generalized eigenvalue of m A - B.
For real eigenvalues, the test is straightforward. For complex
eigenvalues, E(j) and a(j) are complex, represented by
Er(j) + i*Ei(j) and ar(j) + i*ai(j), resp., so the test for that
eigenvector becomes
max( |Wr|, |Wi| )
--------------------------------------------
n ulp max( |b(j) A|, (|ar(j)|+|ai(j)|) |B| )
where
Wr = b(j) A Er(j) - ar(j) B Er(j) + ai(j) B Ei(j)
Wi = b(j) A Ei(j) - ai(j) B Er(j) - ar(j) B Ei(j)
T T _
For left eigenvectors, A , B , a, and b are used.
SGET52 also tests the normalization of E. Each eigenvector is
supposed to be normalized so that the maximum "absolute value"
of its elements is 1, where in this case, "absolute value"
of a complex value x is |Re(x)| + |Im(x)| ; let us call this
maximum "absolute value" norm of a vector v M(v).
if a(j)=b(j)=0, then the eigenvector is set to be the jth coordinate
vector. The normalization test is:
RESULT(2) = max | M(v(j)) - 1 | / ( n ulp )
eigenvectors v(j)
Arguments
=========
LEFT (input) LOGICAL
=.TRUE.: The eigenvectors in the columns of E are assumed
to be *left* eigenvectors.
=.FALSE.: The eigenvectors in the columns of E are assumed
to be *right* eigenvectors.
N (input) INTEGER
The size of the matrices. If it is zero, SGET52 does
nothing. It must be at least zero.
A (input) REAL array, dimension (LDA, N)
The matrix A.
LDA (input) INTEGER
The leading dimension of A. It must be at least 1
and at least N.
B (input) REAL array, dimension (LDB, N)
The matrix B.
LDB (input) INTEGER
The leading dimension of B. It must be at least 1
and at least N.
E (input) REAL array, dimension (LDE, N)
The matrix of eigenvectors. It must be O( 1 ). Complex
eigenvalues and eigenvectors always come in pairs, the
eigenvalue and its conjugate being stored in adjacent
elements of ALPHAR, ALPHAI, and BETA. Thus, if a(j)/b(j)
and a(j+1)/b(j+1) are a complex conjugate pair of
generalized eigenvalues, then E(,j) contains the real part
of the eigenvector and E(,j+1) contains the imaginary part.
Note that whether E(,j) is a real eigenvector or part of a
complex one is specified by whether ALPHAI(j) is zero or not.
LDE (input) INTEGER
The leading dimension of E. It must be at least 1 and at
least N.
ALPHAR (input) REAL array, dimension (N)
The real parts of the values a(j) as described above, which,
along with b(j), define the generalized eigenvalues.
Complex eigenvalues always come in complex conjugate pairs
a(j)/b(j) and a(j+1)/b(j+1), which are stored in adjacent
elements in ALPHAR, ALPHAI, and BETA. Thus, if the j-th
and (j+1)-st eigenvalues form a pair, ALPHAR(j+1)/BETA(j+1)
is assumed to be equal to ALPHAR(j)/BETA(j).
ALPHAI (input) REAL array, dimension (N)
The imaginary parts of the values a(j) as described above,
which, along with b(j), define the generalized eigenvalues.
If ALPHAI(j)=0, then the eigenvalue is real, otherwise it
is part of a complex conjugate pair. Complex eigenvalues
always come in complex conjugate pairs a(j)/b(j) and
a(j+1)/b(j+1), which are stored in adjacent elements in
ALPHAR, ALPHAI, and BETA. Thus, if the j-th and (j+1)-st
eigenvalues form a pair, ALPHAI(j+1)/BETA(j+1) is assumed to
be equal to -ALPHAI(j)/BETA(j). Also, nonzero values in
ALPHAI are assumed to always come in adjacent pairs.
BETA (input) REAL array, dimension (N)
The values b(j) as described above, which, along with a(j),
define the generalized eigenvalues.
WORK (workspace) REAL array, dimension (N**2+N)
RESULT (output) REAL array, dimension (2)
The values computed by the test described above. If A E or
B E is likely to overflow, then RESULT(1:2) is set to
10 / ulp.
=====================================================================
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
e_dim1 = *lde;
e_offset = 1 + e_dim1 * 1;
e -= e_offset;
--alphar;
--alphai;
--beta;
--work;
--result;
/* Function Body */
result[1] = 0.f;
result[2] = 0.f;
if (*n <= 0) {
return 0;
}
safmin = slamch_("Safe minimum");
safmax = 1.f / safmin;
ulp = slamch_("Epsilon") * slamch_("Base");
if (*left) {
*(unsigned char *)trans = 'T';
*(unsigned char *)normab = 'I';
} else {
*(unsigned char *)trans = 'N';
*(unsigned char *)normab = 'O';
}
/* Norm of A, B, and E:
Computing MAX */
r__1 = slange_(normab, n, n, &a[a_offset], lda, &work[1]);
anorm = dmax(r__1,safmin);
/* Computing MAX */
r__1 = slange_(normab, n, n, &b[b_offset], ldb, &work[1]);
bnorm = dmax(r__1,safmin);
/* Computing MAX */
r__1 = slange_("O", n, n, &e[e_offset], lde, &work[1]);
enorm = dmax(r__1,ulp);
alfmax = safmax / dmax(1.f,bnorm);
betmax = safmax / dmax(1.f,anorm);
/* Compute error matrix.
Column i = ( b(i) A - a(i) B ) E(i) / max( |a(i) B| |b(i) A| ) */
ilcplx = FALSE_;
i__1 = *n;
for (jvec = 1; jvec <= i__1; ++jvec) {
if (ilcplx) {
/* 2nd Eigenvalue/-vector of pair -- do nothing */
ilcplx = FALSE_;
} else {
salfr = alphar[jvec];
salfi = alphai[jvec];
sbeta = beta[jvec];
if (salfi == 0.f) {
/* Real eigenvalue and -vector
Computing MAX */
r__1 = dabs(salfr), r__2 = dabs(sbeta);
abmax = dmax(r__1,r__2);
if (dabs(salfr) > alfmax || dabs(sbeta) > betmax || abmax <
1.f) {
scale = 1.f / dmax(abmax,safmin);
salfr = scale * salfr;
sbeta = scale * sbeta;
}
/* Computing MAX */
r__1 = dabs(salfr) * bnorm, r__2 = dabs(sbeta) * anorm, r__1 =
max(r__1,r__2);
scale = 1.f / dmax(r__1,safmin);
acoef = scale * sbeta;
bcoefr = scale * salfr;
sgemv_(trans, n, n, &acoef, &a[a_offset], lda, &e_ref(1, jvec)
, &c__1, &c_b12, &work[*n * (jvec - 1) + 1], &c__1);
r__1 = -bcoefr;
sgemv_(trans, n, n, &r__1, &b[b_offset], lda, &e_ref(1, jvec),
&c__1, &c_b15, &work[*n * (jvec - 1) + 1], &c__1);
} else {
/* Complex conjugate pair */
ilcplx = TRUE_;
if (jvec == *n) {
result[1] = 10.f / ulp;
return 0;
}
/* Computing MAX */
r__1 = dabs(salfr) + dabs(salfi), r__2 = dabs(sbeta);
abmax = dmax(r__1,r__2);
if (dabs(salfr) + dabs(salfi) > alfmax || dabs(sbeta) >
betmax || abmax < 1.f) {
scale = 1.f / dmax(abmax,safmin);
salfr = scale * salfr;
salfi = scale * salfi;
sbeta = scale * sbeta;
}
/* Computing MAX */
r__1 = (dabs(salfr) + dabs(salfi)) * bnorm, r__2 = dabs(sbeta)
* anorm, r__1 = max(r__1,r__2);
scale = 1.f / dmax(r__1,safmin);
acoef = scale * sbeta;
bcoefr = scale * salfr;
bcoefi = scale * salfi;
if (*left) {
bcoefi = -bcoefi;
}
sgemv_(trans, n, n, &acoef, &a[a_offset], lda, &e_ref(1, jvec)
, &c__1, &c_b12, &work[*n * (jvec - 1) + 1], &c__1);
r__1 = -bcoefr;
sgemv_(trans, n, n, &r__1, &b[b_offset], lda, &e_ref(1, jvec),
&c__1, &c_b15, &work[*n * (jvec - 1) + 1], &c__1);
sgemv_(trans, n, n, &bcoefi, &b[b_offset], lda, &e_ref(1,
jvec + 1), &c__1, &c_b15, &work[*n * (jvec - 1) + 1],
&c__1);
sgemv_(trans, n, n, &acoef, &a[a_offset], lda, &e_ref(1, jvec
+ 1), &c__1, &c_b12, &work[*n * jvec + 1], &c__1);
r__1 = -bcoefi;
sgemv_(trans, n, n, &r__1, &b[b_offset], lda, &e_ref(1, jvec),
&c__1, &c_b15, &work[*n * jvec + 1], &c__1);
r__1 = -bcoefr;
sgemv_(trans, n, n, &r__1, &b[b_offset], lda, &e_ref(1, jvec
+ 1), &c__1, &c_b15, &work[*n * jvec + 1], &c__1);
}
}
/* L10: */
}
/* Computing 2nd power */
i__1 = *n;
errnrm = slange_("One", n, n, &work[1], n, &work[i__1 * i__1 + 1]) / enorm;
/* Compute RESULT(1) */
result[1] = errnrm / ulp;
/* Normalization of E: */
enrmer = 0.f;
ilcplx = FALSE_;
i__1 = *n;
for (jvec = 1; jvec <= i__1; ++jvec) {
if (ilcplx) {
ilcplx = FALSE_;
} else {
temp1 = 0.f;
if (alphai[jvec] == 0.f) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
r__2 = temp1, r__3 = (r__1 = e_ref(j, jvec), dabs(r__1));
temp1 = dmax(r__2,r__3);
/* L20: */
}
/* Computing MAX */
r__1 = enrmer, r__2 = temp1 - 1.f;
enrmer = dmax(r__1,r__2);
} else {
ilcplx = TRUE_;
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
r__3 = temp1, r__4 = (r__1 = e_ref(j, jvec), dabs(r__1))
+ (r__2 = e_ref(j, jvec + 1), dabs(r__2));
temp1 = dmax(r__3,r__4);
/* L30: */
}
/* Computing MAX */
r__1 = enrmer, r__2 = temp1 - 1.f;
enrmer = dmax(r__1,r__2);
}
}
/* L40: */
}
/* Compute RESULT(2) : the normalization error in E. */
result[2] = enrmer / ((real) (*n) * ulp);
return 0;
/* End of SGET52 */
} /* sget52_ */
/* Subroutine */ int zchkbk_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(1x,\002.. test output of ZGEBAK .. \002)";
static char fmt_9998[] = "(1x,\002value of largest test error "
" = \002,d12.3)";
static char fmt_9997[] = "(1x,\002example number where info is not zero "
" = \002,i4)";
static char fmt_9996[] = "(1x,\002example number having largest error "
" = \002,i4)";
static char fmt_9995[] = "(1x,\002number of examples where info is not 0"
" = \002,i4)";
static char fmt_9994[] = "(1x,\002total number of examples tested "
" = \002,i4)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
double d_imag(doublecomplex *);
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Local variables */
static integer info, lmax[2];
static doublereal rmax, vmax;
static doublecomplex e[400] /* was [20][20] */;
static integer i__, j, n;
static doublereal scale[20], x;
static integer ninfo;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int zgebak_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublecomplex *, integer *,
integer *);
static doublereal safmin;
static integer ihi;
static doublecomplex ein[400] /* was [20][20] */;
static integer ilo;
static doublereal eps;
static integer knt;
/* Fortran I/O blocks */
static cilist io___7 = { 0, 0, 0, 0, 0 };
static cilist io___11 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___24 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___26 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___27 = { 0, 0, 0, fmt_9994, 0 };
#define e_subscr(a_1,a_2) (a_2)*20 + a_1 - 21
#define e_ref(a_1,a_2) e[e_subscr(a_1,a_2)]
#define ein_subscr(a_1,a_2) (a_2)*20 + a_1 - 21
#define ein_ref(a_1,a_2) ein[ein_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZCHKBK tests ZGEBAK, a routine for backward transformation of
the computed right or left eigenvectors if the orginal matrix
was preprocessed by balance subroutine ZGEBAL.
Arguments
=========
NIN (input) INTEGER
The logical unit number for input. NIN > 0.
NOUT (input) INTEGER
The logical unit number for output. NOUT > 0.
====================================================================== */
lmax[0] = 0;
lmax[1] = 0;
ninfo = 0;
knt = 0;
rmax = 0.;
eps = dlamch_("E");
safmin = dlamch_("S");
L10:
io___7.ciunit = *nin;
s_rsle(&io___7);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ilo, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ihi, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L60;
}
io___11.ciunit = *nin;
s_rsle(&io___11);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&scale[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_rsle();
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___14.ciunit = *nin;
s_rsle(&io___14);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&e_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&ein_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L30: */
}
++knt;
zgebak_("B", "R", &n, &ilo, &ihi, scale, &n, e, &c__20, &info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
vmax = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = e_subscr(i__, j);
i__4 = ein_subscr(i__, j);
z__2.r = e[i__3].r - ein[i__4].r, z__2.i = e[i__3].i - ein[i__4]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
x = ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), abs(d__2)
)) / eps;
i__3 = e_subscr(i__, j);
if ((d__1 = e[i__3].r, abs(d__1)) + (d__2 = d_imag(&e_ref(i__, j))
, abs(d__2)) > safmin) {
i__4 = e_subscr(i__, j);
x /= (d__3 = e[i__4].r, abs(d__3)) + (d__4 = d_imag(&e_ref(
i__, j)), abs(d__4));
}
vmax = max(vmax,x);
/* L40: */
}
/* L50: */
}
if (vmax > rmax) {
lmax[1] = knt;
rmax = vmax;
}
goto L10;
L60:
io___22.ciunit = *nout;
s_wsfe(&io___22);
e_wsfe();
io___23.ciunit = *nout;
s_wsfe(&io___23);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
e_wsfe();
io___24.ciunit = *nout;
s_wsfe(&io___24);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___25.ciunit = *nout;
s_wsfe(&io___25);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___26.ciunit = *nout;
s_wsfe(&io___26);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___27.ciunit = *nout;
s_wsfe(&io___27);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of ZCHKBK */
} /* zchkbk_ */
/* Subroutine */ int dlatm5_(integer *prtype, integer *m, integer *n,
doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
c__, integer *ldc, doublereal *d__, integer *ldd, doublereal *e,
integer *lde, doublereal *f, integer *ldf, doublereal *r__, integer *
ldr, doublereal *l, integer *ldl, doublereal *alpha, integer *qblcka,
integer *qblckb)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
d_offset, e_dim1, e_offset, f_dim1, f_offset, l_dim1, l_offset,
r_dim1, r_offset, i__1, i__2;
/* Builtin functions */
double sin(doublereal);
/* Local variables */
static integer i__, j, k;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
static doublereal imeps, reeps;
#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 d___ref(a_1,a_2) d__[(a_2)*d_dim1 + a_1]
#define e_ref(a_1,a_2) e[(a_2)*e_dim1 + a_1]
#define l_ref(a_1,a_2) l[(a_2)*l_dim1 + a_1]
#define r___ref(a_1,a_2) r__[(a_2)*r_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
DLATM5 generates matrices involved in the Generalized Sylvester
equation:
A * R - L * B = C
D * R - L * E = F
They also satisfy (the diagonalization condition)
[ I -L ] ( [ A -C ], [ D -F ] ) [ I R ] = ( [ A ], [ D ] )
[ I ] ( [ B ] [ E ] ) [ I ] ( [ B ] [ E ] )
Arguments
=========
PRTYPE (input) INTEGER
"Points" to a certian type of the matrices to generate
(see futher details).
M (input) INTEGER
Specifies the order of A and D and the number of rows in
C, F, R and L.
N (input) INTEGER
Specifies the order of B and E and the number of columns in
C, F, R and L.
A (output) DOUBLE PRECISION array, dimension (LDA, M).
On exit A M-by-M is initialized according to PRTYPE.
LDA (input) INTEGER
The leading dimension of A.
B (output) DOUBLE PRECISION array, dimension (LDB, N).
On exit B N-by-N is initialized according to PRTYPE.
LDB (input) INTEGER
The leading dimension of B.
C (output) DOUBLE PRECISION array, dimension (LDC, N).
On exit C M-by-N is initialized according to PRTYPE.
LDC (input) INTEGER
The leading dimension of C.
D (output) DOUBLE PRECISION array, dimension (LDD, M).
On exit D M-by-M is initialized according to PRTYPE.
LDD (input) INTEGER
The leading dimension of D.
E (output) DOUBLE PRECISION array, dimension (LDE, N).
On exit E N-by-N is initialized according to PRTYPE.
LDE (input) INTEGER
The leading dimension of E.
F (output) DOUBLE PRECISION array, dimension (LDF, N).
On exit F M-by-N is initialized according to PRTYPE.
LDF (input) INTEGER
The leading dimension of F.
R (output) DOUBLE PRECISION array, dimension (LDR, N).
On exit R M-by-N is initialized according to PRTYPE.
LDR (input) INTEGER
The leading dimension of R.
L (output) DOUBLE PRECISION array, dimension (LDL, N).
On exit L M-by-N is initialized according to PRTYPE.
LDL (input) INTEGER
The leading dimension of L.
ALPHA (input) DOUBLE PRECISION
Parameter used in generating PRTYPE = 1 and 5 matrices.
QBLCKA (input) INTEGER
When PRTYPE = 3, specifies the distance between 2-by-2
blocks on the diagonal in A. Otherwise, QBLCKA is not
referenced. QBLCKA > 1.
QBLCKB (input) INTEGER
When PRTYPE = 3, specifies the distance between 2-by-2
blocks on the diagonal in B. Otherwise, QBLCKB is not
referenced. QBLCKB > 1.
Further Details
===============
PRTYPE = 1: A and B are Jordan blocks, D and E are identity matrices
A : if (i == j) then A(i, j) = 1.0
if (j == i + 1) then A(i, j) = -1.0
else A(i, j) = 0.0, i, j = 1...M
B : if (i == j) then B(i, j) = 1.0 - ALPHA
if (j == i + 1) then B(i, j) = 1.0
else B(i, j) = 0.0, i, j = 1...N
D : if (i == j) then D(i, j) = 1.0
else D(i, j) = 0.0, i, j = 1...M
E : if (i == j) then E(i, j) = 1.0
else E(i, j) = 0.0, i, j = 1...N
L = R are chosen from [-10...10],
which specifies the right hand sides (C, F).
PRTYPE = 2 or 3: Triangular and/or quasi- triangular.
A : if (i <= j) then A(i, j) = [-1...1]
else A(i, j) = 0.0, i, j = 1...M
if (PRTYPE = 3) then
A(k + 1, k + 1) = A(k, k)
A(k + 1, k) = [-1...1]
sign(A(k, k + 1) = -(sin(A(k + 1, k))
k = 1, M - 1, QBLCKA
B : if (i <= j) then B(i, j) = [-1...1]
else B(i, j) = 0.0, i, j = 1...N
if (PRTYPE = 3) then
B(k + 1, k + 1) = B(k, k)
B(k + 1, k) = [-1...1]
sign(B(k, k + 1) = -(sign(B(k + 1, k))
k = 1, N - 1, QBLCKB
D : if (i <= j) then D(i, j) = [-1...1].
else D(i, j) = 0.0, i, j = 1...M
E : if (i <= j) then D(i, j) = [-1...1]
else E(i, j) = 0.0, i, j = 1...N
L, R are chosen from [-10...10],
which specifies the right hand sides (C, F).
PRTYPE = 4 Full
A(i, j) = [-10...10]
D(i, j) = [-1...1] i,j = 1...M
B(i, j) = [-10...10]
E(i, j) = [-1...1] i,j = 1...N
R(i, j) = [-10...10]
L(i, j) = [-1...1] i = 1..M ,j = 1...N
L, R specifies the right hand sides (C, F).
PRTYPE = 5 special case common and/or close eigs.
=====================================================================
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
d_dim1 = *ldd;
d_offset = 1 + d_dim1 * 1;
d__ -= d_offset;
e_dim1 = *lde;
e_offset = 1 + e_dim1 * 1;
e -= e_offset;
f_dim1 = *ldf;
f_offset = 1 + f_dim1 * 1;
f -= f_offset;
r_dim1 = *ldr;
r_offset = 1 + r_dim1 * 1;
r__ -= r_offset;
l_dim1 = *ldl;
l_offset = 1 + l_dim1 * 1;
l -= l_offset;
/* Function Body */
if (*prtype == 1) {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *m;
for (j = 1; j <= i__2; ++j) {
if (i__ == j) {
a_ref(i__, j) = 1.;
d___ref(i__, j) = 1.;
} else if (i__ == j - 1) {
a_ref(i__, j) = -1.;
d___ref(i__, j) = 0.;
} else {
a_ref(i__, j) = 0.;
d___ref(i__, j) = 0.;
}
/* L10: */
}
/* L20: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
if (i__ == j) {
b_ref(i__, j) = 1. - *alpha;
e_ref(i__, j) = 1.;
} else if (i__ == j - 1) {
b_ref(i__, j) = 1.;
e_ref(i__, j) = 0.;
} else {
b_ref(i__, j) = 0.;
e_ref(i__, j) = 0.;
}
/* L30: */
}
/* L40: */
}
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
r___ref(i__, j) = (.5 - sin((doublereal) (i__ / j))) * 20.;
l_ref(i__, j) = r___ref(i__, j);
/* L50: */
}
/* L60: */
}
} else if (*prtype == 2 || *prtype == 3) {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *m;
for (j = 1; j <= i__2; ++j) {
if (i__ <= j) {
a_ref(i__, j) = (.5 - sin((doublereal) i__)) * 2.;
d___ref(i__, j) = (.5 - sin((doublereal) (i__ * j))) * 2.;
} else {
a_ref(i__, j) = 0.;
d___ref(i__, j) = 0.;
}
/* L70: */
}
/* L80: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
if (i__ <= j) {
b_ref(i__, j) = (.5 - sin((doublereal) (i__ + j))) * 2.;
e_ref(i__, j) = (.5 - sin((doublereal) j)) * 2.;
} else {
b_ref(i__, j) = 0.;
e_ref(i__, j) = 0.;
}
/* L90: */
}
/* L100: */
}
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
r___ref(i__, j) = (.5 - sin((doublereal) (i__ * j))) * 20.;
l_ref(i__, j) = (.5 - sin((doublereal) (i__ + j))) * 20.;
/* L110: */
}
/* L120: */
}
if (*prtype == 3) {
if (*qblcka <= 1) {
*qblcka = 2;
}
i__1 = *m - 1;
i__2 = *qblcka;
for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
a_ref(k + 1, k + 1) = a_ref(k, k);
a_ref(k + 1, k) = -sin(a_ref(k, k + 1));
/* L130: */
}
if (*qblckb <= 1) {
*qblckb = 2;
}
i__2 = *n - 1;
i__1 = *qblckb;
for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
b_ref(k + 1, k + 1) = b_ref(k, k);
b_ref(k + 1, k) = -sin(b_ref(k, k + 1));
/* L140: */
}
}
} else if (*prtype == 4) {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *m;
for (j = 1; j <= i__2; ++j) {
a_ref(i__, j) = (.5 - sin((doublereal) (i__ * j))) * 20.;
d___ref(i__, j) = (.5 - sin((doublereal) (i__ + j))) * 2.;
/* L150: */
}
/* L160: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
b_ref(i__, j) = (.5 - sin((doublereal) (i__ + j))) * 20.;
e_ref(i__, j) = (.5 - sin((doublereal) (i__ * j))) * 2.;
/* L170: */
}
/* L180: */
}
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
r___ref(i__, j) = (.5 - sin((doublereal) (j / i__))) * 20.;
l_ref(i__, j) = (.5 - sin((doublereal) (i__ * j))) * 2.;
/* L190: */
}
/* L200: */
}
} else if (*prtype >= 5) {
reeps = 20. / *alpha;
imeps = -1.5 / *alpha;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
r___ref(i__, j) = (.5 - sin((doublereal) (i__ * j))) * *alpha
/ 20.;
l_ref(i__, j) = (.5 - sin((doublereal) (i__ + j))) * *alpha /
20.;
/* L210: */
}
/* L220: */
}
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
d___ref(i__, i__) = 1.;
/* L230: */
}
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ <= 4) {
a_ref(i__, i__) = 1.;
if (i__ > 2) {
a_ref(i__, i__) = reeps + 1.;
}
if (i__ % 2 != 0 && i__ < *m) {
a_ref(i__, i__ + 1) = imeps;
} else if (i__ > 1) {
a_ref(i__, i__ - 1) = -imeps;
}
} else if (i__ <= 8) {
if (i__ <= 6) {
a_ref(i__, i__) = reeps;
} else {
a_ref(i__, i__) = -reeps;
}
if (i__ % 2 != 0 && i__ < *m) {
a_ref(i__, i__ + 1) = 1.;
} else if (i__ > 1) {
a_ref(i__, i__ - 1) = -1.;
}
} else {
a_ref(i__, i__) = 1.;
if (i__ % 2 != 0 && i__ < *m) {
a_ref(i__, i__ + 1) = imeps * 2;
} else if (i__ > 1) {
a_ref(i__, i__ - 1) = -imeps * 2;
}
}
/* L240: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
e_ref(i__, i__) = 1.;
if (i__ <= 4) {
b_ref(i__, i__) = -1.;
if (i__ > 2) {
b_ref(i__, i__) = 1. - reeps;
}
if (i__ % 2 != 0 && i__ < *n) {
b_ref(i__, i__ + 1) = imeps;
} else if (i__ > 1) {
b_ref(i__, i__ - 1) = -imeps;
}
} else if (i__ <= 8) {
if (i__ <= 6) {
b_ref(i__, i__) = reeps;
} else {
b_ref(i__, i__) = -reeps;
}
if (i__ % 2 != 0 && i__ < *n) {
b_ref(i__, i__ + 1) = imeps + 1.;
} else if (i__ > 1) {
b_ref(i__, i__ - 1) = -1. - imeps;
}
} else {
b_ref(i__, i__) = 1. - reeps;
if (i__ % 2 != 0 && i__ < *n) {
b_ref(i__, i__ + 1) = imeps * 2;
} else if (i__ > 1) {
b_ref(i__, i__ - 1) = -imeps * 2;
}
}
/* L250: */
}
}
/* Compute rhs (C, F) */
dgemm_("N", "N", m, n, m, &c_b29, &a[a_offset], lda, &r__[r_offset], ldr,
&c_b30, &c__[c_offset], ldc);
dgemm_("N", "N", m, n, n, &c_b33, &l[l_offset], ldl, &b[b_offset], ldb, &
c_b29, &c__[c_offset], ldc);
dgemm_("N", "N", m, n, m, &c_b29, &d__[d_offset], ldd, &r__[r_offset],
ldr, &c_b30, &f[f_offset], ldf);
dgemm_("N", "N", m, n, n, &c_b33, &l[l_offset], ldl, &e[e_offset], lde, &
c_b29, &f[f_offset], ldf);
/* End of DLATM5 */
return 0;
} /* dlatm5_ */
/* Subroutine */ int ctgsyl_(char *trans, integer *ijob, integer *m, integer *
n, complex *a, integer *lda, complex *b, integer *ldb, complex *c__,
integer *ldc, complex *d__, integer *ldd, complex *e, integer *lde,
complex *f, integer *ldf, real *scale, real *dif, complex *work,
integer *lwork, integer *iwork, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CTGSYL solves the generalized Sylvester equation:
A * R - L * B = scale * C (1)
D * R - L * E = scale * F
where R and L are unknown m-by-n matrices, (A, D), (B, E) and
(C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,
respectively, with complex entries. A, B, D and E are upper
triangular (i.e., (A,D) and (B,E) in generalized Schur form).
The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1
is an output scaling factor chosen to avoid overflow.
In matrix notation (1) is equivalent to solve Zx = scale*b, where Z
is defined as
Z = [ kron(In, A) -kron(B', Im) ] (2)
[ kron(In, D) -kron(E', Im) ],
Here Ix is the identity matrix of size x and X' is the conjugate
transpose of X. Kron(X, Y) is the Kronecker product between the
matrices X and Y.
If TRANS = 'C', y in the conjugate transposed system Z'*y = scale*b
is solved for, which is equivalent to solve for R and L in
A' * R + D' * L = scale * C (3)
R * B' + L * E' = scale * -F
This case (TRANS = 'C') is used to compute an one-norm-based estimate
of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)
and (B,E), using CLACON.
If IJOB >= 1, CTGSYL computes a Frobenius norm-based estimate of
Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the
reciprocal of the smallest singular value of Z.
This is a level-3 BLAS algorithm.
Arguments
=========
TRANS (input) CHARACTER*1
= 'N': solve the generalized sylvester equation (1).
= 'C': solve the "conjugate transposed" system (3).
IJOB (input) INTEGER
Specifies what kind of functionality to be performed.
=0: solve (1) only.
=1: The functionality of 0 and 3.
=2: The functionality of 0 and 4.
=3: Only an estimate of Dif[(A,D), (B,E)] is computed.
(look ahead strategy is used).
=4: Only an estimate of Dif[(A,D), (B,E)] is computed.
(CGECON on sub-systems is used).
Not referenced if TRANS = 'C'.
M (input) INTEGER
The order of the matrices A and D, and the row dimension of
the matrices C, F, R and L.
N (input) INTEGER
The order of the matrices B and E, and the column dimension
of the matrices C, F, R and L.
A (input) COMPLEX array, dimension (LDA, M)
The upper triangular matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1, M).
B (input) COMPLEX array, dimension (LDB, N)
The upper triangular matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1, N).
C (input/output) COMPLEX array, dimension (LDC, N)
On entry, C contains the right-hand-side of the first matrix
equation in (1) or (3).
On exit, if IJOB = 0, 1 or 2, C has been overwritten by
the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,
the solution achieved during the computation of the
Dif-estimate.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1, M).
D (input) COMPLEX array, dimension (LDD, M)
The upper triangular matrix D.
LDD (input) INTEGER
The leading dimension of the array D. LDD >= max(1, M).
E (input) COMPLEX array, dimension (LDE, N)
The upper triangular matrix E.
LDE (input) INTEGER
The leading dimension of the array E. LDE >= max(1, N).
F (input/output) COMPLEX array, dimension (LDF, N)
On entry, F contains the right-hand-side of the second matrix
equation in (1) or (3).
On exit, if IJOB = 0, 1 or 2, F has been overwritten by
the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,
the solution achieved during the computation of the
Dif-estimate.
LDF (input) INTEGER
The leading dimension of the array F. LDF >= max(1, M).
DIF (output) REAL
On exit DIF is the reciprocal of a lower bound of the
reciprocal of the Dif-function, i.e. DIF is an upper bound of
Dif[(A,D), (B,E)] = sigma-min(Z), where Z as in (2).
IF IJOB = 0 or TRANS = 'C', DIF is not referenced.
SCALE (output) REAL
On exit SCALE is the scaling factor in (1) or (3).
If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,
to a slightly perturbed system but the input matrices A, B,
D and E have not been changed. If SCALE = 0, R and L will
hold the solutions to the homogenious system with C = F = 0.
WORK (workspace/output) COMPLEX array, dimension (LWORK)
IF IJOB = 0, WORK is not referenced. Otherwise,
LWORK (input) INTEGER
The dimension of the array WORK. LWORK > = 1.
If IJOB = 1 or 2 and TRANS = 'N', LWORK >= 2*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.
IWORK (workspace) INTEGER array, dimension (M+N+2)
If IJOB = 0, IWORK is not referenced.
INFO (output) INTEGER
=0: successful exit
<0: If INFO = -i, the i-th argument had an illegal value.
>0: (A, D) and (B, E) have common or very close
eigenvalues.
Further Details
===============
Based on contributions by
Bo Kagstrom and Peter Poromaa, Department of Computing Science,
Umea University, S-901 87 Umea, Sweden.
[1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
for Solving the Generalized Sylvester Equation and Estimating the
Separation between Regular Matrix Pairs, Report UMINF - 93.23,
Department of Computing Science, Umea University, S-901 87 Umea,
Sweden, December 1993, Revised April 1994, Also as LAPACK Working
Note 75. To appear in ACM Trans. on Math. Software, Vol 22,
No 1, 1996.
[2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester
Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.
Appl., 15(4):1045-1060, 1994.
[3] B. Kagstrom and L. Westin, Generalized Schur Methods with
Condition Estimators for Solving the Generalized Sylvester
Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,
July 1989, pp 745-751.
=====================================================================
Decode and test input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__2 = 2;
static integer c_n1 = -1;
static integer c__5 = 5;
static integer c__0 = 0;
static integer c__1 = 1;
static complex c_b16 = {0.f,0.f};
static complex c_b53 = {-1.f,0.f};
static complex c_b54 = {1.f,0.f};
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3,
i__4;
complex q__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static real dsum;
static integer i__, j, k, p, q;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), cgemm_(char *, char *, integer *, integer *, integer *
, complex *, complex *, integer *, complex *, integer *, complex *
, complex *, integer *);
extern logical lsame_(char *, char *);
static integer ifunc, linfo;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
static integer lwmin;
static real scale2;
extern /* Subroutine */ int ctgsy2_(char *, integer *, integer *, integer
*, complex *, integer *, complex *, integer *, complex *, integer
*, complex *, integer *, complex *, integer *, complex *, integer
*, real *, real *, real *, integer *);
static integer ie, je, mb, nb;
static real dscale;
static integer is, js, pq;
static real scaloc;
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), xerbla_(char *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer iround;
static logical notran;
static integer isolve;
static logical lquery;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1
#define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)]
#define d___subscr(a_1,a_2) (a_2)*d_dim1 + a_1
#define d___ref(a_1,a_2) d__[d___subscr(a_1,a_2)]
#define e_subscr(a_1,a_2) (a_2)*e_dim1 + a_1
#define e_ref(a_1,a_2) e[e_subscr(a_1,a_2)]
#define f_subscr(a_1,a_2) (a_2)*f_dim1 + a_1
#define f_ref(a_1,a_2) f[f_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
d_dim1 = *ldd;
d_offset = 1 + d_dim1 * 1;
d__ -= d_offset;
e_dim1 = *lde;
e_offset = 1 + e_dim1 * 1;
e -= e_offset;
f_dim1 = *ldf;
f_offset = 1 + f_dim1 * 1;
f -= f_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
notran = lsame_(trans, "N");
lquery = *lwork == -1;
if ((*ijob == 1 || *ijob == 2) && notran) {
/* Computing MAX */
i__1 = 1, i__2 = (*m << 1) * *n;
lwmin = max(i__1,i__2);
} else {
lwmin = 1;
}
if (! notran && ! lsame_(trans, "C")) {
*info = -1;
} else if (*ijob < 0 || *ijob > 4) {
*info = -2;
} else if (*m <= 0) {
*info = -3;
} else if (*n <= 0) {
*info = -4;
} else if (*lda < max(1,*m)) {
*info = -6;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*ldc < max(1,*m)) {
*info = -10;
} else if (*ldd < max(1,*m)) {
*info = -12;
} else if (*lde < max(1,*n)) {
*info = -14;
} else if (*ldf < max(1,*m)) {
*info = -16;
} else if (*lwork < lwmin && ! lquery) {
*info = -20;
}
if (*info == 0) {
work[1].r = (real) lwmin, work[1].i = 0.f;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTGSYL", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Determine optimal block sizes MB and NB */
mb = ilaenv_(&c__2, "CTGSYL", trans, m, n, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
nb = ilaenv_(&c__5, "CTGSYL", trans, m, n, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
isolve = 1;
ifunc = 0;
if (*ijob >= 3 && notran) {
ifunc = *ijob - 2;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
ccopy_(m, &c_b16, &c__0, &c___ref(1, j), &c__1);
ccopy_(m, &c_b16, &c__0, &f_ref(1, j), &c__1);
/* L10: */
}
} else if (*ijob >= 1 && notran) {
isolve = 2;
}
if (mb <= 1 && nb <= 1 || mb >= *m && nb >= *n) {
/* Use unblocked Level 2 solver */
i__1 = isolve;
for (iround = 1; iround <= i__1; ++iround) {
*scale = 1.f;
dscale = 0.f;
dsum = 1.f;
pq = *m * *n;
ctgsy2_(trans, &ifunc, m, n, &a[a_offset], lda, &b[b_offset], ldb,
&c__[c_offset], ldc, &d__[d_offset], ldd, &e[e_offset],
lde, &f[f_offset], ldf, scale, &dsum, &dscale, info);
if (dscale != 0.f) {
if (*ijob == 1 || *ijob == 3) {
*dif = sqrt((real) ((*m << 1) * *n)) / (dscale * sqrt(
dsum));
} else {
*dif = sqrt((real) pq) / (dscale * sqrt(dsum));
}
}
if (isolve == 2 && iround == 1) {
ifunc = *ijob;
scale2 = *scale;
clacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m);
clacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m);
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
ccopy_(m, &c_b16, &c__0, &c___ref(1, j), &c__1);
ccopy_(m, &c_b16, &c__0, &f_ref(1, j), &c__1);
/* L20: */
}
} else if (isolve == 2 && iround == 2) {
clacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc);
clacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf);
*scale = scale2;
}
/* L30: */
}
return 0;
}
/* Determine block structure of A */
p = 0;
i__ = 1;
L40:
if (i__ > *m) {
goto L50;
}
++p;
iwork[p] = i__;
i__ += mb;
if (i__ >= *m) {
goto L50;
}
goto L40;
L50:
iwork[p + 1] = *m + 1;
if (iwork[p] == iwork[p + 1]) {
--p;
}
/* Determine block structure of B */
q = p + 1;
j = 1;
L60:
if (j > *n) {
goto L70;
}
++q;
iwork[q] = j;
j += nb;
if (j >= *n) {
goto L70;
}
goto L60;
L70:
iwork[q + 1] = *n + 1;
if (iwork[q] == iwork[q + 1]) {
--q;
}
if (notran) {
i__1 = isolve;
for (iround = 1; iround <= i__1; ++iround) {
/* Solve (I, J) - subsystem
A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
for I = P, P - 1, ..., 1; J = 1, 2, ..., Q */
pq = 0;
*scale = 1.f;
dscale = 0.f;
dsum = 1.f;
i__2 = q;
for (j = p + 2; j <= i__2; ++j) {
js = iwork[j];
je = iwork[j + 1] - 1;
nb = je - js + 1;
for (i__ = p; i__ >= 1; --i__) {
is = iwork[i__];
ie = iwork[i__ + 1] - 1;
mb = ie - is + 1;
ctgsy2_(trans, &ifunc, &mb, &nb, &a_ref(is, is), lda, &
b_ref(js, js), ldb, &c___ref(is, js), ldc, &
d___ref(is, is), ldd, &e_ref(js, js), lde, &f_ref(
is, js), ldf, &scaloc, &dsum, &dscale, &linfo);
if (linfo > 0) {
*info = linfo;
}
pq += mb * nb;
if (scaloc != 1.f) {
i__3 = js - 1;
for (k = 1; k <= i__3; ++k) {
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &c___ref(1, k), &c__1);
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &f_ref(1, k), &c__1);
/* L80: */
}
i__3 = je;
for (k = js; k <= i__3; ++k) {
i__4 = is - 1;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &c___ref(1, k), &c__1);
i__4 = is - 1;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &f_ref(1, k), &c__1);
/* L90: */
}
i__3 = je;
for (k = js; k <= i__3; ++k) {
i__4 = *m - ie;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &c___ref(ie + 1, k), &c__1);
i__4 = *m - ie;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &f_ref(ie + 1, k), &c__1);
/* L100: */
}
i__3 = *n;
for (k = je + 1; k <= i__3; ++k) {
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &c___ref(1, k), &c__1);
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &f_ref(1, k), &c__1);
/* L110: */
}
*scale *= scaloc;
}
/* Substitute R(I,J) and L(I,J) into remaining equation. */
if (i__ > 1) {
i__3 = is - 1;
cgemm_("N", "N", &i__3, &nb, &mb, &c_b53, &a_ref(1,
is), lda, &c___ref(is, js), ldc, &c_b54, &
c___ref(1, js), ldc);
i__3 = is - 1;
cgemm_("N", "N", &i__3, &nb, &mb, &c_b53, &d___ref(1,
is), ldd, &c___ref(is, js), ldc, &c_b54, &
f_ref(1, js), ldf);
}
if (j < q) {
i__3 = *n - je;
cgemm_("N", "N", &mb, &i__3, &nb, &c_b54, &f_ref(is,
js), ldf, &b_ref(js, je + 1), ldb, &c_b54, &
c___ref(is, je + 1), ldc);
i__3 = *n - je;
cgemm_("N", "N", &mb, &i__3, &nb, &c_b54, &f_ref(is,
js), ldf, &e_ref(js, je + 1), lde, &c_b54, &
f_ref(is, je + 1), ldf);
}
/* L120: */
}
/* L130: */
}
if (dscale != 0.f) {
if (*ijob == 1 || *ijob == 3) {
*dif = sqrt((real) ((*m << 1) * *n)) / (dscale * sqrt(
dsum));
} else {
*dif = sqrt((real) pq) / (dscale * sqrt(dsum));
}
}
if (isolve == 2 && iround == 1) {
ifunc = *ijob;
scale2 = *scale;
clacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m);
clacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m);
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
ccopy_(m, &c_b16, &c__0, &c___ref(1, j), &c__1);
ccopy_(m, &c_b16, &c__0, &f_ref(1, j), &c__1);
/* L140: */
}
} else if (isolve == 2 && iround == 2) {
clacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc);
clacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf);
*scale = scale2;
}
/* L150: */
}
} else {
/* Solve transposed (I, J)-subsystem
A(I, I)' * R(I, J) + D(I, I)' * L(I, J) = C(I, J)
R(I, J) * B(J, J) + L(I, J) * E(J, J) = -F(I, J)
for I = 1,2,..., P; J = Q, Q-1,..., 1 */
*scale = 1.f;
i__1 = p;
for (i__ = 1; i__ <= i__1; ++i__) {
is = iwork[i__];
ie = iwork[i__ + 1] - 1;
mb = ie - is + 1;
i__2 = p + 2;
for (j = q; j >= i__2; --j) {
js = iwork[j];
je = iwork[j + 1] - 1;
nb = je - js + 1;
ctgsy2_(trans, &ifunc, &mb, &nb, &a_ref(is, is), lda, &b_ref(
js, js), ldb, &c___ref(is, js), ldc, &d___ref(is, is),
ldd, &e_ref(js, js), lde, &f_ref(is, js), ldf, &
scaloc, &dsum, &dscale, &linfo);
if (linfo > 0) {
*info = linfo;
}
if (scaloc != 1.f) {
i__3 = js - 1;
for (k = 1; k <= i__3; ++k) {
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &c___ref(1, k), &c__1);
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &f_ref(1, k), &c__1);
/* L160: */
}
i__3 = je;
for (k = js; k <= i__3; ++k) {
i__4 = is - 1;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &c___ref(1, k), &c__1);
i__4 = is - 1;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &f_ref(1, k), &c__1);
/* L170: */
}
i__3 = je;
for (k = js; k <= i__3; ++k) {
i__4 = *m - ie;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &c___ref(ie + 1, k), &c__1);
i__4 = *m - ie;
q__1.r = scaloc, q__1.i = 0.f;
cscal_(&i__4, &q__1, &f_ref(ie + 1, k), &c__1);
/* L180: */
}
i__3 = *n;
for (k = je + 1; k <= i__3; ++k) {
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &c___ref(1, k), &c__1);
q__1.r = scaloc, q__1.i = 0.f;
cscal_(m, &q__1, &f_ref(1, k), &c__1);
/* L190: */
}
*scale *= scaloc;
}
/* Substitute R(I,J) and L(I,J) into remaining equation. */
if (j > p + 2) {
i__3 = js - 1;
cgemm_("N", "C", &mb, &i__3, &nb, &c_b54, &c___ref(is, js)
, ldc, &b_ref(1, js), ldb, &c_b54, &f_ref(is, 1),
ldf);
i__3 = js - 1;
cgemm_("N", "C", &mb, &i__3, &nb, &c_b54, &f_ref(is, js),
ldf, &e_ref(1, js), lde, &c_b54, &f_ref(is, 1),
ldf);
}
if (i__ < p) {
i__3 = *m - ie;
cgemm_("C", "N", &i__3, &nb, &mb, &c_b53, &a_ref(is, ie +
1), lda, &c___ref(is, js), ldc, &c_b54, &c___ref(
ie + 1, js), ldc);
i__3 = *m - ie;
cgemm_("C", "N", &i__3, &nb, &mb, &c_b53, &d___ref(is, ie
+ 1), ldd, &f_ref(is, js), ldf, &c_b54, &c___ref(
ie + 1, js), ldc);
}
/* L200: */
}
/* L210: */
}
}
work[1].r = (real) lwmin, work[1].i = 0.f;
return 0;
/* End of CTGSYL */
} /* ctgsyl_ */
/* Subroutine */ int cget52_(logical *left, integer *n, complex *a, integer *
lda, complex *b, integer *ldb, complex *e, integer *lde, complex *
alpha, complex *beta, complex *work, real *rwork, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, e_dim1, e_offset, i__1, i__2,
i__3;
real r__1, r__2, r__3, r__4, r__5, r__6;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
static integer jvec;
static real temp1;
static integer j;
static complex betai;
static real scale, abmax;
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *);
static real anorm, bnorm, enorm;
static char trans[1];
static complex acoeff, bcoeff;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
static complex alphai;
extern doublereal slamch_(char *);
static real alfmax, safmin;
static char normab[1];
static real safmax, betmax, enrmer, errnrm, ulp;
#define e_subscr(a_1,a_2) (a_2)*e_dim1 + a_1
#define e_ref(a_1,a_2) e[e_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CGET52 does an eigenvector check for the generalized eigenvalue
problem.
The basic test for right eigenvectors is:
| b(i) A E(i) - a(i) B E(i) |
RESULT(1) = max -------------------------------
i n ulp max( |b(i) A|, |a(i) B| )
using the 1-norm. Here, a(i)/b(i) = w is the i-th generalized
eigenvalue of A - w B, or, equivalently, b(i)/a(i) = m is the i-th
generalized eigenvalue of m A - B.
H H _ _
For left eigenvectors, A , B , a, and b are used.
CGET52 also tests the normalization of E. Each eigenvector is
supposed to be normalized so that the maximum "absolute value"
of its elements is 1, where in this case, "absolute value"
of a complex value x is |Re(x)| + |Im(x)| ; let us call this
maximum "absolute value" norm of a vector v M(v).
if a(i)=b(i)=0, then the eigenvector is set to be the jth coordinate
vector. The normalization test is:
RESULT(2) = max | M(v(i)) - 1 | / ( n ulp )
eigenvectors v(i)
Arguments
=========
LEFT (input) LOGICAL
=.TRUE.: The eigenvectors in the columns of E are assumed
to be *left* eigenvectors.
=.FALSE.: The eigenvectors in the columns of E are assumed
to be *right* eigenvectors.
N (input) INTEGER
The size of the matrices. If it is zero, CGET52 does
nothing. It must be at least zero.
A (input) COMPLEX array, dimension (LDA, N)
The matrix A.
LDA (input) INTEGER
The leading dimension of A. It must be at least 1
and at least N.
B (input) COMPLEX array, dimension (LDB, N)
The matrix B.
LDB (input) INTEGER
The leading dimension of B. It must be at least 1
and at least N.
E (input) COMPLEX array, dimension (LDE, N)
The matrix of eigenvectors. It must be O( 1 ).
LDE (input) INTEGER
The leading dimension of E. It must be at least 1 and at
least N.
ALPHA (input) COMPLEX array, dimension (N)
The values a(i) as described above, which, along with b(i),
define the generalized eigenvalues.
BETA (input) COMPLEX array, dimension (N)
The values b(i) as described above, which, along with a(i),
define the generalized eigenvalues.
WORK (workspace) COMPLEX array, dimension (N**2)
RWORK (workspace) REAL array, dimension (N)
RESULT (output) REAL array, dimension (2)
The values computed by the test described above. If A E or
B E is likely to overflow, then RESULT(1:2) is set to
10 / ulp.
=====================================================================
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
e_dim1 = *lde;
e_offset = 1 + e_dim1 * 1;
e -= e_offset;
--alpha;
--beta;
--work;
--rwork;
--result;
/* Function Body */
result[1] = 0.f;
result[2] = 0.f;
if (*n <= 0) {
return 0;
}
safmin = slamch_("Safe minimum");
safmax = 1.f / safmin;
ulp = slamch_("Epsilon") * slamch_("Base");
if (*left) {
*(unsigned char *)trans = 'C';
*(unsigned char *)normab = 'I';
} else {
*(unsigned char *)trans = 'N';
*(unsigned char *)normab = 'O';
}
/* Norm of A, B, and E:
Computing MAX */
r__1 = clange_(normab, n, n, &a[a_offset], lda, &rwork[1]);
anorm = dmax(r__1,safmin);
/* Computing MAX */
r__1 = clange_(normab, n, n, &b[b_offset], ldb, &rwork[1]);
bnorm = dmax(r__1,safmin);
/* Computing MAX */
r__1 = clange_("O", n, n, &e[e_offset], lde, &rwork[1]);
enorm = dmax(r__1,ulp);
alfmax = safmax / dmax(1.f,bnorm);
betmax = safmax / dmax(1.f,anorm);
/* Compute error matrix.
Column i = ( b(i) A - a(i) B ) E(i) / max( |a(i) B| |b(i) A| ) */
i__1 = *n;
for (jvec = 1; jvec <= i__1; ++jvec) {
i__2 = jvec;
alphai.r = alpha[i__2].r, alphai.i = alpha[i__2].i;
i__2 = jvec;
betai.r = beta[i__2].r, betai.i = beta[i__2].i;
/* Computing MAX */
r__5 = (r__1 = alphai.r, dabs(r__1)) + (r__2 = r_imag(&alphai), dabs(
r__2)), r__6 = (r__3 = betai.r, dabs(r__3)) + (r__4 = r_imag(&
betai), dabs(r__4));
abmax = dmax(r__5,r__6);
if ((r__1 = alphai.r, dabs(r__1)) + (r__2 = r_imag(&alphai), dabs(
r__2)) > alfmax || (r__3 = betai.r, dabs(r__3)) + (r__4 =
r_imag(&betai), dabs(r__4)) > betmax || abmax < 1.f) {
scale = 1.f / dmax(abmax,safmin);
q__1.r = scale * alphai.r, q__1.i = scale * alphai.i;
alphai.r = q__1.r, alphai.i = q__1.i;
q__1.r = scale * betai.r, q__1.i = scale * betai.i;
betai.r = q__1.r, betai.i = q__1.i;
}
/* Computing MAX */
r__5 = ((r__1 = alphai.r, dabs(r__1)) + (r__2 = r_imag(&alphai), dabs(
r__2))) * bnorm, r__6 = ((r__3 = betai.r, dabs(r__3)) + (r__4
= r_imag(&betai), dabs(r__4))) * anorm, r__5 = max(r__5,r__6);
scale = 1.f / dmax(r__5,safmin);
q__1.r = scale * betai.r, q__1.i = scale * betai.i;
acoeff.r = q__1.r, acoeff.i = q__1.i;
q__1.r = scale * alphai.r, q__1.i = scale * alphai.i;
bcoeff.r = q__1.r, bcoeff.i = q__1.i;
if (*left) {
r_cnjg(&q__1, &acoeff);
acoeff.r = q__1.r, acoeff.i = q__1.i;
r_cnjg(&q__1, &bcoeff);
bcoeff.r = q__1.r, bcoeff.i = q__1.i;
}
cgemv_(trans, n, n, &acoeff, &a[a_offset], lda, &e_ref(1, jvec), &
c__1, &c_b1, &work[*n * (jvec - 1) + 1], &c__1);
q__1.r = -bcoeff.r, q__1.i = -bcoeff.i;
cgemv_(trans, n, n, &q__1, &b[b_offset], lda, &e_ref(1, jvec), &c__1,
&c_b2, &work[*n * (jvec - 1) + 1], &c__1);
/* L10: */
}
errnrm = clange_("One", n, n, &work[1], n, &rwork[1]) / enorm;
/* Compute RESULT(1) */
result[1] = errnrm / ulp;
/* Normalization of E: */
enrmer = 0.f;
i__1 = *n;
for (jvec = 1; jvec <= i__1; ++jvec) {
temp1 = 0.f;
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
i__3 = e_subscr(j, jvec);
r__3 = temp1, r__4 = (r__1 = e[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&e_ref(j, jvec)), dabs(r__2));
temp1 = dmax(r__3,r__4);
/* L20: */
}
/* Computing MAX */
r__1 = enrmer, r__2 = temp1 - 1.f;
enrmer = dmax(r__1,r__2);
/* L30: */
}
/* Compute RESULT(2) : the normalization error in E. */
result[2] = enrmer / ((real) (*n) * ulp);
return 0;
/* End of CGET52 */
} /* cget52_ */
/* Subroutine */ int dlakf2_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *b, doublereal *d__, doublereal *e, doublereal *z__,
integer *ldz)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, d_dim1, d_offset, e_dim1,
e_offset, z_dim1, z_offset, i__1, i__2, i__3;
/* Local variables */
static integer i__, j, l, ik, jk, mn;
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
static integer mn2;
#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 d___ref(a_1,a_2) d__[(a_2)*d_dim1 + a_1]
#define e_ref(a_1,a_2) e[(a_2)*e_dim1 + a_1]
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
Form the 2*M*N by 2*M*N matrix
Z = [ kron(In, A) -kron(B', Im) ]
[ kron(In, D) -kron(E', Im) ],
where In is the identity matrix of size n and X' is the transpose
of X. kron(X, Y) is the Kronecker product between the matrices X
and Y.
Arguments
=========
M (input) INTEGER
Size of matrix, must be >= 1.
N (input) INTEGER
Size of matrix, must be >= 1.
A (input) DOUBLE PRECISION, dimension ( LDA, M )
The matrix A in the output matrix Z.
LDA (input) INTEGER
The leading dimension of A, B, D, and E. ( LDA >= M+N )
B (input) DOUBLE PRECISION, dimension ( LDA, N )
D (input) DOUBLE PRECISION, dimension ( LDA, M )
E (input) DOUBLE PRECISION, dimension ( LDA, N )
The matrices used in forming the output matrix Z.
Z (output) DOUBLE PRECISION, dimension ( LDZ, 2*M*N )
The resultant Kronecker M*N*2 by M*N*2 matrix (see above.)
LDZ (input) INTEGER
The leading dimension of Z. ( LDZ >= 2*M*N )
====================================================================
Initialize Z
Parameter adjustments */
e_dim1 = *lda;
e_offset = 1 + e_dim1 * 1;
e -= e_offset;
d_dim1 = *lda;
d_offset = 1 + d_dim1 * 1;
d__ -= d_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
/* Function Body */
mn = *m * *n;
mn2 = mn << 1;
dlaset_("Full", &mn2, &mn2, &c_b3, &c_b3, &z__[z_offset], ldz);
ik = 1;
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
/* form kron(In, A) */
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = *m;
for (j = 1; j <= i__3; ++j) {
z___ref(ik + i__ - 1, ik + j - 1) = a_ref(i__, j);
/* L10: */
}
/* L20: */
}
/* form kron(In, D) */
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = *m;
for (j = 1; j <= i__3; ++j) {
z___ref(ik + mn + i__ - 1, ik + j - 1) = d___ref(i__, j);
/* L30: */
}
/* L40: */
}
ik += *m;
/* L50: */
}
ik = 1;
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
jk = mn + 1;
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
/* form -kron(B', Im) */
i__3 = *m;
for (i__ = 1; i__ <= i__3; ++i__) {
z___ref(ik + i__ - 1, jk + i__ - 1) = -b_ref(j, l);
/* L60: */
}
/* form -kron(E', Im) */
i__3 = *m;
for (i__ = 1; i__ <= i__3; ++i__) {
z___ref(ik + mn + i__ - 1, jk + i__ - 1) = -e_ref(j, l);
/* L70: */
}
jk += *m;
/* L80: */
}
ik += *m;
/* L90: */
}
return 0;
/* End of DLAKF2 */
} /* dlakf2_ */
/* Subroutine */ int dchkgk_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(1x,\002.. test output of DGGBAK .. \002)";
static char fmt_9998[] = "(\002 value of largest test error "
" =\002,d12.3)";
static char fmt_9997[] = "(\002 example number where DGGBAL info is not "
"0 =\002,i4)";
static char fmt_9996[] = "(\002 example number where DGGBAK(L) info is n"
"ot 0 =\002,i4)";
static char fmt_9995[] = "(\002 example number where DGGBAK(R) info is n"
"ot 0 =\002,i4)";
static char fmt_9994[] = "(\002 example number having largest error "
" =\002,i4)";
static char fmt_9993[] = "(\002 number of examples where info is not 0 "
" =\002,i4)";
static char fmt_9992[] = "(\002 total number of examples tested "
" =\002,i4)";
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2, d__3;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void), s_wsfe(cilist *), e_wsfe(void), do_fio(integer *,
char *, ftnlen);
/* Local variables */
static integer info, lmax[4];
static doublereal rmax, vmax, work[2500] /* was [50][50] */, a[2500]
/* was [50][50] */, b[2500] /* was [50][50] */, e[2500] /*
was [50][50] */, f[2500] /* was [50][50] */;
static integer i__, j, m, n;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
static integer ninfo;
static doublereal anorm, bnorm, af[2500] /* was [50][50] */, bf[2500]
/* was [50][50] */;
extern /* Subroutine */ int dggbak_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, integer *), dggbal_(char *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
static doublereal vl[2500] /* was [50][50] */, lscale[50], vr[2500]
/* was [50][50] */, rscale[50];
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *);
static integer ihi, ilo;
static doublereal eps, vlf[2500] /* was [50][50] */;
static integer knt;
static doublereal vrf[2500] /* was [50][50] */;
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, 0, 0 };
static cilist io___10 = { 0, 0, 0, 0, 0 };
static cilist io___13 = { 0, 0, 0, 0, 0 };
static cilist io___15 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9992, 0 };
#define a_ref(a_1,a_2) a[(a_2)*50 + a_1 - 51]
#define b_ref(a_1,a_2) b[(a_2)*50 + a_1 - 51]
#define e_ref(a_1,a_2) e[(a_2)*50 + a_1 - 51]
#define f_ref(a_1,a_2) f[(a_2)*50 + a_1 - 51]
#define vl_ref(a_1,a_2) vl[(a_2)*50 + a_1 - 51]
#define vr_ref(a_1,a_2) vr[(a_2)*50 + a_1 - 51]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DCHKGK tests DGGBAK, a routine for backward balancing of
a matrix pair (A, B).
Arguments
=========
NIN (input) INTEGER
The logical unit number for input. NIN > 0.
NOUT (input) INTEGER
The logical unit number for output. NOUT > 0.
=====================================================================
Initialization */
lmax[0] = 0;
lmax[1] = 0;
lmax[2] = 0;
lmax[3] = 0;
ninfo = 0;
knt = 0;
rmax = 0.;
eps = dlamch_("Precision");
L10:
io___6.ciunit = *nin;
s_rsle(&io___6);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&m, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L100;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___10.ciunit = *nin;
s_rsle(&io___10);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&a_ref(i__, j), (ftnlen)sizeof(
doublereal));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___13.ciunit = *nin;
s_rsle(&io___13);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&b_ref(i__, j), (ftnlen)sizeof(
doublereal));
}
e_rsle();
/* L30: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___15.ciunit = *nin;
s_rsle(&io___15);
i__2 = m;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&vl_ref(i__, j), (ftnlen)sizeof(
doublereal));
}
e_rsle();
/* L40: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = m;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&vr_ref(i__, j), (ftnlen)sizeof(
doublereal));
}
e_rsle();
/* L50: */
}
++knt;
anorm = dlange_("M", &n, &n, a, &c__50, work);
bnorm = dlange_("M", &n, &n, b, &c__50, work);
dlacpy_("FULL", &n, &n, a, &c__50, af, &c__50);
dlacpy_("FULL", &n, &n, b, &c__50, bf, &c__50);
dggbal_("B", &n, a, &c__50, b, &c__50, &ilo, &ihi, lscale, rscale, work, &
info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
dlacpy_("FULL", &n, &m, vl, &c__50, vlf, &c__50);
dlacpy_("FULL", &n, &m, vr, &c__50, vrf, &c__50);
dggbak_("B", "L", &n, &ilo, &ihi, lscale, rscale, &m, vl, &c__50, &info);
if (info != 0) {
++ninfo;
lmax[1] = knt;
}
dggbak_("B", "R", &n, &ilo, &ihi, lscale, rscale, &m, vr, &c__50, &info);
if (info != 0) {
++ninfo;
lmax[2] = knt;
}
/* Test of DGGBAK
Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR
where tilde(A) denotes the transformed matrix. */
dgemm_("N", "N", &n, &m, &n, &c_b52, af, &c__50, vr, &c__50, &c_b55, work,
&c__50);
dgemm_("T", "N", &m, &m, &n, &c_b52, vl, &c__50, work, &c__50, &c_b55, e,
&c__50);
dgemm_("N", "N", &n, &m, &n, &c_b52, a, &c__50, vrf, &c__50, &c_b55, work,
&c__50);
dgemm_("T", "N", &m, &m, &n, &c_b52, vlf, &c__50, work, &c__50, &c_b55, f,
&c__50);
vmax = 0.;
i__1 = m;
for (j = 1; j <= i__1; ++j) {
i__2 = m;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = e_ref(i__, j) - f_ref(i__, j), abs(
d__1));
vmax = max(d__2,d__3);
/* L60: */
}
/* L70: */
}
vmax /= eps * max(anorm,bnorm);
if (vmax > rmax) {
lmax[3] = knt;
rmax = vmax;
}
/* Check tilde(VL)'*B*tilde(VR) - VL'*tilde(B)*VR */
dgemm_("N", "N", &n, &m, &n, &c_b52, bf, &c__50, vr, &c__50, &c_b55, work,
&c__50);
dgemm_("T", "N", &m, &m, &n, &c_b52, vl, &c__50, work, &c__50, &c_b55, e,
&c__50);
dgemm_("N", "N", &n, &m, &n, &c_b52, b, &c__50, vrf, &c__50, &c_b55, work,
&c__50);
dgemm_("T", "N", &m, &m, &n, &c_b52, vlf, &c__50, work, &c__50, &c_b55, f,
&c__50);
vmax = 0.;
i__1 = m;
for (j = 1; j <= i__1; ++j) {
i__2 = m;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = e_ref(i__, j) - f_ref(i__, j), abs(
d__1));
vmax = max(d__2,d__3);
/* L80: */
}
/* L90: */
}
vmax /= eps * max(anorm,bnorm);
if (vmax > rmax) {
lmax[3] = knt;
rmax = vmax;
}
goto L10;
L100:
io___34.ciunit = *nout;
s_wsfe(&io___34);
e_wsfe();
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
e_wsfe();
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
e_wsfe();
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&lmax[3], (ftnlen)sizeof(integer));
e_wsfe();
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of DCHKGK */
} /* dchkgk_ */
