/* Subroutine */ int zchkqp_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, doublereal *thresh, logical *tsterr,
doublecomplex *a, doublecomplex *copya, doublereal *s, doublereal *
copys, doublecomplex *tau, doublecomplex *work, doublereal *rwork,
integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, type"
" \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, m, n, im, in, lda;
doublereal eps;
integer mode, info;
char path[3];
integer ilow, nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer ihigh, nfail, iseed[4], imode, mnmin, istep, nerrs, lwork;
extern doublereal zqpt01_(integer *, integer *, integer *, doublecomplex *
, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zqrt11_(integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zqrt12_(integer *, integer *, doublecomplex *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *)
, dlamch_(char *);
extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *,
integer *), alasum_(char *, integer *, integer *, integer
*, integer *), zgeqpf_(integer *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *,
doublecomplex *, doublereal *, integer *), zlacpy_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *), zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatms_(integer *, integer *, char *, integer *, char *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *, char *, doublecomplex *, integer *, doublecomplex *,
integer *);
doublereal result[3];
extern /* Subroutine */ int zerrqp_(char *, integer *);
/* Fortran I/O blocks */
static cilist io___24 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKQP tests ZGEQPF. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) */
/* where MMAX is the maximum value of M in MVAL and NMAX is the */
/* maximum value of N in NVAL. */
/* COPYA (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) */
/* S (workspace) DOUBLE PRECISION array, dimension */
/* (min(MMAX,NMAX)) */
/* COPYS (workspace) DOUBLE PRECISION array, dimension */
/* (min(MMAX,NMAX)) */
/* TAU (workspace) COMPLEX*16 array, dimension (MMAX) */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (max(M*max(M,N) + 4*min(M,N) + max(M,N))) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (4*NMAX) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--tau;
--copys;
--s;
--copya;
--a;
--nval;
--mval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "QP", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = dlamch_("Epsilon");
/* Test the error exits */
if (*tsterr) {
zerrqp_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
/* Do for each value of M in MVAL. */
m = mval[im];
lda = max(1,m);
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
mnmin = min(m,n);
/* Computing MAX */
i__3 = 1, i__4 = m * max(m,n) + (mnmin << 2) + max(m,n);
lwork = max(i__3,i__4);
for (imode = 1; imode <= 6; ++imode) {
if (! dotype[imode]) {
goto L60;
}
/* Do for each type of matrix */
/* 1: zero matrix */
/* 2: one small singular value */
/* 3: geometric distribution of singular values */
/* 4: first n/2 columns fixed */
/* 5: last n/2 columns fixed */
/* 6: every second column fixed */
mode = imode;
if (imode > 3) {
mode = 1;
}
/* Generate test matrix of size m by n using */
/* singular value distribution indicated by `mode'. */
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
iwork[i__] = 0;
/* L20: */
}
if (imode == 1) {
zlaset_("Full", &m, &n, &c_b11, &c_b11, ©a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.;
/* L30: */
}
} else {
d__1 = 1. / eps;
zlatms_(&m, &n, "Uniform", iseed, "Nonsymm", ©s[1], &
mode, &d__1, &c_b16, &m, &n, "No packing", ©a[
1], &lda, &work[1], &info);
if (imode >= 4) {
if (imode == 4) {
ilow = 1;
istep = 1;
/* Computing MAX */
i__3 = 1, i__4 = n / 2;
ihigh = max(i__3,i__4);
} else if (imode == 5) {
/* Computing MAX */
i__3 = 1, i__4 = n / 2;
ilow = max(i__3,i__4);
istep = 1;
ihigh = n;
} else if (imode == 6) {
ilow = 1;
istep = 2;
ihigh = n;
}
i__3 = ihigh;
i__4 = istep;
for (i__ = ilow; i__4 < 0 ? i__ >= i__3 : i__ <= i__3;
i__ += i__4) {
iwork[i__] = 1;
/* L40: */
}
}
dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
/* Save A and its singular values */
zlacpy_("All", &m, &n, ©a[1], &lda, &a[1], &lda);
/* Compute the QR factorization with pivoting of A */
s_copy(srnamc_1.srnamt, "ZGEQPF", (ftnlen)32, (ftnlen)6);
zgeqpf_(&m, &n, &a[1], &lda, &iwork[1], &tau[1], &work[1], &
rwork[1], &info);
/* Compute norm(svd(a) - svd(r)) */
result[0] = zqrt12_(&m, &n, &a[1], &lda, ©s[1], &work[1],
&lwork, &rwork[1]);
/* Compute norm( A*P - Q*R ) */
result[1] = zqpt01_(&m, &n, &mnmin, ©a[1], &a[1], &lda, &
tau[1], &iwork[1], &work[1], &lwork);
/* Compute Q'*Q */
result[2] = zqrt11_(&m, &mnmin, &a[1], &lda, &tau[1], &work[1]
, &lwork);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 1; k <= 3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___24.ciunit = *nout;
s_wsfe(&io___24);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L50: */
}
nrun += 3;
L60:
;
}
/* L70: */
}
/* L80: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
/* End of ZCHKQP */
return 0;
} /* zchkqp_ */
/* Subroutine */ int dqrt15_(integer *scale, integer *rksel, integer *m,
integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b,
integer *ldb, doublereal *s, integer *rank, doublereal *norma,
doublereal *normb, integer *iseed, doublereal *work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
static integer info;
static doublereal temp;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static integer j;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dlarf_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, doublereal *), dgemm_(char *, char *, integer *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
extern doublereal dasum_(integer *, doublereal *, integer *);
static doublereal dummy[1];
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
static integer mn;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
extern doublereal dlarnd_(integer *, integer *);
extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *,
integer *), dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *);
static doublereal bignum;
extern /* Subroutine */ int dlaror_(char *, char *, integer *, integer *,
doublereal *, integer *, integer *, doublereal *, integer *), dlarnv_(integer *, integer *, integer *,
doublereal *);
static doublereal smlnum, eps;
#define a_ref(a_1,a_2) a[(a_2)*a_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
=======
DQRT15 generates a matrix with full or deficient rank and of various
norms.
Arguments
=========
SCALE (input) INTEGER
SCALE = 1: normally scaled matrix
SCALE = 2: matrix scaled up
SCALE = 3: matrix scaled down
RKSEL (input) INTEGER
RKSEL = 1: full rank matrix
RKSEL = 2: rank-deficient matrix
M (input) INTEGER
The number of rows of the matrix A.
N (input) INTEGER
The number of columns of A.
NRHS (input) INTEGER
The number of columns of B.
A (output) DOUBLE PRECISION array, dimension (LDA,N)
The M-by-N matrix A.
LDA (input) INTEGER
The leading dimension of the array A.
B (output) DOUBLE PRECISION array, dimension (LDB, NRHS)
A matrix that is in the range space of matrix A.
LDB (input) INTEGER
The leading dimension of the array B.
S (output) DOUBLE PRECISION array, dimension MIN(M,N)
Singular values of A.
RANK (output) INTEGER
number of nonzero singular values of A.
NORMA (output) DOUBLE PRECISION
one-norm of A.
NORMB (output) DOUBLE PRECISION
one-norm of B.
ISEED (input/output) integer array, dimension (4)
seed for random number generator.
WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
LWORK (input) INTEGER
length of work space required.
LWORK >= MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
=====================================================================
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;
--s;
--iseed;
--work;
/* Function Body */
mn = min(*m,*n);
/* Computing MAX */
i__1 = *m + mn, i__2 = mn * *nrhs, i__1 = max(i__1,i__2), i__2 = (*n << 1)
+ *m;
if (*lwork < max(i__1,i__2)) {
xerbla_("DQRT15", &c__16);
return 0;
}
smlnum = dlamch_("Safe minimum");
bignum = 1. / smlnum;
eps = dlamch_("Epsilon");
smlnum = smlnum / eps / eps;
bignum = 1. / smlnum;
/* Determine rank and (unscaled) singular values */
if (*rksel == 1) {
*rank = mn;
} else if (*rksel == 2) {
*rank = mn * 3 / 4;
i__1 = mn;
for (j = *rank + 1; j <= i__1; ++j) {
s[j] = 0.;
/* L10: */
}
} else {
xerbla_("DQRT15", &c__2);
}
if (*rank > 0) {
/* Nontrivial case */
s[1] = 1.;
i__1 = *rank;
for (j = 2; j <= i__1; ++j) {
L20:
temp = dlarnd_(&c__1, &iseed[1]);
if (temp > .1) {
s[j] = abs(temp);
} else {
goto L20;
}
/* L30: */
}
dlaord_("Decreasing", rank, &s[1], &c__1);
/* Generate 'rank' columns of a random orthogonal matrix in A */
dlarnv_(&c__2, &iseed[1], m, &work[1]);
d__1 = 1. / dnrm2_(m, &work[1], &c__1);
dscal_(m, &d__1, &work[1], &c__1);
dlaset_("Full", m, rank, &c_b18, &c_b19, &a[a_offset], lda)
;
dlarf_("Left", m, rank, &work[1], &c__1, &c_b22, &a[a_offset], lda, &
work[*m + 1]);
/* workspace used: m+mn
Generate consistent rhs in the range space of A */
i__1 = *rank * *nrhs;
dlarnv_(&c__2, &iseed[1], &i__1, &work[1]);
dgemm_("No transpose", "No transpose", m, nrhs, rank, &c_b19, &a[
a_offset], lda, &work[1], rank, &c_b18, &b[b_offset], ldb);
/* work space used: <= mn *nrhs
generate (unscaled) matrix A */
i__1 = *rank;
for (j = 1; j <= i__1; ++j) {
dscal_(m, &s[j], &a_ref(1, j), &c__1);
/* L40: */
}
if (*rank < *n) {
i__1 = *n - *rank;
dlaset_("Full", m, &i__1, &c_b18, &c_b18, &a_ref(1, *rank + 1),
lda);
}
dlaror_("Right", "No initialization", m, n, &a[a_offset], lda, &iseed[
1], &work[1], &info);
} else {
/* work space used 2*n+m
Generate null matrix and rhs */
i__1 = mn;
for (j = 1; j <= i__1; ++j) {
s[j] = 0.;
/* L50: */
}
dlaset_("Full", m, n, &c_b18, &c_b18, &a[a_offset], lda);
dlaset_("Full", m, nrhs, &c_b18, &c_b18, &b[b_offset], ldb)
;
}
/* Scale the matrix */
if (*scale != 1) {
*norma = dlange_("Max", m, n, &a[a_offset], lda, dummy);
if (*norma != 0.) {
if (*scale == 2) {
/* matrix scaled up */
dlascl_("General", &c__0, &c__0, norma, &bignum, m, n, &a[
a_offset], lda, &info);
dlascl_("General", &c__0, &c__0, norma, &bignum, &mn, &c__1, &
s[1], &mn, &info);
dlascl_("General", &c__0, &c__0, norma, &bignum, m, nrhs, &b[
b_offset], ldb, &info);
} else if (*scale == 3) {
/* matrix scaled down */
dlascl_("General", &c__0, &c__0, norma, &smlnum, m, n, &a[
a_offset], lda, &info);
dlascl_("General", &c__0, &c__0, norma, &smlnum, &mn, &c__1, &
s[1], &mn, &info);
dlascl_("General", &c__0, &c__0, norma, &smlnum, m, nrhs, &b[
b_offset], ldb, &info);
} else {
xerbla_("DQRT15", &c__1);
return 0;
}
}
}
*norma = dasum_(&mn, &s[1], &c__1);
*normb = dlange_("One-norm", m, nrhs, &b[b_offset], ldb, dummy)
;
return 0;
/* End of DQRT15 */
} /* dqrt15_ */
/* Subroutine */ int dchktz_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, doublereal *thresh, logical *tsterr,
doublereal *a, doublereal *copya, doublereal *s, doublereal *copys,
doublereal *tau, doublereal *work, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, type"
" \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, m, n, im, in, lda;
doublereal eps;
integer mode, info;
char path[3];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer nfail, iseed[4], imode;
extern doublereal dqrt12_(integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
integer mnmin;
extern doublereal drzt01_(integer *, integer *, doublereal *, doublereal *
, integer *, doublereal *, doublereal *, integer *), drzt02_(
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *), dtzt01_(integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *), dtzt02_(integer *, integer *, doublereal *, integer *
, doublereal *, doublereal *, integer *);
integer nerrs, lwork;
extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *,
integer *), dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *), alasum_(char *, integer *,
integer *, integer *, integer *), dlatms_(integer *,
integer *, char *, integer *, char *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, char *,
doublereal *, integer *, doublereal *, integer *), derrtz_(char *, integer *), dtzrqf_(integer *,
integer *, doublereal *, integer *, doublereal *, integer *);
doublereal result[6];
extern /* Subroutine */ int dtzrzf_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___21 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKTZ tests DTZRQF and STZRZF. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX) */
/* where MMAX is the maximum value of M in MVAL and NMAX is the */
/* maximum value of N in NVAL. */
/* COPYA (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX) */
/* S (workspace) DOUBLE PRECISION array, dimension */
/* (min(MMAX,NMAX)) */
/* COPYS (workspace) DOUBLE PRECISION array, dimension */
/* (min(MMAX,NMAX)) */
/* TAU (workspace) DOUBLE PRECISION array, dimension (MMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (MMAX*NMAX + 4*NMAX + MMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--work;
--tau;
--copys;
--s;
--copya;
--a;
--nval;
--mval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "TZ", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = dlamch_("Epsilon");
/* Test the error exits */
if (*tsterr) {
derrtz_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
/* Do for each value of M in MVAL. */
m = mval[im];
lda = max(1,m);
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
/* Do for each value of N in NVAL for which M .LE. N. */
n = nval[in];
mnmin = min(m,n);
/* Computing MAX */
i__3 = 1, i__4 = n * n + (m << 2) + n, i__3 = max(i__3,i__4),
i__4 = m * n + (mnmin << 1) + (n << 2);
lwork = max(i__3,i__4);
if (m <= n) {
for (imode = 1; imode <= 3; ++imode) {
if (! dotype[imode]) {
goto L50;
}
/* Do for each type of singular value distribution. */
/* 0: zero matrix */
/* 1: one small singular value */
/* 2: exponential distribution */
mode = imode - 1;
/* Test DTZRQF */
/* Generate test matrix of size m by n using */
/* singular value distribution indicated by `mode'. */
if (mode == 0) {
dlaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.;
/* L20: */
}
} else {
d__1 = 1. / eps;
dlatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
copys[1], &imode, &d__1, &c_b15, &m, &n,
"No packing", &a[1], &lda, &work[1], &info);
dgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
1], &info);
i__3 = m - 1;
dlaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
lda);
dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
/* Save A and its singular values */
dlacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
/* Call DTZRQF to reduce the upper trapezoidal matrix to */
/* upper triangular form. */
s_copy(srnamc_1.srnamt, "DTZRQF", (ftnlen)32, (ftnlen)6);
dtzrqf_(&m, &n, &a[1], &lda, &tau[1], &info);
/* Compute norm(svd(a) - svd(r)) */
result[0] = dqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
1], &lwork);
/* Compute norm( A - R*Q ) */
result[1] = dtzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
1], &work[1], &lwork);
/* Compute norm(Q'*Q - I). */
result[2] = dtzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
, &lwork);
/* Test DTZRZF */
/* Generate test matrix of size m by n using */
/* singular value distribution indicated by `mode'. */
if (mode == 0) {
dlaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.;
/* L30: */
}
} else {
d__1 = 1. / eps;
dlatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
copys[1], &imode, &d__1, &c_b15, &m, &n,
"No packing", &a[1], &lda, &work[1], &info);
dgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
1], &info);
i__3 = m - 1;
dlaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
lda);
dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
/* Save A and its singular values */
dlacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
/* Call DTZRZF to reduce the upper trapezoidal matrix to */
/* upper triangular form. */
s_copy(srnamc_1.srnamt, "DTZRZF", (ftnlen)32, (ftnlen)6);
dtzrzf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lwork, &
info);
/* Compute norm(svd(a) - svd(r)) */
result[3] = dqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
1], &lwork);
/* Compute norm( A - R*Q ) */
result[4] = drzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
1], &work[1], &lwork);
/* Compute norm(Q'*Q - I). */
result[5] = drzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
, &lwork);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___21.ciunit = *nout;
s_wsfe(&io___21);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L40: */
}
nrun += 6;
L50:
;
}
}
/* L60: */
}
/* L70: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
/* End if DCHKTZ */
return 0;
} /* dchktz_ */
/* Subroutine */ int zchktz_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, doublereal *thresh, logical *tsterr,
doublecomplex *a, doublecomplex *copya, doublereal *s, doublereal *
copys, doublecomplex *tau, doublecomplex *work, doublereal *rwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, type"
" \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer mode, info;
static char path[3];
static integer nrun, i__;
extern /* Subroutine */ int alahd_(integer *, char *);
static integer k, m, n, nfail, iseed[4], imode, mnmin, nerrs, lwork;
extern doublereal zqrt12_(integer *, integer *, doublecomplex *, integer *
, doublereal *, doublecomplex *, integer *, doublereal *),
zrzt01_(integer *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *), zrzt02_(
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *), ztzt01_(integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *), ztzt02_(integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static integer im, in;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *,
integer *), alasum_(char *, integer *, integer *, integer
*, integer *), zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *), zlatms_(
integer *, integer *, char *, integer *, char *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *, char
*, doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal result[6];
extern /* Subroutine */ int zerrtz_(char *, integer *), ztzrqf_(
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *), ztzrzf_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *)
;
static integer lda;
static doublereal eps;
/* Fortran I/O blocks */
static cilist io___21 = { 0, 0, 0, fmt_9999, 0 };
/* -- 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
=======
ZCHKTZ tests ZTZRQF and ZTZRZF.
Arguments
=========
DOTYPE (input) LOGICAL array, dimension (NTYPES)
The matrix types to be used for testing. Matrices of type j
(for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
.TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
NM (input) INTEGER
The number of values of M contained in the vector MVAL.
MVAL (input) INTEGER array, dimension (NM)
The values of the matrix row dimension M.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix column dimension N.
THRESH (input) DOUBLE PRECISION
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
TSTERR (input) LOGICAL
Flag that indicates whether error exits are to be tested.
A (workspace) COMPLEX*16 array, dimension (MMAX*NMAX)
where MMAX is the maximum value of M in MVAL and NMAX is the
maximum value of N in NVAL.
COPYA (workspace) COMPLEX*16 array, dimension (MMAX*NMAX)
S (workspace) DOUBLE PRECISION array, dimension
(min(MMAX,NMAX))
COPYS (workspace) DOUBLE PRECISION array, dimension
(min(MMAX,NMAX))
TAU (workspace) COMPLEX*16 array, dimension (MMAX)
WORK (workspace) COMPLEX*16 array, dimension
(MMAX*NMAX + 4*NMAX + MMAX)
RWORK (workspace) DOUBLE PRECISION array, dimension (2*NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--rwork;
--work;
--tau;
--copys;
--s;
--copya;
--a;
--nval;
--mval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "TZ", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = dlamch_("Epsilon");
/* Test the error exits */
if (*tsterr) {
zerrtz_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
/* Do for each value of M in MVAL. */
m = mval[im];
lda = max(1,m);
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
/* Do for each value of N in NVAL for which M .LE. N. */
n = nval[in];
mnmin = min(m,n);
/* Computing MAX */
i__3 = 1, i__4 = n * n + (m << 2) + n;
lwork = max(i__3,i__4);
if (m <= n) {
for (imode = 1; imode <= 3; ++imode) {
/* Do for each type of singular value distribution.
0: zero matrix
1: one small singular value
2: exponential distribution */
mode = imode - 1;
/* Test ZTZRQF
Generate test matrix of size m by n using
singular value distribution indicated by `mode'. */
if (mode == 0) {
zlaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.;
/* L20: */
}
} else {
d__1 = 1. / eps;
zlatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
copys[1], &imode, &d__1, &c_b15, &m, &n,
"No packing", &a[1], &lda, &work[1], &info);
zgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
1], &info);
i__3 = m - 1;
zlaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
lda);
dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
/* Save A and its singular values */
zlacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
/* Call ZTZRQF to reduce the upper trapezoidal matrix to
upper triangular form. */
s_copy(srnamc_1.srnamt, "ZTZRQF", (ftnlen)6, (ftnlen)6);
ztzrqf_(&m, &n, &a[1], &lda, &tau[1], &info);
/* Compute norm(svd(a) - svd(r)) */
result[0] = zqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
1], &lwork, &rwork[1]);
/* Compute norm( A - R*Q ) */
result[1] = ztzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
1], &work[1], &lwork);
/* Compute norm(Q'*Q - I). */
result[2] = ztzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
, &lwork);
/* Test ZTZRZF
Generate test matrix of size m by n using
singular value distribution indicated by `mode'. */
if (mode == 0) {
zlaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.;
/* L30: */
}
} else {
d__1 = 1. / eps;
zlatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
copys[1], &imode, &d__1, &c_b15, &m, &n,
"No packing", &a[1], &lda, &work[1], &info);
zgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
1], &info);
i__3 = m - 1;
zlaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
lda);
dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
/* Save A and its singular values */
zlacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
/* Call ZTZRZF to reduce the upper trapezoidal matrix to
upper triangular form. */
s_copy(srnamc_1.srnamt, "ZTZRZF", (ftnlen)6, (ftnlen)6);
ztzrzf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lwork, &
info);
/* Compute norm(svd(a) - svd(r)) */
result[3] = zqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
1], &lwork, &rwork[1]);
/* Compute norm( A - R*Q ) */
result[4] = zrzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
1], &work[1], &lwork);
/* Compute norm(Q'*Q - I). */
result[5] = zrzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
, &lwork);
/* Print information about the tests that did not pass
the threshold. */
for (k = 1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___21.ciunit = *nout;
s_wsfe(&io___21);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L40: */
}
nrun += 6;
/* L50: */
}
}
/* L60: */
}
/* L70: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
/* End if ZCHKTZ */
return 0;
} /* zchktz_ */
/* Subroutine */ int dchkq3_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
nxval, doublereal *thresh, doublereal *a, doublereal *copya,
doublereal *s, doublereal *copys, doublereal *tau, doublereal *work,
integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002 M =\002,i5,\002, N =\002,i5,\002, "
"NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
"=\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
doublereal d__1;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer mode, info;
static char path[3];
static integer ilow, nrun, i__;
extern /* Subroutine */ int alahd_(integer *, char *);
static integer k, m, n, ihigh, nfail, iseed[4], imode;
extern doublereal dqpt01_(integer *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *), dqrt11_(integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dqrt12_(integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *);
static integer mnmin;
extern /* Subroutine */ int icopy_(integer *, integer *, integer *,
integer *, integer *);
static integer istep, nerrs, lwork;
extern /* Subroutine */ int dgeqp3_(integer *, integer *, doublereal *,
integer *, integer *, doublereal *, doublereal *, integer *,
integer *);
static integer nb, im, in;
extern doublereal dlamch_(char *);
static integer lw;
extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *,
integer *);
static integer nx;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *), alasum_(char *, integer *,
integer *, integer *, integer *), dlatms_(integer *,
integer *, char *, integer *, char *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, char *,
doublereal *, integer *, doublereal *, integer *), xlaenv_(integer *, integer *);
static doublereal result[3];
static integer lda, inb;
static doublereal eps;
/* Fortran I/O blocks */
static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
/* -- 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
=======
DCHKQ3 tests DGEQP3.
Arguments
=========
DOTYPE (input) LOGICAL array, dimension (NTYPES)
The matrix types to be used for testing. Matrices of type j
(for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
.TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
NM (input) INTEGER
The number of values of M contained in the vector MVAL.
MVAL (input) INTEGER array, dimension (NM)
The values of the matrix row dimension M.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix column dimension N.
NNB (input) INTEGER
The number of values of NB and NX contained in the
vectors NBVAL and NXVAL. The blocking parameters are used
in pairs (NB,NX).
NBVAL (input) INTEGER array, dimension (NNB)
The values of the blocksize NB.
NXVAL (input) INTEGER array, dimension (NNB)
The values of the crossover point NX.
THRESH (input) DOUBLE PRECISION
The threshold value for the test ratios. A result is
included in the output file if RESULT >= THRESH. To have
every test ratio printed, use THRESH = 0.
A (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX)
where MMAX is the maximum value of M in MVAL and NMAX is the
maximum value of N in NVAL.
COPYA (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX)
S (workspace) DOUBLE PRECISION array, dimension
(min(MMAX,NMAX))
COPYS (workspace) DOUBLE PRECISION array, dimension
(min(MMAX,NMAX))
TAU (workspace) DOUBLE PRECISION array, dimension (MMAX)
WORK (workspace) DOUBLE PRECISION array, dimension
(MMAX*NMAX + 4*NMAX + MMAX)
IWORK (workspace) INTEGER array, dimension (2*NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--iwork;
--work;
--tau;
--copys;
--s;
--copya;
--a;
--nxval;
--nbval;
--nval;
--mval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "Q3", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = dlamch_("Epsilon");
infoc_1.infot = 0;
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
/* Do for each value of M in MVAL. */
m = mval[im];
lda = max(1,m);
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
mnmin = min(m,n);
/* Computing MAX */
i__3 = 1, i__4 = m * max(m,n) + (mnmin << 2) + max(m,n);
lwork = max(i__3,i__4);
for (imode = 1; imode <= 6; ++imode) {
if (! dotype[imode]) {
goto L70;
}
/* Do for each type of matrix
1: zero matrix
2: one small singular value
3: geometric distribution of singular values
4: first n/2 columns fixed
5: last n/2 columns fixed
6: every second column fixed */
mode = imode;
if (imode > 3) {
mode = 1;
}
/* Generate test matrix of size m by n using
singular value distribution indicated by `mode'. */
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
iwork[i__] = 0;
/* L20: */
}
if (imode == 1) {
dlaset_("Full", &m, &n, &c_b11, &c_b11, ©a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.;
/* L30: */
}
} else {
d__1 = 1. / eps;
dlatms_(&m, &n, "Uniform", iseed, "Nonsymm", ©s[1], &
mode, &d__1, &c_b16, &m, &n, "No packing", ©a[
1], &lda, &work[1], &info);
if (imode >= 4) {
if (imode == 4) {
ilow = 1;
istep = 1;
/* Computing MAX */
i__3 = 1, i__4 = n / 2;
ihigh = max(i__3,i__4);
} else if (imode == 5) {
/* Computing MAX */
i__3 = 1, i__4 = n / 2;
ilow = max(i__3,i__4);
istep = 1;
ihigh = n;
} else if (imode == 6) {
ilow = 1;
istep = 2;
ihigh = n;
}
i__3 = ihigh;
i__4 = istep;
for (i__ = ilow; i__4 < 0 ? i__ >= i__3 : i__ <= i__3;
i__ += i__4) {
iwork[i__] = 1;
/* L40: */
}
}
dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
nb = nbval[inb];
xlaenv_(&c__1, &nb);
nx = nxval[inb];
xlaenv_(&c__3, &nx);
/* Get a working copy of COPYA into A and a copy of
vector IWORK. */
dlacpy_("All", &m, &n, ©a[1], &lda, &a[1], &lda);
icopy_(&n, &iwork[1], &c__1, &iwork[n + 1], &c__1);
/* Compute the QR factorization with pivoting of A
Computing MAX */
i__3 = 1, i__5 = (n << 1) + nb * (n + 1);
lw = max(i__3,i__5);
/* Compute the QP3 factorization of A */
s_copy(srnamc_1.srnamt, "DGEQP3", (ftnlen)6, (ftnlen)6);
dgeqp3_(&m, &n, &a[1], &lda, &iwork[n + 1], &tau[1], &
work[1], &lw, &info);
/* Compute norm(svd(a) - svd(r)) */
result[0] = dqrt12_(&m, &n, &a[1], &lda, ©s[1], &work[
1], &lwork);
/* Compute norm( A*P - Q*R ) */
result[1] = dqpt01_(&m, &n, &mnmin, ©a[1], &a[1], &
lda, &tau[1], &iwork[n + 1], &work[1], &lwork);
/* Compute Q'*Q */
result[2] = dqrt11_(&m, &mnmin, &a[1], &lda, &tau[1], &
work[1], &lwork);
/* Print information about the tests that did not pass
the threshold. */
for (k = 1; k <= 3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___28.ciunit = *nout;
s_wsfe(&io___28);
do_fio(&c__1, "DGEQP3", (ftnlen)6);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L50: */
}
nrun += 3;
/* L60: */
}
L70:
;
}
/* L80: */
}
/* L90: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
/* End of DCHKQ3 */
return 0;
} /* dchkq3_ */
