Subroutine */ int header_(void)
{
/* Initialized data */
static char l[6*10] = "ZDOTC " "ZDOTU " "ZAXPY " "ZCOPY " "ZSWAP " "DZNR"
"M2" "DZASUM" "ZSCAL " "ZDSCAL" "IZAMAX";
/* Format strings */
static char fmt_99999[] = "(/\002 Test of subprogram number\002,i3,12x,a"
"6)";
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Fortran I/O blocks */
static cilist io___6 = { 0, 6, 0, fmt_99999, 0 };
#define l_ref(a_0,a_1) &l[(a_1)*6 + a_0 - 6]
s_wsfe(&io___6);
do_fio(&c__1, (char *)&combla_1.icase, (ftnlen)sizeof(integer));
do_fio(&c__1, l_ref(0, combla_1.icase), (ftnlen)6);
e_wsfe();
return 0;
} /* header_ */
/* Subroutine */ int cqlt01_(integer *m, integer *n, complex *a, complex *af,
complex *q, complex *l, integer *lda, complex *tau, complex *work,
integer *lwork, real *rwork, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
q_offset, i__1, i__2;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer info;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *), cherk_(char *,
char *, integer *, integer *, real *, complex *, integer *, real *
, complex *, integer *);
static real resid, anorm;
static integer minmn;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
extern /* Subroutine */ int cgeqlf_(integer *, integer *, complex *,
integer *, complex *, complex *, integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *);
extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
real *);
extern /* Subroutine */ int cungql_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, integer *);
static real eps;
#define l_subscr(a_1,a_2) (a_2)*l_dim1 + a_1
#define l_ref(a_1,a_2) l[l_subscr(a_1,a_2)]
#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1
#define af_ref(a_1,a_2) af[af_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
=======
CQLT01 tests CGEQLF, which computes the QL factorization of an m-by-n
matrix A, and partially tests CUNGQL which forms the m-by-m
orthogonal matrix Q.
CQLT01 compares L with Q'*A, and checks that Q is orthogonal.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
A (input) COMPLEX array, dimension (LDA,N)
The m-by-n matrix A.
AF (output) COMPLEX array, dimension (LDA,N)
Details of the QL factorization of A, as returned by CGEQLF.
See CGEQLF for further details.
Q (output) COMPLEX array, dimension (LDA,M)
The m-by-m orthogonal matrix Q.
L (workspace) COMPLEX array, dimension (LDA,max(M,N))
LDA (input) INTEGER
The leading dimension of the arrays A, AF, Q and R.
LDA >= max(M,N).
TAU (output) COMPLEX array, dimension (min(M,N))
The scalar factors of the elementary reflectors, as returned
by CGEQLF.
WORK (workspace) COMPLEX array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK.
RWORK (workspace) REAL array, dimension (M)
RESULT (output) REAL array, dimension (2)
The test ratios:
RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS )
RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
=====================================================================
Parameter adjustments */
l_dim1 = *lda;
l_offset = 1 + l_dim1 * 1;
l -= l_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
minmn = min(*m,*n);
eps = slamch_("Epsilon");
/* Copy the matrix A to the array AF. */
clacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
/* Factorize the matrix A in the array AF. */
s_copy(srnamc_1.srnamt, "CGEQLF", (ftnlen)6, (ftnlen)6);
cgeqlf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy details of Q */
claset_("Full", m, m, &c_b1, &c_b1, &q[q_offset], lda);
if (*m >= *n) {
if (*n < *m && *n > 0) {
i__1 = *m - *n;
clacpy_("Full", &i__1, n, &af[af_offset], lda, &q_ref(1, *m - *n
+ 1), lda);
}
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
clacpy_("Upper", &i__1, &i__2, &af_ref(*m - *n + 1, 2), lda, &
q_ref(*m - *n + 1, *m - *n + 2), lda);
}
} else {
if (*m > 1) {
i__1 = *m - 1;
i__2 = *m - 1;
clacpy_("Upper", &i__1, &i__2, &af_ref(1, *n - *m + 2), lda, &
q_ref(1, 2), lda);
}
}
/* Generate the m-by-m matrix Q */
s_copy(srnamc_1.srnamt, "CUNGQL", (ftnlen)6, (ftnlen)6);
cungql_(m, m, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy L */
claset_("Full", m, n, &c_b12, &c_b12, &l[l_offset], lda);
if (*m >= *n) {
if (*n > 0) {
clacpy_("Lower", n, n, &af_ref(*m - *n + 1, 1), lda, &l_ref(*m - *
n + 1, 1), lda);
}
} else {
if (*n > *m && *m > 0) {
i__1 = *n - *m;
clacpy_("Full", m, &i__1, &af[af_offset], lda, &l[l_offset], lda);
}
if (*m > 0) {
clacpy_("Lower", m, m, &af_ref(1, *n - *m + 1), lda, &l_ref(1, *n
- *m + 1), lda);
}
}
/* Compute L - Q'*A */
cgemm_("Conjugate transpose", "No transpose", m, n, m, &c_b19, &q[
q_offset], lda, &a[a_offset], lda, &c_b20, &l[l_offset], lda);
/* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */
anorm = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
resid = clange_("1", m, n, &l[l_offset], lda, &rwork[1]);
if (anorm > 0.f) {
result[1] = resid / (real) max(1,*m) / anorm / eps;
} else {
result[1] = 0.f;
}
/* Compute I - Q'*Q */
claset_("Full", m, m, &c_b12, &c_b20, &l[l_offset], lda);
cherk_("Upper", "Conjugate transpose", m, m, &c_b28, &q[q_offset], lda, &
c_b29, &l[l_offset], lda);
/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
resid = clansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (real) max(1,*m) / eps;
return 0;
/* End of CQLT01 */
} /* cqlt01_ */
/* 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 zqlt02_(integer *m, integer *n, integer *k,
doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex *
l, integer *lda, doublecomplex *tau, doublecomplex *work, integer *
lwork, doublereal *rwork, doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
q_offset, i__1, i__2;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer info;
static doublereal resid, anorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *), zlange_(char *, integer *,
integer *, doublecomplex *, integer *, doublereal *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *);
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zungql_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *);
static doublereal eps;
#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 l_subscr(a_1,a_2) (a_2)*l_dim1 + a_1
#define l_ref(a_1,a_2) l[l_subscr(a_1,a_2)]
#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1
#define af_ref(a_1,a_2) af[af_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
=======
ZQLT02 tests ZUNGQL, which generates an m-by-n matrix Q with
orthonornmal columns that is defined as the product of k elementary
reflectors.
Given the QL factorization of an m-by-n matrix A, ZQLT02 generates
the orthogonal matrix Q defined by the factorization of the last k
columns of A; it compares L(m-n+1:m,n-k+1:n) with
Q(1:m,m-n+1:m)'*A(1:m,n-k+1:n), and checks that the columns of Q are
orthonormal.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix Q to be generated. M >= 0.
N (input) INTEGER
The number of columns of the matrix Q to be generated.
M >= N >= 0.
K (input) INTEGER
The number of elementary reflectors whose product defines the
matrix Q. N >= K >= 0.
A (input) COMPLEX*16 array, dimension (LDA,N)
The m-by-n matrix A which was factorized by ZQLT01.
AF (input) COMPLEX*16 array, dimension (LDA,N)
Details of the QL factorization of A, as returned by ZGEQLF.
See ZGEQLF for further details.
Q (workspace) COMPLEX*16 array, dimension (LDA,N)
L (workspace) COMPLEX*16 array, dimension (LDA,N)
LDA (input) INTEGER
The leading dimension of the arrays A, AF, Q and L. LDA >= M.
TAU (input) COMPLEX*16 array, dimension (N)
The scalar factors of the elementary reflectors corresponding
to the QL factorization in AF.
WORK (workspace) COMPLEX*16 array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK.
RWORK (workspace) DOUBLE PRECISION array, dimension (M)
RESULT (output) DOUBLE PRECISION array, dimension (2)
The test ratios:
RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS )
RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
=====================================================================
Quick return if possible
Parameter adjustments */
l_dim1 = *lda;
l_offset = 1 + l_dim1 * 1;
l -= l_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
if (*m == 0 || *n == 0 || *k == 0) {
result[1] = 0.;
result[2] = 0.;
return 0;
}
eps = dlamch_("Epsilon");
/* Copy the last k columns of the factorization to the array Q */
zlaset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
if (*k < *m) {
i__1 = *m - *k;
zlacpy_("Full", &i__1, k, &af_ref(1, *n - *k + 1), lda, &q_ref(1, *n
- *k + 1), lda);
}
if (*k > 1) {
i__1 = *k - 1;
i__2 = *k - 1;
zlacpy_("Upper", &i__1, &i__2, &af_ref(*m - *k + 1, *n - *k + 2), lda,
&q_ref(*m - *k + 1, *n - *k + 2), lda);
}
/* Generate the last n columns of the matrix Q */
s_copy(srnamc_1.srnamt, "ZUNGQL", (ftnlen)6, (ftnlen)6);
zungql_(m, n, k, &q[q_offset], lda, &tau[*n - *k + 1], &work[1], lwork, &
info);
/* Copy L(m-n+1:m,n-k+1:n) */
zlaset_("Full", n, k, &c_b9, &c_b9, &l_ref(*m - *n + 1, *n - *k + 1), lda);
zlacpy_("Lower", k, k, &af_ref(*m - *k + 1, *n - *k + 1), lda, &l_ref(*m
- *k + 1, *n - *k + 1), lda);
/* Compute L(m-n+1:m,n-k+1:n) - Q(1:m,m-n+1:m)' * A(1:m,n-k+1:n) */
zgemm_("Conjugate transpose", "No transpose", n, k, m, &c_b14, &q[
q_offset], lda, &a_ref(1, *n - *k + 1), lda, &c_b15, &l_ref(*m - *
n + 1, *n - *k + 1), lda);
/* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */
anorm = zlange_("1", m, k, &a_ref(1, *n - *k + 1), lda, &rwork[1]);
resid = zlange_("1", n, k, &l_ref(*m - *n + 1, *n - *k + 1), lda, &rwork[
1]);
if (anorm > 0.) {
result[1] = resid / (doublereal) max(1,*m) / anorm / eps;
} else {
result[1] = 0.;
}
/* Compute I - Q'*Q */
zlaset_("Full", n, n, &c_b9, &c_b15, &l[l_offset], lda);
zherk_("Upper", "Conjugate transpose", n, m, &c_b23, &q[q_offset], lda, &
c_b24, &l[l_offset], lda);
/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
resid = zlansy_("1", "Upper", n, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (doublereal) max(1,*m) / eps;
return 0;
/* End of ZQLT02 */
} /* zqlt02_ */