/* Subroutine */ int zgelss_(integer *m, integer *n, integer *nrhs,
doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
doublereal *s, doublereal *rcond, integer *rank, doublecomplex *work,
integer *lwork, doublereal *rwork, integer *info)
{
/* -- LAPACK driver 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
=======
ZGELSS computes the minimum norm solution to a complex linear
least squares problem:
Minimize 2-norm(| b - A*x |).
using the singular value decomposition (SVD) of A. A is an M-by-N
matrix which may be rank-deficient.
Several right hand side vectors b and solution vectors x can be
handled in a single call; they are stored as the columns of the
M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix
X.
The effective rank of A is determined by treating as zero those
singular values which are less than RCOND times the largest singular
value.
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.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, the first min(m,n) rows of A are overwritten with
its right singular vectors, stored rowwise.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
On entry, the M-by-NRHS right hand side matrix B.
On exit, B is overwritten by the N-by-NRHS solution matrix X.
If m >= n and RANK = n, the residual sum-of-squares for
the solution in the i-th column is given by the sum of
squares of elements n+1:m in that column.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,M,N).
S (output) DOUBLE PRECISION array, dimension (min(M,N))
The singular values of A in decreasing order.
The condition number of A in the 2-norm = S(1)/S(min(m,n)).
RCOND (input) DOUBLE PRECISION
RCOND is used to determine the effective rank of A.
Singular values S(i) <= RCOND*S(1) are treated as zero.
If RCOND < 0, machine precision is used instead.
RANK (output) INTEGER
The effective rank of A, i.e., the number of singular values
which are greater than RCOND*S(1).
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 >= 1, and also:
LWORK >= 2*min(M,N) + max(M,N,NRHS)
For good performance, LWORK should generally be larger.
RWORK (workspace) DOUBLE PRECISION array, dimension (5*min(M,N)-1)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: the algorithm for computing the SVD failed to converge;
if INFO = i, i off-diagonal elements of an intermediate
bidiagonal form did not converge to zero.
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* Table of constant values */
static doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
static integer c__6 = 6;
static integer c_n1 = -1;
static integer c__1 = 1;
static integer c__0 = 0;
static doublereal c_b78 = 0.;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
static doublereal anrm, bnrm;
static integer itau;
static doublecomplex vdum[1];
static integer i, iascl, ibscl, chunk;
static doublereal sfmin;
static integer minmn;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
static integer maxmn, itaup, itauq, mnthr;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static integer iwork;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
static integer bl, ie, il;
extern doublereal dlamch_(char *);
static integer mm;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dlaset_(char *, integer *, integer
*, doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *), zgebrd_(integer *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
static doublereal bignum;
extern /* Subroutine */ int zgelqf_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *
), zlascl_(char *, integer *, integer *, doublereal *, doublereal
*, integer *, integer *, doublecomplex *, integer *, integer *), zgeqrf_(integer *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *, integer *), zdrscl_(
integer *, doublereal *, doublecomplex *, integer *);
static integer ldwork;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *), zbdsqr_(
char *, integer *, integer *, integer *, integer *, doublereal *,
doublereal *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, integer *);
static integer minwrk, maxwrk;
extern /* Subroutine */ int zungbr_(char *, integer *, integer *, integer
*, doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *);
static doublereal smlnum;
static integer irwork;
extern /* Subroutine */ int zunmbr_(char *, char *, char *, integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *
), zunmlq_(char *, char *, integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *
), zunmqr_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *);
static doublereal eps, thr;
#define VDUM(I) vdum[(I)]
#define S(I) s[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
*info = 0;
minmn = min(*m,*n);
maxmn = max(*m,*n);
mnthr = ilaenv_(&c__6, "ZGELSS", " ", m, n, nrhs, &c_n1, 6L, 1L);
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
} else if (*ldb < max(1,maxmn)) {
*info = -7;
}
/* Compute workspace
(Note: Comments in the code beginning "Workspace:" describe the
minimal amount of workspace needed at that point in the code,
as well as the preferred amount for good performance.
CWorkspace refers to complex workspace, and RWorkspace refers
to real workspace. NB refers to the optimal block size for the
immediately following subroutine, as returned by ILAENV.) */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
maxwrk = 0;
mm = *m;
if (*m >= *n && *m >= mnthr) {
/* Path 1a - overdetermined, with many more rows than co
lumns
Space needed for ZBDSQR is BDSPAC = 5*N-1 */
mm = *n;
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m,
n, &c_n1, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "ZUNMQR", "LT",
m, nrhs, n, &c_n1, 6L, 2L);
maxwrk = max(i__1,i__2);
}
if (*m >= *n) {
/* Path 1 - overdetermined or exactly determined
Space needed for ZBDSQR is BDSPC = 7*N+12
Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) + (mm + *n) * ilaenv_(&c__1,
"ZGEBRD", " ", &mm, n, &c_n1, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) + *nrhs * ilaenv_(&c__1, "ZUNMBR",
"QLC", &mm, nrhs, n, &c_n1, 6L, 3L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, "ZUN"
"GBR", "P", n, n, n, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *nrhs;
maxwrk = max(i__1,i__2);
minwrk = (*n << 1) + max(*nrhs,*m);
}
if (*n > *m) {
minwrk = (*m << 1) + max(*nrhs,*n);
if (*n >= mnthr) {
/* Path 2a - underdetermined, with many more colu
mns
than rows
Space needed for ZBDSQR is BDSPAC = 5*M-1 */
maxwrk = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &c_n1,
&c_n1, 6L, 1L);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *m * *m + (*m << 1) * ilaenv_(&
c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *m * *m + *nrhs * ilaenv_(&
c__1, "ZUNMBR", "QLC", m, nrhs, m, &c_n1, 6L, 3L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *m * *m + (*m - 1) * ilaenv_(&
c__1, "ZUNGBR", "P", m, m, m, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
if (*nrhs > 1) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs;
maxwrk = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 1);
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, "ZUNMLQ",
"LT", n, nrhs, m, &c_n1, 6L, 2L);
maxwrk = max(i__1,i__2);
} else {
/* Path 2 - underdetermined
Space needed for ZBDSQR is BDSPAC = 5*M-1 */
maxwrk = (*m << 1) + (*n + *m) * ilaenv_(&c__1, "ZGEBRD",
" ", m, n, &c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__1 = maxwrk, i__2 = (*m << 1) + *nrhs * ilaenv_(&c__1,
"ZUNMBR", "QLT", m, nrhs, m, &c_n1, 6L, 3L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1, "ZUNGBR"
, "P", m, n, m, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *nrhs;
maxwrk = max(i__1,i__2);
}
}
minwrk = max(minwrk,1);
maxwrk = max(minwrk,maxwrk);
WORK(1).r = (doublereal) maxwrk, WORK(1).i = 0.;
}
if (*lwork < minwrk) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGELSS", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
*rank = 0;
return 0;
}
/* Get machine parameters */
eps = dlamch_("P");
sfmin = dlamch_("S");
smlnum = sfmin / eps;
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = zlange_("M", m, n, &A(1,1), lda, &RWORK(1));
iascl = 0;
if (anrm > 0. && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &A(1,1), lda,
info);
iascl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM */
zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &A(1,1), lda,
info);
iascl = 2;
} else if (anrm == 0.) {
/* VISMatrix all zero. Return zero solution. */
i__1 = max(*m,*n);
zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &B(1,1), ldb);
dlaset_("F", &minmn, &c__1, &c_b78, &c_b78, &S(1), &minmn);
*rank = 0;
goto L70;
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = zlange_("M", m, nrhs, &B(1,1), ldb, &RWORK(1));
ibscl = 0;
if (bnrm > 0. && bnrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
zlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &B(1,1), ldb,
info);
ibscl = 1;
} else if (bnrm > bignum) {
/* Scale matrix norm down to BIGNUM */
zlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &B(1,1), ldb,
info);
ibscl = 2;
}
/* Overdetermined case */
if (*m >= *n) {
/* Path 1 - overdetermined or exactly determined */
mm = *m;
if (*m >= mnthr) {
/* Path 1a - overdetermined, with many more rows than co
lumns */
mm = *n;
itau = 1;
iwork = itau + *n;
/* Compute A=Q*R
(CWorkspace: need 2*N, prefer N+N*NB)
(RWorkspace: none) */
i__1 = *lwork - iwork + 1;
zgeqrf_(m, n, &A(1,1), lda, &WORK(itau), &WORK(iwork), &i__1,
info);
/* Multiply B by transpose(Q)
(CWorkspace: need N+NRHS, prefer N+NRHS*NB)
(RWorkspace: none) */
i__1 = *lwork - iwork + 1;
zunmqr_("L", "C", m, nrhs, n, &A(1,1), lda, &WORK(itau), &B(1,1), ldb, &WORK(iwork), &i__1, info);
/* Zero out below R */
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &A(2,1), lda);
}
}
ie = 1;
itauq = 1;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in A
(CWorkspace: need 2*N+MM, prefer 2*N+(MM+N)*NB)
(RWorkspace: need N) */
i__1 = *lwork - iwork + 1;
zgebrd_(&mm, n, &A(1,1), lda, &S(1), &RWORK(ie), &WORK(itauq), &
WORK(itaup), &WORK(iwork), &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors of R
(CWorkspace: need 2*N+NRHS, prefer 2*N+NRHS*NB)
(RWorkspace: none) */
i__1 = *lwork - iwork + 1;
zunmbr_("Q", "L", "C", &mm, nrhs, n, &A(1,1), lda, &WORK(itauq),
&B(1,1), ldb, &WORK(iwork), &i__1, info);
/* Generate right bidiagonalizing vectors of R in A
(CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
(RWorkspace: none) */
i__1 = *lwork - iwork + 1;
zungbr_("P", n, n, n, &A(1,1), lda, &WORK(itaup), &WORK(iwork), &
i__1, info);
irwork = ie + *n;
/* Perform bidiagonal QR iteration
multiply B by transpose of left singular vectors
compute right singular vectors in A
(CWorkspace: none)
(RWorkspace: need BDSPAC) */
zbdsqr_("U", n, n, &c__0, nrhs, &S(1), &RWORK(ie), &A(1,1), lda,
vdum, &c__1, &B(1,1), ldb, &RWORK(irwork), info);
if (*info != 0) {
goto L70;
}
/* Multiply B by reciprocals of singular values
Computing MAX */
d__1 = *rcond * S(1);
thr = max(d__1,sfmin);
if (*rcond < 0.) {
/* Computing MAX */
d__1 = eps * S(1);
thr = max(d__1,sfmin);
}
*rank = 0;
i__1 = *n;
for (i = 1; i <= *n; ++i) {
if (S(i) > thr) {
zdrscl_(nrhs, &S(i), &B(i,1), ldb);
++(*rank);
} else {
zlaset_("F", &c__1, nrhs, &c_b1, &c_b1, &B(i,1), ldb);
}
/* L10: */
}
/* Multiply B by right singular vectors
(CWorkspace: need N, prefer N*NRHS)
(RWorkspace: none) */
if (*lwork >= *ldb * *nrhs && *nrhs > 1) {
zgemm_("C", "N", n, nrhs, n, &c_b2, &A(1,1), lda, &B(1,1), ldb, &c_b1, &WORK(1), ldb);
zlacpy_("G", n, nrhs, &WORK(1), ldb, &B(1,1), ldb);
} else if (*nrhs > 1) {
chunk = *lwork / *n;
i__1 = *nrhs;
i__2 = chunk;
for (i = 1; chunk < 0 ? i >= *nrhs : i <= *nrhs; i += chunk) {
/* Computing MIN */
i__3 = *nrhs - i + 1;
bl = min(i__3,chunk);
zgemm_("C", "N", n, &bl, n, &c_b2, &A(1,1), lda, &B(1,1), ldb, &c_b1, &WORK(1), n);
zlacpy_("G", n, &bl, &WORK(1), n, &B(1,1), ldb);
/* L20: */
}
} else {
zgemv_("C", n, n, &c_b2, &A(1,1), lda, &B(1,1), &c__1, &
c_b1, &WORK(1), &c__1);
zcopy_(n, &WORK(1), &c__1, &B(1,1), &c__1);
}
} else /* if(complicated condition) */ {
/* Computing MAX */
i__2 = max(*m,*nrhs), i__1 = *n - (*m << 1);
if (*n >= mnthr && *lwork >= *m * 3 + *m * *m + max(i__2,i__1)) {
/* Underdetermined case, M much less than N
Path 2a - underdetermined, with many more columns than r
ows
and sufficient workspace for an efficient algorithm */
ldwork = *m;
/* Computing MAX */
i__2 = max(*m,*nrhs), i__1 = *n - (*m << 1);
if (*lwork >= *m * 3 + *m * *lda + max(i__2,i__1)) {
ldwork = *lda;
}
itau = 1;
iwork = *m + 1;
/* Compute A=L*Q
(CWorkspace: need 2*M, prefer M+M*NB)
(RWorkspace: none) */
i__2 = *lwork - iwork + 1;
zgelqf_(m, n, &A(1,1), lda, &WORK(itau), &WORK(iwork), &i__2,
info);
il = iwork;
/* Copy L to WORK(IL), zeroing out above it */
zlacpy_("L", m, m, &A(1,1), lda, &WORK(il), &ldwork);
i__2 = *m - 1;
i__1 = *m - 1;
zlaset_("U", &i__2, &i__1, &c_b1, &c_b1, &WORK(il + ldwork), &
ldwork);
ie = 1;
itauq = il + ldwork * *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in WORK(IL)
(CWorkspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
(RWorkspace: need M) */
i__2 = *lwork - iwork + 1;
zgebrd_(m, m, &WORK(il), &ldwork, &S(1), &RWORK(ie), &WORK(itauq),
&WORK(itaup), &WORK(iwork), &i__2, info);
/* Multiply B by transpose of left bidiagonalizing vectors
of L
(CWorkspace: need M*M+3*M+NRHS, prefer M*M+3*M+NRHS*NB)
(RWorkspace: none) */
i__2 = *lwork - iwork + 1;
zunmbr_("Q", "L", "C", m, nrhs, m, &WORK(il), &ldwork, &WORK(
itauq), &B(1,1), ldb, &WORK(iwork), &i__2, info);
/* Generate right bidiagonalizing vectors of R in WORK(IL)
(CWorkspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB)
(RWorkspace: none) */
i__2 = *lwork - iwork + 1;
zungbr_("P", m, m, m, &WORK(il), &ldwork, &WORK(itaup), &WORK(
iwork), &i__2, info);
irwork = ie + *m;
/* Perform bidiagonal QR iteration, computing right singula
r
vectors of L in WORK(IL) and multiplying B by transpose
of
left singular vectors
(CWorkspace: need M*M)
(RWorkspace: need BDSPAC) */
zbdsqr_("U", m, m, &c__0, nrhs, &S(1), &RWORK(ie), &WORK(il), &
ldwork, &A(1,1), lda, &B(1,1), ldb, &RWORK(
irwork), info);
if (*info != 0) {
goto L70;
}
/* Multiply B by reciprocals of singular values
Computing MAX */
d__1 = *rcond * S(1);
thr = max(d__1,sfmin);
if (*rcond < 0.) {
/* Computing MAX */
d__1 = eps * S(1);
thr = max(d__1,sfmin);
}
*rank = 0;
i__2 = *m;
for (i = 1; i <= *m; ++i) {
if (S(i) > thr) {
zdrscl_(nrhs, &S(i), &B(i,1), ldb);
++(*rank);
} else {
zlaset_("F", &c__1, nrhs, &c_b1, &c_b1, &B(i,1),
ldb);
}
/* L30: */
}
iwork = il + *m * ldwork;
/* Multiply B by right singular vectors of L in WORK(IL)
(CWorkspace: need M*M+2*M, prefer M*M+M+M*NRHS)
(RWorkspace: none) */
if (*lwork >= *ldb * *nrhs + iwork - 1 && *nrhs > 1) {
zgemm_("C", "N", m, nrhs, m, &c_b2, &WORK(il), &ldwork, &B(1,1), ldb, &c_b1, &WORK(iwork), ldb);
zlacpy_("G", m, nrhs, &WORK(iwork), ldb, &B(1,1), ldb);
} else if (*nrhs > 1) {
chunk = (*lwork - iwork + 1) / *m;
i__2 = *nrhs;
i__1 = chunk;
for (i = 1; chunk < 0 ? i >= *nrhs : i <= *nrhs; i += chunk) {
/* Computing MIN */
i__3 = *nrhs - i + 1;
bl = min(i__3,chunk);
zgemm_("C", "N", m, &bl, m, &c_b2, &WORK(il), &ldwork, &B(1,i), ldb, &c_b1, &WORK(iwork), n);
zlacpy_("G", m, &bl, &WORK(iwork), n, &B(1,1), ldb);
/* L40: */
}
} else {
zgemv_("C", m, m, &c_b2, &WORK(il), &ldwork, &B(1,1), &
c__1, &c_b1, &WORK(iwork), &c__1);
zcopy_(m, &WORK(iwork), &c__1, &B(1,1), &c__1);
}
/* Zero out below first M rows of B */
i__1 = *n - *m;
zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &B(*m+1,1), ldb);
iwork = itau + *m;
/* Multiply transpose(Q) by B
(CWorkspace: need M+NRHS, prefer M+NHRS*NB)
(RWorkspace: none) */
i__1 = *lwork - iwork + 1;
zunmlq_("L", "C", n, nrhs, m, &A(1,1), lda, &WORK(itau), &B(1,1), ldb, &WORK(iwork), &i__1, info);
} else {
/* Path 2 - remaining underdetermined cases */
ie = 1;
itauq = 1;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize A
(CWorkspace: need 3*M, prefer 2*M+(M+N)*NB)
(RWorkspace: need N) */
i__1 = *lwork - iwork + 1;
zgebrd_(m, n, &A(1,1), lda, &S(1), &RWORK(ie), &WORK(itauq),
&WORK(itaup), &WORK(iwork), &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors
(CWorkspace: need 2*M+NRHS, prefer 2*M+NRHS*NB)
(RWorkspace: none) */
i__1 = *lwork - iwork + 1;
zunmbr_("Q", "L", "C", m, nrhs, n, &A(1,1), lda, &WORK(itauq)
, &B(1,1), ldb, &WORK(iwork), &i__1, info);
/* Generate right bidiagonalizing vectors in A
(CWorkspace: need 3*M, prefer 2*M+M*NB)
(RWorkspace: none) */
i__1 = *lwork - iwork + 1;
zungbr_("P", m, n, m, &A(1,1), lda, &WORK(itaup), &WORK(
iwork), &i__1, info);
irwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing right singular vectors of A in A and
multiplying B by transpose of left singular vectors
(CWorkspace: none)
(RWorkspace: need BDSPAC) */
zbdsqr_("L", m, n, &c__0, nrhs, &S(1), &RWORK(ie), &A(1,1),
lda, vdum, &c__1, &B(1,1), ldb, &RWORK(irwork), info);
if (*info != 0) {
goto L70;
}
/* Multiply B by reciprocals of singular values
Computing MAX */
d__1 = *rcond * S(1);
thr = max(d__1,sfmin);
if (*rcond < 0.) {
/* Computing MAX */
d__1 = eps * S(1);
thr = max(d__1,sfmin);
}
*rank = 0;
i__1 = *m;
for (i = 1; i <= *m; ++i) {
if (S(i) > thr) {
zdrscl_(nrhs, &S(i), &B(i,1), ldb);
++(*rank);
} else {
zlaset_("F", &c__1, nrhs, &c_b1, &c_b1, &B(i,1),
ldb);
}
/* L50: */
}
/* Multiply B by right singular vectors of A
(CWorkspace: need N, prefer N*NRHS)
(RWorkspace: none) */
if (*lwork >= *ldb * *nrhs && *nrhs > 1) {
zgemm_("C", "N", n, nrhs, m, &c_b2, &A(1,1), lda, &B(1,1), ldb, &c_b1, &WORK(1), ldb);
zlacpy_("G", n, nrhs, &WORK(1), ldb, &B(1,1), ldb);
} else if (*nrhs > 1) {
chunk = *lwork / *n;
i__1 = *nrhs;
i__2 = chunk;
for (i = 1; chunk < 0 ? i >= *nrhs : i <= *nrhs; i += chunk) {
/* Computing MIN */
i__3 = *nrhs - i + 1;
bl = min(i__3,chunk);
zgemm_("C", "N", n, &bl, m, &c_b2, &A(1,1), lda, &B(1,i), ldb, &c_b1, &WORK(1), n);
zlacpy_("F", n, &bl, &WORK(1), n, &B(1,i), ldb);
/* L60: */
}
} else {
zgemv_("C", m, n, &c_b2, &A(1,1), lda, &B(1,1), &
c__1, &c_b1, &WORK(1), &c__1);
zcopy_(n, &WORK(1), &c__1, &B(1,1), &c__1);
}
}
}
/* Undo scaling */
if (iascl == 1) {
zlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &B(1,1), ldb,
info);
dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &S(1), &
minmn, info);
} else if (iascl == 2) {
zlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &B(1,1), ldb,
info);
dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &S(1), &
minmn, info);
}
if (ibscl == 1) {
zlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &B(1,1), ldb,
info);
} else if (ibscl == 2) {
zlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &B(1,1), ldb,
info);
}
L70:
WORK(1).r = (doublereal) maxwrk, WORK(1).i = 0.;
return 0;
/* End of ZGELSS */
} /* zgelss_ */
int main(void)
{
/* Local scalars */
char vect, vect_i;
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_zungbr( &vect, &m, &n, &k, &lda, &lwork );
lda_r = n+2;
vect_i = vect;
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( MIN(m,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( MIN(m,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( (MIN(m,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 */
zungbr_( &vect, &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 < (MIN(m,k)); i++ ) {
tau_i[i] = tau[i];
}
for( i = 0; i < lwork; i++ ) {
work_i[i] = work[i];
}
info_i = LAPACKE_zungbr_work( LAPACK_COL_MAJOR, vect_i, m_i, n_i, k_i, a_i,
lda_i, tau_i, work_i, lwork_i );
failed = compare_zungbr( a, a_i, info, info_i, lda, n );
if( failed == 0 ) {
printf( "PASSED: column-major middle-level interface to zungbr\n" );
} else {
printf( "FAILED: column-major middle-level interface to zungbr\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 < (MIN(m,k)); i++ ) {
tau_i[i] = tau[i];
}
for( i = 0; i < lwork; i++ ) {
work_i[i] = work[i];
}
info_i = LAPACKE_zungbr( LAPACK_COL_MAJOR, vect_i, m_i, n_i, k_i, a_i,
lda_i, tau_i );
failed = compare_zungbr( a, a_i, info, info_i, lda, n );
if( failed == 0 ) {
printf( "PASSED: column-major high-level interface to zungbr\n" );
} else {
printf( "FAILED: column-major high-level interface to zungbr\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 < (MIN(m,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_zungbr_work( LAPACK_ROW_MAJOR, vect_i, 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_zungbr( a, a_i, info, info_i, lda, n );
if( failed == 0 ) {
printf( "PASSED: row-major middle-level interface to zungbr\n" );
} else {
printf( "FAILED: row-major middle-level interface to zungbr\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 < (MIN(m,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_zungbr( LAPACK_ROW_MAJOR, vect_i, 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_zungbr( a, a_i, info, info_i, lda, n );
if( failed == 0 ) {
printf( "PASSED: row-major high-level interface to zungbr\n" );
} else {
printf( "FAILED: row-major high-level interface to zungbr\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 zerrbd_(char *path, integer *nunit)
{
/* Format strings */
static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
"rror exits (\002,i3,\002 tests done)\002)";
static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
"ts of the error \002,\002exits ***\002)";
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
doublecomplex a[16] /* was [4][4] */;
doublereal d__[4], e[4];
integer i__, j;
doublecomplex u[16] /* was [4][4] */, v[16] /* was [4][4] */, w[4];
char c2[2];
integer nt;
doublecomplex tp[4], tq[4];
doublereal rw[16];
integer info;
extern /* Subroutine */ int zgebrd_(integer *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), zbdsqr_(char *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *
, doublereal *, integer *), zungbr_(char *, integer *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, integer *), zunmbr_(char *,
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 };
static cilist io___16 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___17 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZERRBD tests the error exits for ZGEBRD, ZUNGBR, ZUNMBR, and ZBDSQR. */
/* 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 Functions .. */
/* .. */
/* .. 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();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
/* Set the variables to innocuous values. */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
i__1 = i__ + (j << 2) - 5;
d__1 = 1. / (doublereal) (i__ + j);
a[i__1].r = d__1, a[i__1].i = 0.;
/* L10: */
}
/* L20: */
}
infoc_1.ok = TRUE_;
nt = 0;
/* Test error exits of the SVD routines. */
if (lsamen_(&c__2, c2, "BD")) {
/* ZGEBRD */
s_copy(srnamc_1.srnamt, "ZGEBRD", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zgebrd_(&c_n1, &c__0, a, &c__1, d__, e, tq, tp, w, &c__1, &info);
chkxer_("ZGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgebrd_(&c__0, &c_n1, a, &c__1, d__, e, tq, tp, w, &c__1, &info);
chkxer_("ZGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zgebrd_(&c__2, &c__1, a, &c__1, d__, e, tq, tp, w, &c__2, &info);
chkxer_("ZGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
zgebrd_(&c__2, &c__1, a, &c__2, d__, e, tq, tp, w, &c__1, &info);
chkxer_("ZGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 4;
/* ZUNGBR */
s_copy(srnamc_1.srnamt, "ZUNGBR", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zungbr_("/", &c__0, &c__0, &c__0, a, &c__1, tq, w, &c__1, &info);
chkxer_("ZUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zungbr_("Q", &c_n1, &c__0, &c__0, a, &c__1, tq, w, &c__1, &info);
chkxer_("ZUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zungbr_("Q", &c__0, &c_n1, &c__0, a, &c__1, tq, w, &c__1, &info);
chkxer_("ZUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zungbr_("Q", &c__0, &c__1, &c__0, a, &c__1, tq, w, &c__1, &info);
chkxer_("ZUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zungbr_("Q", &c__1, &c__0, &c__1, a, &c__1, tq, w, &c__1, &info);
chkxer_("ZUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zungbr_("P", &c__1, &c__0, &c__0, a, &c__1, tq, w, &c__1, &info);
chkxer_("ZUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zungbr_("P", &c__0, &c__1, &c__1, a, &c__1, tq, w, &c__1, &info);
chkxer_("ZUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zungbr_("Q", &c__0, &c__0, &c_n1, a, &c__1, tq, w, &c__1, &info);
chkxer_("ZUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
zungbr_("Q", &c__2, &c__1, &c__1, a, &c__1, tq, w, &c__1, &info);
chkxer_("ZUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
zungbr_("Q", &c__2, &c__2, &c__1, a, &c__2, tq, w, &c__1, &info);
chkxer_("ZUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 10;
/* ZUNMBR */
s_copy(srnamc_1.srnamt, "ZUNMBR", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zunmbr_("/", "L", "T", &c__0, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
&c__1, &info);
chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zunmbr_("Q", "/", "T", &c__0, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
&c__1, &info);
chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zunmbr_("Q", "L", "/", &c__0, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
&c__1, &info);
chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zunmbr_("Q", "L", "C", &c_n1, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
&c__1, &info);
chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zunmbr_("Q", "L", "C", &c__0, &c_n1, &c__0, a, &c__1, tq, u, &c__1, w,
&c__1, &info);
chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
zunmbr_("Q", "L", "C", &c__0, &c__0, &c_n1, a, &c__1, tq, u, &c__1, w,
&c__1, &info);
chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
zunmbr_("Q", "L", "C", &c__2, &c__0, &c__0, a, &c__1, tq, u, &c__2, w,
&c__1, &info);
chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
zunmbr_("Q", "R", "C", &c__0, &c__2, &c__0, a, &c__1, tq, u, &c__1, w,
&c__1, &info);
chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
zunmbr_("P", "L", "C", &c__2, &c__0, &c__2, a, &c__1, tq, u, &c__2, w,
&c__1, &info);
chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
zunmbr_("P", "R", "C", &c__0, &c__2, &c__2, a, &c__1, tq, u, &c__1, w,
&c__1, &info);
chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
zunmbr_("Q", "R", "C", &c__2, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
&c__1, &info);
chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
zunmbr_("Q", "L", "C", &c__0, &c__2, &c__0, a, &c__1, tq, u, &c__1, w,
&c__0, &info);
chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
zunmbr_("Q", "R", "C", &c__2, &c__0, &c__0, a, &c__1, tq, u, &c__2, w,
&c__0, &info);
chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 13;
/* ZBDSQR */
s_copy(srnamc_1.srnamt, "ZBDSQR", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
zbdsqr_("/", &c__0, &c__0, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
a, &c__1, rw, &info);
chkxer_("ZBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zbdsqr_("U", &c_n1, &c__0, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
a, &c__1, rw, &info);
chkxer_("ZBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zbdsqr_("U", &c__0, &c_n1, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
a, &c__1, rw, &info);
chkxer_("ZBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zbdsqr_("U", &c__0, &c__0, &c_n1, &c__0, d__, e, v, &c__1, u, &c__1,
a, &c__1, rw, &info);
chkxer_("ZBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zbdsqr_("U", &c__0, &c__0, &c__0, &c_n1, d__, e, v, &c__1, u, &c__1,
a, &c__1, rw, &info);
chkxer_("ZBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
zbdsqr_("U", &c__2, &c__1, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
a, &c__1, rw, &info);
chkxer_("ZBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
zbdsqr_("U", &c__0, &c__0, &c__2, &c__0, d__, e, v, &c__1, u, &c__1,
a, &c__1, rw, &info);
chkxer_("ZBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
zbdsqr_("U", &c__2, &c__0, &c__0, &c__1, d__, e, v, &c__1, u, &c__1,
a, &c__1, rw, &info);
chkxer_("ZBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
}
/* Print a summary line. */
if (infoc_1.ok) {
io___16.ciunit = infoc_1.nout;
s_wsfe(&io___16);
do_fio(&c__1, path, (ftnlen)3);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___17.ciunit = infoc_1.nout;
s_wsfe(&io___17);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
return 0;
/* End of ZERRBD */
} /* zerrbd_ */
