/* Subroutine */ int cchkq3_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
nxval, real *thresh, complex *a, complex *copya, real *s, real *copys,
complex *tau, complex *work, real *rwork, 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;
real r__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, nb, im, in, lw, nx, lda, inb;
real eps;
integer mode, info;
char path[3];
integer ilow, nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer ihigh, nfail, iseed[4], imode;
extern doublereal cqpt01_(integer *, integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *),
cqrt11_(integer *, integer *, complex *, integer *, complex *,
complex *, integer *), cqrt12_(integer *, integer *, complex *,
integer *, real *, complex *, integer *, real *);
integer mnmin;
extern /* Subroutine */ int icopy_(integer *, integer *, integer *,
integer *, integer *);
integer istep, nerrs, lwork;
extern /* Subroutine */ int cgeqp3_(integer *, integer *, complex *,
integer *, integer *, complex *, complex *, integer *, real *,
integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *), alasum_(char *, integer *, integer *, integer *, integer
*), clatms_(integer *, integer *, char *, integer *, char
*, real *, integer *, real *, real *, integer *, integer *, char *
, complex *, integer *, complex *, integer *), slaord_(char *, integer *, real *, integer *),
xlaenv_(integer *, integer *);
real result[3];
/* Fortran I/O blocks */
static cilist io___28 = { 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 */
/* ======= */
/* CCHKQ3 tests CGEQP3. */
/* 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) REAL */
/* 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) COMPLEX 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 array, dimension (MMAX*NMAX) */
/* S (workspace) REAL array, dimension */
/* (min(MMAX,NMAX)) */
/* COPYS (workspace) REAL array, dimension */
/* (min(MMAX,NMAX)) */
/* TAU (workspace) COMPLEX array, dimension (MMAX) */
/* WORK (workspace) COMPLEX array, dimension */
/* (max(M*max(M,N) + 4*min(M,N) + max(M,N))) */
/* RWORK (workspace) REAL array, dimension (4*NMAX) */
/* IWORK (workspace) INTEGER array, dimension (2*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;
--nxval;
--nbval;
--nval;
--mval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
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 = slamch_("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) {
claset_("Full", &m, &n, &c_b1, &c_b1, ©a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.f;
/* L30: */
}
} else {
r__1 = 1.f / eps;
clatms_(&m, &n, "Uniform", iseed, "Nonsymm", ©s[1], &
mode, &r__1, &c_b15, &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: */
}
}
slaord_("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);
/* Save A and its singular values and a copy of */
/* vector IWORK. */
clacpy_("All", &m, &n, ©a[1], &lda, &a[1], &lda);
icopy_(&n, &iwork[1], &c__1, &iwork[n + 1], &c__1);
/* Workspace needed. */
lw = nb * (n + 1);
s_copy(srnamc_1.srnamt, "CGEQP3", (ftnlen)6, (ftnlen)6);
cgeqp3_(&m, &n, &a[1], &lda, &iwork[n + 1], &tau[1], &
work[1], &lw, &rwork[1], &info);
/* Compute norm(svd(a) - svd(r)) */
result[0] = cqrt12_(&m, &n, &a[1], &lda, ©s[1], &work[
1], &lwork, &rwork[1]);
/* Compute norm( A*P - Q*R ) */
result[1] = cqpt01_(&m, &n, &mnmin, ©a[1], &a[1], &
lda, &tau[1], &iwork[n + 1], &work[1], &lwork);
/* Compute Q'*Q */
result[2] = cqrt11_(&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, "CGEQP3", (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(real));
e_wsfe();
++nfail;
}
/* L50: */
}
nrun += 3;
/* L60: */
}
L70:
;
}
/* L80: */
}
/* L90: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
/* End of CCHKQ3 */
return 0;
} /* cchkq3_ */
/* Subroutine */ int sqrt15_(integer *scale, integer *rksel, integer *m,
integer *n, integer *nrhs, real *a, integer *lda, real *b, integer *
ldb, real *s, integer *rank, real *norma, real *normb, integer *iseed,
real *work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
real r__1;
/* Local variables */
static integer info;
static real temp;
extern doublereal snrm2_(integer *, real *, integer *);
static integer j;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
slarf_(char *, integer *, integer *, real *, integer *, real *,
real *, integer *, real *), sgemm_(char *, char *,
integer *, integer *, integer *, real *, real *, integer *, real *
, integer *, real *, real *, integer *);
extern doublereal sasum_(integer *, real *, integer *);
static real dummy[1];
static integer mn;
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int xerbla_(char *, integer *);
static real bignum;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
extern doublereal slarnd_(integer *, integer *);
extern /* Subroutine */ int slaord_(char *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *,
real *, integer *), slaror_(char *, char *, integer *,
integer *, real *, integer *, integer *, real *, integer *), slarnv_(integer *, integer *, integer *, real *);
static real 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
=======
SQRT15 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) REAL array, dimension (LDA,N)
The M-by-N matrix A.
LDA (input) INTEGER
The leading dimension of the array A.
B (output) REAL 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) REAL array, dimension MIN(M,N)
Singular values of A.
RANK (output) INTEGER
number of nonzero singular values of A.
NORMA (output) REAL
one-norm of A.
NORMB (output) REAL
one-norm of B.
ISEED (input/output) integer array, dimension (4)
seed for random number generator.
WORK (workspace) REAL 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_("SQRT15", &c__16);
return 0;
}
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
eps = slamch_("Epsilon");
smlnum = smlnum / eps / eps;
bignum = 1.f / 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.f;
/* L10: */
}
} else {
xerbla_("SQRT15", &c__2);
}
if (*rank > 0) {
/* Nontrivial case */
s[1] = 1.f;
i__1 = *rank;
for (j = 2; j <= i__1; ++j) {
L20:
temp = slarnd_(&c__1, &iseed[1]);
if (temp > .1f) {
s[j] = dabs(temp);
} else {
goto L20;
}
/* L30: */
}
slaord_("Decreasing", rank, &s[1], &c__1);
/* Generate 'rank' columns of a random orthogonal matrix in A */
slarnv_(&c__2, &iseed[1], m, &work[1]);
r__1 = 1.f / snrm2_(m, &work[1], &c__1);
sscal_(m, &r__1, &work[1], &c__1);
slaset_("Full", m, rank, &c_b18, &c_b19, &a[a_offset], lda)
;
slarf_("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;
slarnv_(&c__2, &iseed[1], &i__1, &work[1]);
sgemm_("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) {
sscal_(m, &s[j], &a_ref(1, j), &c__1);
/* L40: */
}
if (*rank < *n) {
i__1 = *n - *rank;
slaset_("Full", m, &i__1, &c_b18, &c_b18, &a_ref(1, *rank + 1),
lda);
}
slaror_("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.f;
/* L50: */
}
slaset_("Full", m, n, &c_b18, &c_b18, &a[a_offset], lda);
slaset_("Full", m, nrhs, &c_b18, &c_b18, &b[b_offset], ldb)
;
}
/* Scale the matrix */
if (*scale != 1) {
*norma = slange_("Max", m, n, &a[a_offset], lda, dummy);
if (*norma != 0.f) {
if (*scale == 2) {
/* matrix scaled up */
slascl_("General", &c__0, &c__0, norma, &bignum, m, n, &a[
a_offset], lda, &info);
slascl_("General", &c__0, &c__0, norma, &bignum, &mn, &c__1, &
s[1], &mn, &info);
slascl_("General", &c__0, &c__0, norma, &bignum, m, nrhs, &b[
b_offset], ldb, &info);
} else if (*scale == 3) {
/* matrix scaled down */
slascl_("General", &c__0, &c__0, norma, &smlnum, m, n, &a[
a_offset], lda, &info);
slascl_("General", &c__0, &c__0, norma, &smlnum, &mn, &c__1, &
s[1], &mn, &info);
slascl_("General", &c__0, &c__0, norma, &smlnum, m, nrhs, &b[
b_offset], ldb, &info);
} else {
xerbla_("SQRT15", &c__1);
return 0;
}
}
}
*norma = sasum_(&mn, &s[1], &c__1);
*normb = slange_("One-norm", m, nrhs, &b[b_offset], ldb, dummy)
;
return 0;
/* End of SQRT15 */
} /* sqrt15_ */
/* Subroutine */ int schktz_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, real *thresh, logical *tsterr, real *a,
real *copya, real *s, real *copys, real *tau, real *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;
real r__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;
real eps;
integer mode, info;
char path[3];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer nfail, iseed[4], imode, mnmin, nerrs;
extern doublereal sqrt12_(integer *, integer *, real *, integer *, real *,
real *, integer *);
integer lwork;
extern doublereal srzt01_(integer *, integer *, real *, real *, integer *,
real *, real *, integer *), srzt02_(integer *, integer *, real *,
integer *, real *, real *, integer *), stzt01_(integer *,
integer *, real *, real *, integer *, real *, real *, integer *),
stzt02_(integer *, integer *, real *, integer *, real *, real *,
integer *);
extern /* Subroutine */ int sgeqr2_(integer *, integer *, real *, integer
*, real *, real *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
*, integer *), slaord_(char *, integer *, real *, integer
*), slacpy_(char *, integer *, integer *, real *, integer
*, real *, integer *), slaset_(char *, integer *, integer
*, real *, real *, real *, integer *), slatms_(integer *,
integer *, char *, integer *, char *, real *, integer *, real *,
real *, integer *, integer *, char *, real *, integer *, real *,
integer *);
real result[6];
extern /* Subroutine */ int serrtz_(char *, integer *), stzrqf_(
integer *, integer *, real *, integer *, real *, integer *),
stzrzf_(integer *, integer *, real *, integer *, real *, real *,
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 */
/* ======= */
/* SCHKTZ tests STZRQF 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) REAL */
/* 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) REAL 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) REAL array, dimension (MMAX*NMAX) */
/* S (workspace) REAL array, dimension */
/* (min(MMAX,NMAX)) */
/* COPYS (workspace) REAL array, dimension */
/* (min(MMAX,NMAX)) */
/* TAU (workspace) REAL array, dimension (MMAX) */
/* WORK (workspace) REAL 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, "Single 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 = slamch_("Epsilon");
/* Test the error exits */
if (*tsterr) {
serrtz_(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 STZRQF */
/* Generate test matrix of size m by n using */
/* singular value distribution indicated by `mode'. */
if (mode == 0) {
slaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.f;
/* L20: */
}
} else {
r__1 = 1.f / eps;
slatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
copys[1], &imode, &r__1, &c_b15, &m, &n,
"No packing", &a[1], &lda, &work[1], &info);
sgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
1], &info);
i__3 = m - 1;
slaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
lda);
slaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
/* Save A and its singular values */
slacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
/* Call STZRQF to reduce the upper trapezoidal matrix to */
/* upper triangular form. */
s_copy(srnamc_1.srnamt, "STZRQF", (ftnlen)32, (ftnlen)6);
stzrqf_(&m, &n, &a[1], &lda, &tau[1], &info);
/* Compute norm(svd(a) - svd(r)) */
result[0] = sqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
1], &lwork);
/* Compute norm( A - R*Q ) */
result[1] = stzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
1], &work[1], &lwork);
/* Compute norm(Q'*Q - I). */
result[2] = stzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
, &lwork);
/* Test STZRZF */
/* Generate test matrix of size m by n using */
/* singular value distribution indicated by `mode'. */
if (mode == 0) {
slaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
i__3 = mnmin;
for (i__ = 1; i__ <= i__3; ++i__) {
copys[i__] = 0.f;
/* L30: */
}
} else {
r__1 = 1.f / eps;
slatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
copys[1], &imode, &r__1, &c_b15, &m, &n,
"No packing", &a[1], &lda, &work[1], &info);
sgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
1], &info);
i__3 = m - 1;
slaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
lda);
slaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
/* Save A and its singular values */
slacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
/* Call STZRZF to reduce the upper trapezoidal matrix to */
/* upper triangular form. */
s_copy(srnamc_1.srnamt, "STZRZF", (ftnlen)32, (ftnlen)6);
stzrzf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lwork, &
info);
/* Compute norm(svd(a) - svd(r)) */
result[3] = sqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
1], &lwork);
/* Compute norm( A - R*Q ) */
result[4] = srzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
1], &work[1], &lwork);
/* Compute norm(Q'*Q - I). */
result[5] = srzt02_(&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(real));
e_wsfe();
++nfail;
}
/* L40: */
}
nrun += 6;
L50:
;
}
}
/* L60: */
}
/* L70: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
/* End if SCHKTZ */
return 0;
} /* schktz_ */
/* Subroutine */ int cqrt15_(integer *scale, integer *rksel, integer *m,
integer *n, integer *nrhs, complex *a, integer *lda, complex *b,
integer *ldb, real *s, integer *rank, real *norma, real *normb,
integer *iseed, complex *work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
real r__1;
/* Local variables */
integer j, mn;
real eps;
integer info;
real temp;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *), clarf_(char *,
integer *, integer *, complex *, integer *, complex *, complex *,
integer *, complex *);
extern doublereal sasum_(integer *, real *, integer *);
real dummy[1];
extern doublereal scnrm2_(integer *, complex *, integer *);
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, complex *, integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), claset_(char *, integer *, integer *, complex *, complex *,
complex *, integer *), xerbla_(char *, integer *);
real bignum;
extern /* Subroutine */ int claror_(char *, char *, integer *, integer *,
complex *, integer *, integer *, complex *, integer *);
extern doublereal slarnd_(integer *, integer *);
extern /* Subroutine */ int slaord_(char *, integer *, real *, integer *), clarnv_(integer *, integer *, integer *, complex *),
slascl_(char *, integer *, integer *, real *, real *, integer *,
integer *, real *, integer *, integer *);
real smlnum;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CQRT15 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) COMPLEX array, dimension (LDA,N) */
/* The M-by-N matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* B (output) COMPLEX 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) REAL array, dimension MIN(M,N) */
/* Singular values of A. */
/* RANK (output) INTEGER */
/* number of nonzero singular values of A. */
/* NORMA (output) REAL */
/* one-norm norm of A. */
/* NORMB (output) REAL */
/* one-norm norm of B. */
/* ISEED (input/output) integer array, dimension (4) */
/* seed for random number generator. */
/* WORK (workspace) COMPLEX array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* length of work space required. */
/* LWORK >= MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
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_("CQRT15", &c__16);
return 0;
}
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
eps = slamch_("Epsilon");
smlnum = smlnum / eps / eps;
bignum = 1.f / 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.f;
/* L10: */
}
} else {
xerbla_("CQRT15", &c__2);
}
if (*rank > 0) {
/* Nontrivial case */
s[1] = 1.f;
i__1 = *rank;
for (j = 2; j <= i__1; ++j) {
L20:
temp = slarnd_(&c__1, &iseed[1]);
if (temp > .1f) {
s[j] = dabs(temp);
} else {
goto L20;
}
/* L30: */
}
slaord_("Decreasing", rank, &s[1], &c__1);
/* Generate 'rank' columns of a random orthogonal matrix in A */
clarnv_(&c__2, &iseed[1], m, &work[1]);
r__1 = 1.f / scnrm2_(m, &work[1], &c__1);
csscal_(m, &r__1, &work[1], &c__1);
claset_("Full", m, rank, &c_b1, &c_b2, &a[a_offset], lda);
clarf_("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;
clarnv_(&c__2, &iseed[1], &i__1, &work[1]);
cgemm_("No transpose", "No transpose", m, nrhs, rank, &c_b2, &a[
a_offset], lda, &work[1], rank, &c_b1, &b[b_offset], ldb);
/* work space used: <= mn *nrhs */
/* generate (unscaled) matrix A */
i__1 = *rank;
for (j = 1; j <= i__1; ++j) {
csscal_(m, &s[j], &a[j * a_dim1 + 1], &c__1);
/* L40: */
}
if (*rank < *n) {
i__1 = *n - *rank;
claset_("Full", m, &i__1, &c_b1, &c_b1, &a[(*rank + 1) * a_dim1 +
1], lda);
}
claror_("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.f;
/* L50: */
}
claset_("Full", m, n, &c_b1, &c_b1, &a[a_offset], lda);
claset_("Full", m, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
}
/* Scale the matrix */
if (*scale != 1) {
*norma = clange_("Max", m, n, &a[a_offset], lda, dummy);
if (*norma != 0.f) {
if (*scale == 2) {
/* matrix scaled up */
clascl_("General", &c__0, &c__0, norma, &bignum, m, n, &a[
a_offset], lda, &info);
slascl_("General", &c__0, &c__0, norma, &bignum, &mn, &c__1, &
s[1], &mn, &info);
clascl_("General", &c__0, &c__0, norma, &bignum, m, nrhs, &b[
b_offset], ldb, &info);
} else if (*scale == 3) {
/* matrix scaled down */
clascl_("General", &c__0, &c__0, norma, &smlnum, m, n, &a[
a_offset], lda, &info);
slascl_("General", &c__0, &c__0, norma, &smlnum, &mn, &c__1, &
s[1], &mn, &info);
clascl_("General", &c__0, &c__0, norma, &smlnum, m, nrhs, &b[
b_offset], ldb, &info);
} else {
xerbla_("CQRT15", &c__1);
return 0;
}
}
}
*norma = sasum_(&mn, &s[1], &c__1);
*normb = clange_("One-norm", m, nrhs, &b[b_offset], ldb, dummy)
;
return 0;
/* End of CQRT15 */
} /* cqrt15_ */
