/* Subroutine */ int zlqt02_(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;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
doublereal eps;
integer info;
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 zunglq_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLQT02 tests ZUNGLQ, which generates an m-by-n matrix Q with */
/* orthonornmal rows that is defined as the product of k elementary */
/* reflectors. */
/* Given the LQ factorization of an m-by-n matrix A, ZLQT02 generates */
/* the orthogonal matrix Q defined by the factorization of the first k */
/* rows of A; it compares L(1:k,1:m) with A(1:k,1:n)*Q(1:m,1:n)', and */
/* checks that the rows 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. */
/* N >= M >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* matrix Q. M >= K >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The m-by-n matrix A which was factorized by ZLQT01. */
/* AF (input) COMPLEX*16 array, dimension (LDA,N) */
/* Details of the LQ factorization of A, as returned by ZGELQF. */
/* See ZGELQF for further details. */
/* Q (workspace) COMPLEX*16 array, dimension (LDA,N) */
/* L (workspace) COMPLEX*16 array, dimension (LDA,M) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, Q and L. LDA >= N. */
/* TAU (input) COMPLEX*16 array, dimension (M) */
/* The scalar factors of the elementary reflectors corresponding */
/* to the LQ 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 - A*Q' ) / ( N * norm(A) * EPS ) */
/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
l_dim1 = *lda;
l_offset = 1 + l_dim1;
l -= l_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
eps = dlamch_("Epsilon");
/* Copy the first k rows of the factorization to the array Q */
zlaset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
i__1 = *n - 1;
zlacpy_("Upper", k, &i__1, &af[(af_dim1 << 1) + 1], lda, &q[(q_dim1 << 1)
+ 1], lda);
/* Generate the first n columns of the matrix Q */
s_copy(srnamc_1.srnamt, "ZUNGLQ", (ftnlen)6, (ftnlen)6);
zunglq_(m, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy L(1:k,1:m) */
zlaset_("Full", k, m, &c_b8, &c_b8, &l[l_offset], lda);
zlacpy_("Lower", k, m, &af[af_offset], lda, &l[l_offset], lda);
/* Compute L(1:k,1:m) - A(1:k,1:n) * Q(1:m,1:n)' */
zgemm_("No transpose", "Conjugate transpose", k, m, n, &c_b13, &a[
a_offset], lda, &q[q_offset], lda, &c_b14, &l[l_offset], lda);
/* Compute norm( L - A*Q' ) / ( N * norm(A) * EPS ) . */
anorm = zlange_("1", k, n, &a[a_offset], lda, &rwork[1]);
resid = zlange_("1", k, m, &l[l_offset], lda, &rwork[1]);
if (anorm > 0.) {
result[1] = resid / (doublereal) max(1,*n) / anorm / eps;
} else {
result[1] = 0.;
}
/* Compute I - Q*Q' */
zlaset_("Full", m, m, &c_b8, &c_b14, &l[l_offset], lda);
zherk_("Upper", "No transpose", m, n, &c_b22, &q[q_offset], lda, &c_b23, &
l[l_offset], lda);
/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
resid = zlansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (doublereal) max(1,*n) / eps;
return 0;
/* End of ZLQT02 */
} /* zlqt02_ */
/* Subroutine */ int zungbr_(char *vect, integer *m, integer *n, integer *k,
doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
work, integer *lwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZUNGBR generates one of the complex unitary matrices Q or P**H
determined by ZGEBRD when reducing a complex matrix A to bidiagonal
form: A = Q * B * P**H. Q and P**H are defined as products of
elementary reflectors H(i) or G(i) respectively.
If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q
is of order M:
if m >= k, Q = H(1) H(2) . . . H(k) and ZUNGBR returns the first n
columns of Q, where m >= n >= k;
if m < k, Q = H(1) H(2) . . . H(m-1) and ZUNGBR returns Q as an
M-by-M matrix.
If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H
is of order N:
if k < n, P**H = G(k) . . . G(2) G(1) and ZUNGBR returns the first m
rows of P**H, where n >= m >= k;
if k >= n, P**H = G(n-1) . . . G(2) G(1) and ZUNGBR returns P**H as
an N-by-N matrix.
Arguments
=========
VECT (input) CHARACTER*1
Specifies whether the matrix Q or the matrix P**H is
required, as defined in the transformation applied by ZGEBRD:
= 'Q': generate Q;
= 'P': generate P**H.
M (input) INTEGER
The number of rows of the matrix Q or P**H to be returned.
M >= 0.
N (input) INTEGER
The number of columns of the matrix Q or P**H to be returned.
N >= 0.
If VECT = 'Q', M >= N >= min(M,K);
if VECT = 'P', N >= M >= min(N,K).
K (input) INTEGER
If VECT = 'Q', the number of columns in the original M-by-K
matrix reduced by ZGEBRD.
If VECT = 'P', the number of rows in the original K-by-N
matrix reduced by ZGEBRD.
K >= 0.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the vectors which define the elementary reflectors,
as returned by ZGEBRD.
On exit, the M-by-N matrix Q or P**H.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= M.
TAU (input) COMPLEX*16 array, dimension
(min(M,K)) if VECT = 'Q'
(min(N,K)) if VECT = 'P'
TAU(i) must contain the scalar factor of the elementary
reflector H(i) or G(i), which determines Q or P**H, as
returned by ZGEBRD in its array argument TAUQ or TAUP.
WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,min(M,N)).
For optimum performance LWORK >= min(M,N)*NB, where NB
is the optimal blocksize.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
static integer i, j;
extern logical lsame_(char *, char *);
static integer iinfo;
static logical wantq;
extern /* Subroutine */ int xerbla_(char *, integer *), zunglq_(
integer *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *, integer *), zungqr_(
integer *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *, integer *);
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*info = 0;
wantq = lsame_(vect, "Q");
if (! wantq && ! lsame_(vect, "P")) {
*info = -1;
} else if (*m < 0) {
*info = -2;
} else if (*n < 0 || wantq && (*n > *m || *n < min(*m,*k)) || ! wantq && (
*m > *n || *m < min(*n,*k))) {
*info = -3;
} else if (*k < 0) {
*info = -4;
} else if (*lda < max(1,*m)) {
*info = -6;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = min(*m,*n);
if (*lwork < max(i__1,i__2)) {
*info = -9;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZUNGBR", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
WORK(1).r = 1., WORK(1).i = 0.;
return 0;
}
if (wantq) {
/* Form Q, determined by a call to ZGEBRD to reduce an m-by-k
matrix */
if (*m >= *k) {
/* If m >= k, assume m >= n >= k */
zungqr_(m, n, k, &A(1,1), lda, &TAU(1), &WORK(1), lwork, &
iinfo);
} else {
/* If m < k, assume m = n
Shift the vectors which define the elementary reflect
ors one
column to the right, and set the first row and column
of Q
to those of the unit matrix */
for (j = *m; j >= 2; --j) {
i__1 = j * a_dim1 + 1;
A(1,j).r = 0., A(1,j).i = 0.;
i__1 = *m;
for (i = j + 1; i <= *m; ++i) {
i__2 = i + j * a_dim1;
i__3 = i + (j - 1) * a_dim1;
A(i,j).r = A(i,j-1).r, A(i,j).i = A(i,j-1).i;
/* L10: */
}
/* L20: */
}
i__1 = a_dim1 + 1;
A(1,1).r = 1., A(1,1).i = 0.;
i__1 = *m;
for (i = 2; i <= *m; ++i) {
i__2 = i + a_dim1;
A(i,1).r = 0., A(i,1).i = 0.;
/* L30: */
}
if (*m > 1) {
/* Form Q(2:m,2:m) */
i__1 = *m - 1;
i__2 = *m - 1;
i__3 = *m - 1;
zungqr_(&i__1, &i__2, &i__3, &A(2,2), lda, &TAU(
1), &WORK(1), lwork, &iinfo);
}
}
} else {
/* Form P', determined by a call to ZGEBRD to reduce a k-by-n
matrix */
if (*k < *n) {
/* If k < n, assume k <= m <= n */
zunglq_(m, n, k, &A(1,1), lda, &TAU(1), &WORK(1), lwork, &
iinfo);
} else {
/* If k >= n, assume m = n
Shift the vectors which define the elementary reflect
ors one
row downward, and set the first row and column of P'
to
those of the unit matrix */
i__1 = a_dim1 + 1;
A(1,1).r = 1., A(1,1).i = 0.;
i__1 = *n;
for (i = 2; i <= *n; ++i) {
i__2 = i + a_dim1;
A(i,1).r = 0., A(i,1).i = 0.;
/* L40: */
}
i__1 = *n;
for (j = 2; j <= *n; ++j) {
for (i = j - 1; i >= 2; --i) {
i__2 = i + j * a_dim1;
i__3 = i - 1 + j * a_dim1;
A(i,j).r = A(i-1,j).r, A(i,j).i = A(i-1,j).i;
/* L50: */
}
i__2 = j * a_dim1 + 1;
A(1,j).r = 0., A(1,j).i = 0.;
/* L60: */
}
if (*n > 1) {
/* Form P'(2:n,2:n) */
i__1 = *n - 1;
i__2 = *n - 1;
i__3 = *n - 1;
zunglq_(&i__1, &i__2, &i__3, &A(2,2), lda, &TAU(
1), &WORK(1), lwork, &iinfo);
}
}
}
return 0;
/* End of ZUNGBR */
} /* zungbr_ */
int main(void)
{
/* Local scalars */
lapack_int m, m_i;
lapack_int n, n_i;
lapack_int k, k_i;
lapack_int lda, lda_i;
lapack_int lda_r;
lapack_int lwork, lwork_i;
lapack_int info, info_i;
lapack_int i;
int failed;
/* Local arrays */
lapack_complex_double *a = NULL, *a_i = NULL;
lapack_complex_double *tau = NULL, *tau_i = NULL;
lapack_complex_double *work = NULL, *work_i = NULL;
lapack_complex_double *a_save = NULL;
lapack_complex_double *a_r = NULL;
/* Iniitialize the scalar parameters */
init_scalars_zunglq( &m, &n, &k, &lda, &lwork );
lda_r = n+2;
m_i = m;
n_i = n;
k_i = k;
lda_i = lda;
lwork_i = lwork;
/* Allocate memory for the LAPACK routine arrays */
a = (lapack_complex_double *)
LAPACKE_malloc( lda*n * sizeof(lapack_complex_double) );
tau = (lapack_complex_double *)
LAPACKE_malloc( k * sizeof(lapack_complex_double) );
work = (lapack_complex_double *)
LAPACKE_malloc( lwork * sizeof(lapack_complex_double) );
/* Allocate memory for the C interface function arrays */
a_i = (lapack_complex_double *)
LAPACKE_malloc( lda*n * sizeof(lapack_complex_double) );
tau_i = (lapack_complex_double *)
LAPACKE_malloc( k * sizeof(lapack_complex_double) );
work_i = (lapack_complex_double *)
LAPACKE_malloc( lwork * sizeof(lapack_complex_double) );
/* Allocate memory for the backup arrays */
a_save = (lapack_complex_double *)
LAPACKE_malloc( lda*n * sizeof(lapack_complex_double) );
/* Allocate memory for the row-major arrays */
a_r = (lapack_complex_double *)
LAPACKE_malloc( m*(n+2) * sizeof(lapack_complex_double) );
/* Initialize input arrays */
init_a( lda*n, a );
init_tau( k, tau );
init_work( lwork, work );
/* Backup the ouptut arrays */
for( i = 0; i < lda*n; i++ ) {
a_save[i] = a[i];
}
/* Call the LAPACK routine */
zunglq_( &m, &n, &k, a, &lda, tau, work, &lwork, &info );
/* Initialize input data, call the column-major middle-level
* interface to LAPACK routine and check the results */
for( i = 0; i < lda*n; i++ ) {
a_i[i] = a_save[i];
}
for( i = 0; i < k; i++ ) {
tau_i[i] = tau[i];
}
for( i = 0; i < lwork; i++ ) {
work_i[i] = work[i];
}
info_i = LAPACKE_zunglq_work( LAPACK_COL_MAJOR, m_i, n_i, k_i, a_i, lda_i,
tau_i, work_i, lwork_i );
failed = compare_zunglq( a, a_i, info, info_i, lda, n );
if( failed == 0 ) {
printf( "PASSED: column-major middle-level interface to zunglq\n" );
} else {
printf( "FAILED: column-major middle-level interface to zunglq\n" );
}
/* Initialize input data, call the column-major high-level
* interface to LAPACK routine and check the results */
for( i = 0; i < lda*n; i++ ) {
a_i[i] = a_save[i];
}
for( i = 0; i < k; i++ ) {
tau_i[i] = tau[i];
}
for( i = 0; i < lwork; i++ ) {
work_i[i] = work[i];
}
info_i = LAPACKE_zunglq( LAPACK_COL_MAJOR, m_i, n_i, k_i, a_i, lda_i,
tau_i );
failed = compare_zunglq( a, a_i, info, info_i, lda, n );
if( failed == 0 ) {
printf( "PASSED: column-major high-level interface to zunglq\n" );
} else {
printf( "FAILED: column-major high-level interface to zunglq\n" );
}
/* Initialize input data, call the row-major middle-level
* interface to LAPACK routine and check the results */
for( i = 0; i < lda*n; i++ ) {
a_i[i] = a_save[i];
}
for( i = 0; i < k; i++ ) {
tau_i[i] = tau[i];
}
for( i = 0; i < lwork; i++ ) {
work_i[i] = work[i];
}
LAPACKE_zge_trans( LAPACK_COL_MAJOR, m, n, a_i, lda, a_r, n+2 );
info_i = LAPACKE_zunglq_work( LAPACK_ROW_MAJOR, m_i, n_i, k_i, a_r, lda_r,
tau_i, work_i, lwork_i );
LAPACKE_zge_trans( LAPACK_ROW_MAJOR, m, n, a_r, n+2, a_i, lda );
failed = compare_zunglq( a, a_i, info, info_i, lda, n );
if( failed == 0 ) {
printf( "PASSED: row-major middle-level interface to zunglq\n" );
} else {
printf( "FAILED: row-major middle-level interface to zunglq\n" );
}
/* Initialize input data, call the row-major high-level
* interface to LAPACK routine and check the results */
for( i = 0; i < lda*n; i++ ) {
a_i[i] = a_save[i];
}
for( i = 0; i < k; i++ ) {
tau_i[i] = tau[i];
}
for( i = 0; i < lwork; i++ ) {
work_i[i] = work[i];
}
/* Init row_major arrays */
LAPACKE_zge_trans( LAPACK_COL_MAJOR, m, n, a_i, lda, a_r, n+2 );
info_i = LAPACKE_zunglq( LAPACK_ROW_MAJOR, m_i, n_i, k_i, a_r, lda_r,
tau_i );
LAPACKE_zge_trans( LAPACK_ROW_MAJOR, m, n, a_r, n+2, a_i, lda );
failed = compare_zunglq( a, a_i, info, info_i, lda, n );
if( failed == 0 ) {
printf( "PASSED: row-major high-level interface to zunglq\n" );
} else {
printf( "FAILED: row-major high-level interface to zunglq\n" );
}
/* Release memory */
if( a != NULL ) {
LAPACKE_free( a );
}
if( a_i != NULL ) {
LAPACKE_free( a_i );
}
if( a_r != NULL ) {
LAPACKE_free( a_r );
}
if( a_save != NULL ) {
LAPACKE_free( a_save );
}
if( tau != NULL ) {
LAPACKE_free( tau );
}
if( tau_i != NULL ) {
LAPACKE_free( tau_i );
}
if( work != NULL ) {
LAPACKE_free( work );
}
if( work_i != NULL ) {
LAPACKE_free( work_i );
}
return 0;
}
/* Subroutine */ int zerrlq_(char *path, integer *nunit)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
doublecomplex a[4] /* was [2][2] */, b[2];
integer i__, j;
doublecomplex w[2], x[2], af[4] /* was [2][2] */;
integer info;
extern /* Subroutine */ int zgelq2_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *), zungl2_(
integer *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *), zunml2_(char *,
char *, integer *, integer *, integer *, doublecomplex *, integer
*, doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *), alaesm_(char *, logical *, integer *), chkxer_(char *, integer *, integer *, logical *, logical
*), zgelqf_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *)
, zgelqs_(integer *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *), zunglq_(integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, integer *), zunmlq_(char *, char *,
integer *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZERRLQ tests the error exits for the COMPLEX*16 routines */
/* that use the LQ decomposition of a general matrix. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
/* Set the variables to innocuous values. */
for (j = 1; j <= 2; ++j) {
for (i__ = 1; i__ <= 2; ++i__) {
i__1 = i__ + (j << 1) - 3;
d__1 = 1. / (doublereal) (i__ + j);
d__2 = -1. / (doublereal) (i__ + j);
z__1.r = d__1, z__1.i = d__2;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = i__ + (j << 1) - 3;
d__1 = 1. / (doublereal) (i__ + j);
d__2 = -1. / (doublereal) (i__ + j);
z__1.r = d__1, z__1.i = d__2;
af[i__1].r = z__1.r, af[i__1].i = z__1.i;
/* L10: */
}
i__1 = j - 1;
b[i__1].r = 0., b[i__1].i = 0.;
i__1 = j - 1;
w[i__1].r = 0., w[i__1].i = 0.;
i__1 = j - 1;
x[i__1].r = 0., x[i__1].i = 0.;
/* L20: */
}
infoc_1.ok = TRUE_;
/* Error exits for LQ factorization */
/* ZGELQF */
s_copy(srnamc_1.srnamt, "ZGELQF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zgelqf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
chkxer_("ZGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgelqf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
chkxer_("ZGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zgelqf_(&c__2, &c__1, a, &c__1, b, w, &c__2, &info);
chkxer_("ZGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
zgelqf_(&c__2, &c__1, a, &c__2, b, w, &c__1, &info);
chkxer_("ZGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZGELQ2 */
s_copy(srnamc_1.srnamt, "ZGELQ2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zgelq2_(&c_n1, &c__0, a, &c__1, b, w, &info);
chkxer_("ZGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgelq2_(&c__0, &c_n1, a, &c__1, b, w, &info);
chkxer_("ZGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zgelq2_(&c__2, &c__1, a, &c__1, b, w, &info);
chkxer_("ZGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZGELQS */
s_copy(srnamc_1.srnamt, "ZGELQS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zgelqs_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("ZGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgelqs_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("ZGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgelqs_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
chkxer_("ZGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zgelqs_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("ZGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zgelqs_(&c__2, &c__2, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
chkxer_("ZGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
zgelqs_(&c__1, &c__2, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("ZGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
zgelqs_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("ZGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZUNGLQ */
s_copy(srnamc_1.srnamt, "ZUNGLQ", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zunglq_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
chkxer_("ZUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zunglq_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
chkxer_("ZUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zunglq_(&c__2, &c__1, &c__0, a, &c__2, x, w, &c__2, &info);
chkxer_("ZUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zunglq_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
chkxer_("ZUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zunglq_(&c__1, &c__1, &c__2, a, &c__1, x, w, &c__1, &info);
chkxer_("ZUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunglq_(&c__2, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
chkxer_("ZUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
zunglq_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
chkxer_("ZUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZUNGL2 */
s_copy(srnamc_1.srnamt, "ZUNGL2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zungl2_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
chkxer_("ZUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zungl2_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
chkxer_("ZUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zungl2_(&c__2, &c__1, &c__0, a, &c__2, x, w, &info);
chkxer_("ZUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zungl2_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
chkxer_("ZUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zungl2_(&c__1, &c__1, &c__2, a, &c__1, x, w, &info);
chkxer_("ZUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zungl2_(&c__2, &c__2, &c__0, a, &c__1, x, w, &info);
chkxer_("ZUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZUNMLQ */
s_copy(srnamc_1.srnamt, "ZUNMLQ", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zunmlq_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zunmlq_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zunmlq_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zunmlq_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunmlq_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunmlq_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunmlq_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
zunmlq_("L", "N", &c__2, &c__0, &c__2, a, &c__1, x, af, &c__2, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
zunmlq_("R", "N", &c__0, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
zunmlq_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
zunmlq_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
zunmlq_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
info);
chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZUNML2 */
s_copy(srnamc_1.srnamt, "ZUNML2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zunml2_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zunml2_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zunml2_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zunml2_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunml2_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunml2_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunml2_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
zunml2_("L", "N", &c__2, &c__1, &c__2, a, &c__1, x, af, &c__2, w, &info);
chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
zunml2_("R", "N", &c__1, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &info);
chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
zunml2_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &info);
chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of ZERRLQ */
} /* zerrlq_ */
/* Subroutine */ int zungbr_(char *vect, integer *m, integer *n, integer *k,
doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, j, nb, mn;
extern logical lsame_(char *, char *);
integer iinfo;
logical wantq;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
integer lwkopt;
logical lquery;
extern /* Subroutine */ int zunglq_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *), zungqr_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZUNGBR generates one of the complex unitary matrices Q or P**H */
/* determined by ZGEBRD when reducing a complex matrix A to bidiagonal */
/* form: A = Q * B * P**H. Q and P**H are defined as products of */
/* elementary reflectors H(i) or G(i) respectively. */
/* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q */
/* is of order M: */
/* if m >= k, Q = H(1) H(2) . . . H(k) and ZUNGBR returns the first n */
/* columns of Q, where m >= n >= k; */
/* if m < k, Q = H(1) H(2) . . . H(m-1) and ZUNGBR returns Q as an */
/* M-by-M matrix. */
/* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H */
/* is of order N: */
/* if k < n, P**H = G(k) . . . G(2) G(1) and ZUNGBR returns the first m */
/* rows of P**H, where n >= m >= k; */
/* if k >= n, P**H = G(n-1) . . . G(2) G(1) and ZUNGBR returns P**H as */
/* an N-by-N matrix. */
/* Arguments */
/* ========= */
/* VECT (input) CHARACTER*1 */
/* Specifies whether the matrix Q or the matrix P**H is */
/* required, as defined in the transformation applied by ZGEBRD: */
/* = 'Q': generate Q; */
/* = 'P': generate P**H. */
/* M (input) INTEGER */
/* The number of rows of the matrix Q or P**H to be returned. */
/* M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q or P**H to be returned. */
/* N >= 0. */
/* If VECT = 'Q', M >= N >= lmin(M,K); */
/* if VECT = 'P', N >= M >= lmin(N,K). */
/* K (input) INTEGER */
/* If VECT = 'Q', the number of columns in the original M-by-K */
/* matrix reduced by ZGEBRD. */
/* If VECT = 'P', the number of rows in the original K-by-N */
/* matrix reduced by ZGEBRD. */
/* K >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the vectors which define the elementary reflectors, */
/* as returned by ZGEBRD. */
/* On exit, the M-by-N matrix Q or P**H. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= M. */
/* TAU (input) COMPLEX*16 array, dimension */
/* (min(M,K)) if VECT = 'Q' */
/* (min(N,K)) if VECT = 'P' */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i) or G(i), which determines Q or P**H, as */
/* returned by ZGEBRD in its array argument TAUQ or TAUP. */
/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= lmax(1,min(M,N)). */
/* For optimum performance LWORK >= lmin(M,N)*NB, where NB */
/* is the optimal blocksize. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
wantq = lsame_(vect, "Q");
mn = lmin(*m,*n);
lquery = *lwork == -1;
if (! wantq && ! lsame_(vect, "P")) {
*info = -1;
} else if (*m < 0) {
*info = -2;
} else if (*n < 0 || wantq && (*n > *m || *n < lmin(*m,*k)) || ! wantq && (
*m > *n || *m < lmin(*n,*k))) {
*info = -3;
} else if (*k < 0) {
*info = -4;
} else if (*lda < lmax(1,*m)) {
*info = -6;
} else if (*lwork < lmax(1,mn) && ! lquery) {
*info = -9;
}
if (*info == 0) {
if (wantq) {
nb = ilaenv_(&c__1, "ZUNGQR", " ", m, n, k, &c_n1);
} else {
nb = ilaenv_(&c__1, "ZUNGLQ", " ", m, n, k, &c_n1);
}
lwkopt = lmax(1,mn) * nb;
work[1].r = (doublereal) lwkopt, work[1].i = 0.;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZUNGBR", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
work[1].r = 1., work[1].i = 0.;
return 0;
}
if (wantq) {
/* Form Q, determined by a call to ZGEBRD to reduce an m-by-k */
/* matrix */
if (*m >= *k) {
/* If m >= k, assume m >= n >= k */
zungqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
iinfo);
} else {
/* If m < k, assume m = n */
/* Shift the vectors which define the elementary reflectors one */
/* column to the right, and set the first row and column of Q */
/* to those of the unit matrix */
for (j = *m; j >= 2; --j) {
i__1 = j * a_dim1 + 1;
a[i__1].r = 0., a[i__1].i = 0.;
i__1 = *m;
for (i__ = j + 1; i__ <= i__1; ++i__) {
i__2 = i__ + j * a_dim1;
i__3 = i__ + (j - 1) * a_dim1;
a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
/* L10: */
}
/* L20: */
}
i__1 = a_dim1 + 1;
a[i__1].r = 1., a[i__1].i = 0.;
i__1 = *m;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = i__ + a_dim1;
a[i__2].r = 0., a[i__2].i = 0.;
/* L30: */
}
if (*m > 1) {
/* Form Q(2:m,2:m) */
i__1 = *m - 1;
i__2 = *m - 1;
i__3 = *m - 1;
zungqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[
1], &work[1], lwork, &iinfo);
}
}
} else {
/* Form P', determined by a call to ZGEBRD to reduce a k-by-n */
/* matrix */
if (*k < *n) {
/* If k < n, assume k <= m <= n */
zunglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
iinfo);
} else {
/* If k >= n, assume m = n */
/* Shift the vectors which define the elementary reflectors one */
/* row downward, and set the first row and column of P' to */
/* those of the unit matrix */
i__1 = a_dim1 + 1;
a[i__1].r = 1., a[i__1].i = 0.;
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = i__ + a_dim1;
a[i__2].r = 0., a[i__2].i = 0.;
/* L40: */
}
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
for (i__ = j - 1; i__ >= 2; --i__) {
i__2 = i__ + j * a_dim1;
i__3 = i__ - 1 + j * a_dim1;
a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
/* L50: */
}
i__2 = j * a_dim1 + 1;
a[i__2].r = 0., a[i__2].i = 0.;
/* L60: */
}
if (*n > 1) {
/* Form P'(2:n,2:n) */
i__1 = *n - 1;
i__2 = *n - 1;
i__3 = *n - 1;
zunglq_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[
1], &work[1], lwork, &iinfo);
}
}
}
work[1].r = (doublereal) lwkopt, work[1].i = 0.;
return 0;
/* End of ZUNGBR */
} /* zungbr_ */
/* Subroutine */ int zlqt01_(integer *m, integer *n, 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;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
doublereal eps;
integer info;
doublereal resid, anorm;
integer minmn;
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 zgelqf_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *
), 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 zunglq_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLQT01 tests ZGELQF, which computes the LQ factorization of an m-by-n */
/* matrix A, and partially tests ZUNGLQ which forms the n-by-n */
/* orthogonal matrix Q. */
/* ZLQT01 compares L with A*Q', 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*16 array, dimension (LDA,N) */
/* The m-by-n matrix A. */
/* AF (output) COMPLEX*16 array, dimension (LDA,N) */
/* Details of the LQ factorization of A, as returned by ZGELQF. */
/* See ZGELQF for further details. */
/* Q (output) COMPLEX*16 array, dimension (LDA,N) */
/* The n-by-n orthogonal matrix Q. */
/* L (workspace) COMPLEX*16 array, dimension (LDA,max(M,N)) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, Q and L. */
/* LDA >= max(M,N). */
/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors, as returned */
/* by ZGELQF. */
/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(M,N)) */
/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
/* The test ratios: */
/* RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS ) */
/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
l_dim1 = *lda;
l_offset = 1 + l_dim1;
l -= l_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
minmn = min(*m,*n);
eps = dlamch_("Epsilon");
/* Copy the matrix A to the array AF. */
zlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
/* Factorize the matrix A in the array AF. */
s_copy(srnamc_1.srnamt, "ZGELQF", (ftnlen)32, (ftnlen)6);
zgelqf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy details of Q */
zlaset_("Full", n, n, &c_b1, &c_b1, &q[q_offset], lda);
if (*n > 1) {
i__1 = *n - 1;
zlacpy_("Upper", m, &i__1, &af[(af_dim1 << 1) + 1], lda, &q[(q_dim1 <<
1) + 1], lda);
}
/* Generate the n-by-n matrix Q */
s_copy(srnamc_1.srnamt, "ZUNGLQ", (ftnlen)32, (ftnlen)6);
zunglq_(n, n, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy L */
zlaset_("Full", m, n, &c_b10, &c_b10, &l[l_offset], lda);
zlacpy_("Lower", m, n, &af[af_offset], lda, &l[l_offset], lda);
/* Compute L - A*Q' */
zgemm_("No transpose", "Conjugate transpose", m, n, n, &c_b15, &a[
a_offset], lda, &q[q_offset], lda, &c_b16, &l[l_offset], lda);
/* Compute norm( L - Q'*A ) / ( N * norm(A) * EPS ) . */
anorm = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
resid = zlange_("1", m, n, &l[l_offset], lda, &rwork[1]);
if (anorm > 0.) {
result[1] = resid / (doublereal) max(1,*n) / anorm / eps;
} else {
result[1] = 0.;
}
/* Compute I - Q*Q' */
zlaset_("Full", n, n, &c_b10, &c_b16, &l[l_offset], lda);
zherk_("Upper", "No transpose", n, n, &c_b24, &q[q_offset], lda, &c_b25, &
l[l_offset], lda);
/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
resid = zlansy_("1", "Upper", n, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (doublereal) max(1,*n) / eps;
return 0;
/* End of ZLQT01 */
} /* zlqt01_ */
/* Subroutine */ int zlqt02_(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;
/* 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 zunglq_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *);
static doublereal eps;
#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
=======
ZLQT02 tests ZUNGLQ, which generates an m-by-n matrix Q with
orthonornmal rows that is defined as the product of k elementary
reflectors.
Given the LQ factorization of an m-by-n matrix A, ZLQT02 generates
the orthogonal matrix Q defined by the factorization of the first k
rows of A; it compares L(1:k,1:m) with A(1:k,1:n)*Q(1:m,1:n)', and
checks that the rows 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.
N >= M >= 0.
K (input) INTEGER
The number of elementary reflectors whose product defines the
matrix Q. M >= K >= 0.
A (input) COMPLEX*16 array, dimension (LDA,N)
The m-by-n matrix A which was factorized by ZLQT01.
AF (input) COMPLEX*16 array, dimension (LDA,N)
Details of the LQ factorization of A, as returned by ZGELQF.
See ZGELQF for further details.
Q (workspace) COMPLEX*16 array, dimension (LDA,N)
L (workspace) COMPLEX*16 array, dimension (LDA,M)
LDA (input) INTEGER
The leading dimension of the arrays A, AF, Q and L. LDA >= N.
TAU (input) COMPLEX*16 array, dimension (M)
The scalar factors of the elementary reflectors corresponding
to the LQ 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 - A*Q' ) / ( N * norm(A) * EPS )
RESULT(2) = norm( I - Q*Q' ) / ( N * 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 */
eps = dlamch_("Epsilon");
/* Copy the first k rows of the factorization to the array Q */
zlaset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
i__1 = *n - 1;
zlacpy_("Upper", k, &i__1, &af_ref(1, 2), lda, &q_ref(1, 2), lda);
/* Generate the first n columns of the matrix Q */
s_copy(srnamc_1.srnamt, "ZUNGLQ", (ftnlen)6, (ftnlen)6);
zunglq_(m, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy L(1:k,1:m) */
zlaset_("Full", k, m, &c_b8, &c_b8, &l[l_offset], lda);
zlacpy_("Lower", k, m, &af[af_offset], lda, &l[l_offset], lda);
/* Compute L(1:k,1:m) - A(1:k,1:n) * Q(1:m,1:n)' */
zgemm_("No transpose", "Conjugate transpose", k, m, n, &c_b13, &a[
a_offset], lda, &q[q_offset], lda, &c_b14, &l[l_offset], lda);
/* Compute norm( L - A*Q' ) / ( N * norm(A) * EPS ) . */
anorm = zlange_("1", k, n, &a[a_offset], lda, &rwork[1]);
resid = zlange_("1", k, m, &l[l_offset], lda, &rwork[1]);
if (anorm > 0.) {
result[1] = resid / (doublereal) max(1,*n) / anorm / eps;
} else {
result[1] = 0.;
}
/* Compute I - Q*Q' */
zlaset_("Full", m, m, &c_b8, &c_b14, &l[l_offset], lda);
zherk_("Upper", "No transpose", m, n, &c_b22, &q[q_offset], lda, &c_b23, &
l[l_offset], lda);
/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
resid = zlansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (doublereal) max(1,*n) / eps;
return 0;
/* End of ZLQT02 */
} /* zlqt02_ */