/* Subroutine */ int dggevx_(char *balanc, char *jobvl, char *jobvr, char *
sense, integer *n, doublereal *a, integer *lda, doublereal *b,
integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *
beta, doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr,
integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale,
doublereal *abnrm, doublereal *bbnrm, doublereal *rconde, doublereal *
rcondv, doublereal *work, integer *lwork, integer *iwork, logical *
bwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
vr_offset, i__1, i__2;
doublereal d__1, d__2, d__3, d__4;
/* Local variables */
integer i__, j, m, jc, in, mm, jr;
doublereal eps;
logical ilv, pair;
doublereal anrm, bnrm;
integer ierr, itau;
doublereal temp;
logical ilvl, ilvr;
integer iwrk, iwrk1;
integer icols;
logical noscl;
integer irows;
logical ilascl, ilbscl;
logical ldumma[1];
char chtemp[1];
doublereal bignum;
integer ijobvl;
integer ijobvr;
logical wantsb;
doublereal anrmto;
logical wantse;
doublereal bnrmto;
integer minwrk, maxwrk;
logical wantsn;
doublereal smlnum;
logical lquery, wantsv;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B) */
/* the generalized eigenvalues, and optionally, the left and/or right */
/* generalized eigenvectors. */
/* Optionally also, it computes a balancing transformation to improve */
/* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */
/* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for */
/* the eigenvalues (RCONDE), and reciprocal condition numbers for the */
/* right eigenvectors (RCONDV). */
/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar */
/* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is */
/* singular. It is usually represented as the pair (alpha,beta), as */
/* there is a reasonable interpretation for beta=0, and even for both */
/* being zero. */
/* The right eigenvector v(j) corresponding to the eigenvalue lambda(j) */
/* of (A,B) satisfies */
/* A * v(j) = lambda(j) * B * v(j) . */
/* The left eigenvector u(j) corresponding to the eigenvalue lambda(j) */
/* of (A,B) satisfies */
/* u(j)**H * A = lambda(j) * u(j)**H * B. */
/* where u(j)**H is the conjugate-transpose of u(j). */
/* Arguments */
/* ========= */
/* BALANC (input) CHARACTER*1 */
/* Specifies the balance option to be performed. */
/* = 'N': do not diagonally scale or permute; */
/* = 'P': permute only; */
/* = 'S': scale only; */
/* = 'B': both permute and scale. */
/* Computed reciprocal condition numbers will be for the */
/* matrices after permuting and/or balancing. Permuting does */
/* not change condition numbers (in exact arithmetic), but */
/* balancing does. */
/* JOBVL (input) CHARACTER*1 */
/* = 'N': do not compute the left generalized eigenvectors; */
/* = 'V': compute the left generalized eigenvectors. */
/* JOBVR (input) CHARACTER*1 */
/* = 'N': do not compute the right generalized eigenvectors; */
/* = 'V': compute the right generalized eigenvectors. */
/* SENSE (input) CHARACTER*1 */
/* Determines which reciprocal condition numbers are computed. */
/* = 'N': none are computed; */
/* = 'E': computed for eigenvalues only; */
/* = 'V': computed for eigenvectors only; */
/* = 'B': computed for eigenvalues and eigenvectors. */
/* N (input) INTEGER */
/* The order of the matrices A, B, VL, and VR. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
/* On entry, the matrix A in the pair (A,B). */
/* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V' */
/* or both, then A contains the first part of the real Schur */
/* form of the "balanced" versions of the input A and B. */
/* LDA (input) INTEGER */
/* The leading dimension of A. LDA >= max(1,N). */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */
/* On entry, the matrix B in the pair (A,B). */
/* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V' */
/* or both, then B contains the second part of the real Schur */
/* form of the "balanced" versions of the input A and B. */
/* LDB (input) INTEGER */
/* The leading dimension of B. LDB >= max(1,N). */
/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */
/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */
/* BETA (output) DOUBLE PRECISION array, dimension (N) */
/* be the generalized eigenvalues. If ALPHAI(j) is zero, then */
/* the j-th eigenvalue is real; if positive, then the j-th and */
/* (j+1)-st eigenvalues are a complex conjugate pair, with */
/* ALPHAI(j+1) negative. */
/* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */
/* may easily over- or underflow, and BETA(j) may even be zero. */
/* Thus, the user should avoid naively computing the ratio */
/* ALPHA/BETA. However, ALPHAR and ALPHAI will be always less */
/* than and usually comparable with norm(A) in magnitude, and */
/* BETA always less than and usually comparable with norm(B). */
/* VL (output) DOUBLE PRECISION array, dimension (LDVL,N) */
/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
/* after another in the columns of VL, in the same order as */
/* their eigenvalues. If the j-th eigenvalue is real, then */
/* u(j) = VL(:,j), the j-th column of VL. If the j-th and */
/* (j+1)-th eigenvalues form a complex conjugate pair, then */
/* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1). */
/* Each eigenvector will be scaled so the largest component have */
/* abs(real part) + abs(imag. part) = 1. */
/* Not referenced if JOBVL = 'N'. */
/* LDVL (input) INTEGER */
/* The leading dimension of the matrix VL. LDVL >= 1, and */
/* if JOBVL = 'V', LDVL >= N. */
/* VR (output) DOUBLE PRECISION array, dimension (LDVR,N) */
/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
/* after another in the columns of VR, in the same order as */
/* their eigenvalues. If the j-th eigenvalue is real, then */
/* v(j) = VR(:,j), the j-th column of VR. If the j-th and */
/* (j+1)-th eigenvalues form a complex conjugate pair, then */
/* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1). */
/* Each eigenvector will be scaled so the largest component have */
/* abs(real part) + abs(imag. part) = 1. */
/* Not referenced if JOBVR = 'N'. */
/* LDVR (input) INTEGER */
/* The leading dimension of the matrix VR. LDVR >= 1, and */
/* if JOBVR = 'V', LDVR >= N. */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are integer values such that on exit */
/* A(i,j) = 0 and B(i,j) = 0 if i > j and */
/* If BALANC = 'N' or 'S', ILO = 1 and IHI = N. */
/* LSCALE (output) DOUBLE PRECISION array, dimension (N) */
/* Details of the permutations and scaling factors applied */
/* to the left side of A and B. If PL(j) is the index of the */
/* row interchanged with row j, and DL(j) is the scaling */
/* factor applied to row j, then */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* RSCALE (output) DOUBLE PRECISION array, dimension (N) */
/* Details of the permutations and scaling factors applied */
/* to the right side of A and B. If PR(j) is the index of the */
/* column interchanged with column j, and DR(j) is the scaling */
/* factor applied to column j, then */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* ABNRM (output) DOUBLE PRECISION */
/* The one-norm of the balanced matrix A. */
/* BBNRM (output) DOUBLE PRECISION */
/* The one-norm of the balanced matrix B. */
/* RCONDE (output) DOUBLE PRECISION array, dimension (N) */
/* If SENSE = 'E' or 'B', the reciprocal condition numbers of */
/* the eigenvalues, stored in consecutive elements of the array. */
/* For a complex conjugate pair of eigenvalues two consecutive */
/* elements of RCONDE are set to the same value. Thus RCONDE(j), */
/* RCONDV(j), and the j-th columns of VL and VR all correspond */
/* to the j-th eigenpair. */
/* If SENSE = 'N or 'V', RCONDE is not referenced. */
/* RCONDV (output) DOUBLE PRECISION array, dimension (N) */
/* If SENSE = 'V' or 'B', the estimated reciprocal condition */
/* numbers of the eigenvectors, stored in consecutive elements */
/* of the array. For a complex eigenvector two consecutive */
/* elements of RCONDV are set to the same value. If the */
/* eigenvalues cannot be reordered to compute RCONDV(j), */
/* RCONDV(j) is set to 0; this can only occur when the true */
/* value would be very small anyway. */
/* If SENSE = 'N' or 'E', RCONDV is not referenced. */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,2*N). */
/* If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V', */
/* LWORK >= max(1,6*N). */
/* If SENSE = 'E' or 'B', LWORK >= max(1,10*N). */
/* If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* IWORK (workspace) INTEGER array, dimension (N+6) */
/* If SENSE = 'E', IWORK is not referenced. */
/* BWORK (workspace) LOGICAL array, dimension (N) */
/* If SENSE = 'N', BWORK is not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* The QZ iteration failed. No eigenvectors have been */
/* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) */
/* > N: =N+1: other than QZ iteration failed in DHGEQZ. */
/* =N+2: error return from DTGEVC. */
/* Further Details */
/* =============== */
/* Balancing a matrix pair (A,B) includes, first, permuting rows and */
/* columns to isolate eigenvalues, second, applying diagonal similarity */
/* transformation to the rows and columns to make the rows and columns */
/* as close in norm as possible. The computed reciprocal condition */
/* numbers correspond to the balanced matrix. Permuting rows and columns */
/* will not change the condition numbers (in exact arithmetic) but */
/* diagonal scaling will. For further explanation of balancing, see */
/* section 4.11.1.2 of LAPACK Users' Guide. */
/* An approximate error bound on the chordal distance between the i-th */
/* computed generalized eigenvalue w and the corresponding exact */
/* eigenvalue lambda is */
/* chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I) */
/* An approximate error bound for the angle between the i-th computed */
/* eigenvector VL(i) or VR(i) is given by */
/* EPS * norm(ABNRM, BBNRM) / DIF(i). */
/* For further explanation of the reciprocal condition numbers RCONDE */
/* and RCONDV, see section 4.11 of LAPACK User's Guide. */
/* ===================================================================== */
/* Decode the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--alphar;
--alphai;
--beta;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--lscale;
--rscale;
--rconde;
--rcondv;
--work;
--iwork;
--bwork;
/* Function Body */
if (lsame_(jobvl, "N")) {
ijobvl = 1;
ilvl = FALSE_;
} else if (lsame_(jobvl, "V")) {
ijobvl = 2;
ilvl = TRUE_;
} else {
ijobvl = -1;
ilvl = FALSE_;
}
if (lsame_(jobvr, "N")) {
ijobvr = 1;
ilvr = FALSE_;
} else if (lsame_(jobvr, "V")) {
ijobvr = 2;
ilvr = TRUE_;
} else {
ijobvr = -1;
ilvr = FALSE_;
}
ilv = ilvl || ilvr;
noscl = lsame_(balanc, "N") || lsame_(balanc, "P");
wantsn = lsame_(sense, "N");
wantse = lsame_(sense, "E");
wantsv = lsame_(sense, "V");
wantsb = lsame_(sense, "B");
/* Test the input arguments */
*info = 0;
lquery = *lwork == -1;
if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P")
|| lsame_(balanc, "B"))) {
*info = -1;
} else if (ijobvl <= 0) {
*info = -2;
} else if (ijobvr <= 0) {
*info = -3;
} else if (! (wantsn || wantse || wantsb || wantsv)) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldvl < 1 || ilvl && *ldvl < *n) {
*info = -14;
} else if (*ldvr < 1 || ilvr && *ldvr < *n) {
*info = -16;
}
/* 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. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV. The workspace is */
/* computed assuming ILO = 1 and IHI = N, the worst case.) */
if (*info == 0) {
if (*n == 0) {
minwrk = 1;
maxwrk = 1;
} else {
if (noscl && ! ilv) {
minwrk = *n << 1;
} else {
minwrk = *n * 6;
}
if (wantse || wantsb) {
minwrk = *n * 10;
}
if (wantsv || wantsb) {
/* Computing MAX */
i__1 = minwrk, i__2 = (*n << 1) * (*n + 4) + 16;
minwrk = max(i__1,i__2);
}
maxwrk = minwrk;
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", n, &
c__1, n, &c__0);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DORMQR", " ", n, &
c__1, n, &c__0);
maxwrk = max(i__1,i__2);
if (ilvl) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DORGQR",
" ", n, &c__1, n, &c__0);
maxwrk = max(i__1,i__2);
}
}
work[1] = (doublereal) maxwrk;
if (*lwork < minwrk && ! lquery) {
*info = -26;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGGEVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]);
ilascl = FALSE_;
if (anrm > 0. && anrm < smlnum) {
anrmto = smlnum;
ilascl = TRUE_;
} else if (anrm > bignum) {
anrmto = bignum;
ilascl = TRUE_;
}
if (ilascl) {
dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
ierr);
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]);
ilbscl = FALSE_;
if (bnrm > 0. && bnrm < smlnum) {
bnrmto = smlnum;
ilbscl = TRUE_;
} else if (bnrm > bignum) {
bnrmto = bignum;
ilbscl = TRUE_;
}
if (ilbscl) {
dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
ierr);
}
/* Permute and/or balance the matrix pair (A,B) */
/* (Workspace: need 6*N if BALANC = 'S' or 'B', 1 otherwise) */
dggbal_(balanc, n, &a[a_offset], lda, &b[b_offset], ldb, ilo, ihi, &
lscale[1], &rscale[1], &work[1], &ierr);
/* Compute ABNRM and BBNRM */
*abnrm = dlange_("1", n, n, &a[a_offset], lda, &work[1]);
if (ilascl) {
work[1] = *abnrm;
dlascl_("G", &c__0, &c__0, &anrmto, &anrm, &c__1, &c__1, &work[1], &
c__1, &ierr);
*abnrm = work[1];
}
*bbnrm = dlange_("1", n, n, &b[b_offset], ldb, &work[1]);
if (ilbscl) {
work[1] = *bbnrm;
dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, &c__1, &c__1, &work[1], &
c__1, &ierr);
*bbnrm = work[1];
}
/* Reduce B to triangular form (QR decomposition of B) */
/* (Workspace: need N, prefer N*NB ) */
irows = *ihi + 1 - *ilo;
if (ilv || ! wantsn) {
icols = *n + 1 - *ilo;
} else {
icols = irows;
}
itau = 1;
iwrk = itau + irows;
i__1 = *lwork + 1 - iwrk;
dgeqrf_(&irows, &icols, &b[*ilo + *ilo * b_dim1], ldb, &work[itau], &work[
iwrk], &i__1, &ierr);
/* Apply the orthogonal transformation to A */
/* (Workspace: need N, prefer N*NB) */
i__1 = *lwork + 1 - iwrk;
dormqr_("L", "T", &irows, &icols, &irows, &b[*ilo + *ilo * b_dim1], ldb, &
work[itau], &a[*ilo + *ilo * a_dim1], lda, &work[iwrk], &i__1, &
ierr);
/* Initialize VL and/or VR */
/* (Workspace: need N, prefer N*NB) */
if (ilvl) {
dlaset_("Full", n, n, &c_b59, &c_b60, &vl[vl_offset], ldvl)
;
if (irows > 1) {
i__1 = irows - 1;
i__2 = irows - 1;
dlacpy_("L", &i__1, &i__2, &b[*ilo + 1 + *ilo * b_dim1], ldb, &vl[
*ilo + 1 + *ilo * vl_dim1], ldvl);
}
i__1 = *lwork + 1 - iwrk;
dorgqr_(&irows, &irows, &irows, &vl[*ilo + *ilo * vl_dim1], ldvl, &
work[itau], &work[iwrk], &i__1, &ierr);
}
if (ilvr) {
dlaset_("Full", n, n, &c_b59, &c_b60, &vr[vr_offset], ldvr)
;
}
/* Reduce to generalized Hessenberg form */
/* (Workspace: none needed) */
if (ilv || ! wantsn) {
/* Eigenvectors requested -- work on whole matrix. */
dgghrd_(jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset],
ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr);
} else {
dgghrd_("N", "N", &irows, &c__1, &irows, &a[*ilo + *ilo * a_dim1],
lda, &b[*ilo + *ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[
vr_offset], ldvr, &ierr);
}
/* Perform QZ algorithm (Compute eigenvalues, and optionally, the */
/* Schur forms and Schur vectors) */
/* (Workspace: need N) */
if (ilv || ! wantsn) {
*(unsigned char *)chtemp = 'S';
} else {
*(unsigned char *)chtemp = 'E';
}
dhgeqz_(chtemp, jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset]
, ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset], ldvl, &
vr[vr_offset], ldvr, &work[1], lwork, &ierr);
if (ierr != 0) {
if (ierr > 0 && ierr <= *n) {
*info = ierr;
} else if (ierr > *n && ierr <= *n << 1) {
*info = ierr - *n;
} else {
*info = *n + 1;
}
goto L130;
}
/* Compute Eigenvectors and estimate condition numbers if desired */
/* (Workspace: DTGEVC: need 6*N */
/* DTGSNA: need 2*N*(N+2)+16 if SENSE = 'V' or 'B', */
/* need N otherwise ) */
if (ilv || ! wantsn) {
if (ilv) {
if (ilvl) {
if (ilvr) {
*(unsigned char *)chtemp = 'B';
} else {
*(unsigned char *)chtemp = 'L';
}
} else {
*(unsigned char *)chtemp = 'R';
}
dtgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset],
ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &
work[1], &ierr);
if (ierr != 0) {
*info = *n + 2;
goto L130;
}
}
if (! wantsn) {
/* compute eigenvectors (DTGEVC) and estimate condition */
/* numbers (DTGSNA). Note that the definition of the condition */
/* number is not invariant under transformation (u,v) to */
/* (Q*u, Z*v), where (u,v) are eigenvectors of the generalized */
/* Schur form (S,T), Q and Z are orthogonal matrices. In order */
/* to avoid using extra 2*N*N workspace, we have to recalculate */
/* eigenvectors and estimate one condition numbers at a time. */
pair = FALSE_;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (pair) {
pair = FALSE_;
goto L20;
}
mm = 1;
if (i__ < *n) {
if (a[i__ + 1 + i__ * a_dim1] != 0.) {
pair = TRUE_;
mm = 2;
}
}
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
bwork[j] = FALSE_;
}
if (mm == 1) {
bwork[i__] = TRUE_;
} else if (mm == 2) {
bwork[i__] = TRUE_;
bwork[i__ + 1] = TRUE_;
}
iwrk = mm * *n + 1;
iwrk1 = iwrk + mm * *n;
/* Compute a pair of left and right eigenvectors. */
/* (compute workspace: need up to 4*N + 6*N) */
if (wantse || wantsb) {
dtgevc_("B", "S", &bwork[1], n, &a[a_offset], lda, &b[
b_offset], ldb, &work[1], n, &work[iwrk], n, &mm,
&m, &work[iwrk1], &ierr);
if (ierr != 0) {
*info = *n + 2;
goto L130;
}
}
i__2 = *lwork - iwrk1 + 1;
dtgsna_(sense, "S", &bwork[1], n, &a[a_offset], lda, &b[
b_offset], ldb, &work[1], n, &work[iwrk], n, &rconde[
i__], &rcondv[i__], &mm, &m, &work[iwrk1], &i__2, &
iwork[1], &ierr);
L20:
;
}
}
}
/* Undo balancing on VL and VR and normalization */
/* (Workspace: none needed) */
if (ilvl) {
dggbak_(balanc, "L", n, ilo, ihi, &lscale[1], &rscale[1], n, &vl[
vl_offset], ldvl, &ierr);
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
if (alphai[jc] < 0.) {
goto L70;
}
temp = 0.;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = vl[jr + jc * vl_dim1], abs(
d__1));
temp = max(d__2,d__3);
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__3 = temp, d__4 = (d__1 = vl[jr + jc * vl_dim1], abs(
d__1)) + (d__2 = vl[jr + (jc + 1) * vl_dim1], abs(
d__2));
temp = max(d__3,d__4);
}
}
if (temp < smlnum) {
goto L70;
}
temp = 1. / temp;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vl[jr + jc * vl_dim1] *= temp;
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vl[jr + jc * vl_dim1] *= temp;
vl[jr + (jc + 1) * vl_dim1] *= temp;
}
}
L70:
;
}
}
if (ilvr) {
dggbak_(balanc, "R", n, ilo, ihi, &lscale[1], &rscale[1], n, &vr[
vr_offset], ldvr, &ierr);
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
if (alphai[jc] < 0.) {
goto L120;
}
temp = 0.;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = vr[jr + jc * vr_dim1], abs(
d__1));
temp = max(d__2,d__3);
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__3 = temp, d__4 = (d__1 = vr[jr + jc * vr_dim1], abs(
d__1)) + (d__2 = vr[jr + (jc + 1) * vr_dim1], abs(
d__2));
temp = max(d__3,d__4);
}
}
if (temp < smlnum) {
goto L120;
}
temp = 1. / temp;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vr[jr + jc * vr_dim1] *= temp;
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vr[jr + jc * vr_dim1] *= temp;
vr[jr + (jc + 1) * vr_dim1] *= temp;
}
}
L120:
;
}
}
/* Undo scaling if necessary */
if (ilascl) {
dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, &
ierr);
dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, &
ierr);
}
if (ilbscl) {
dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
ierr);
}
L130:
work[1] = (doublereal) maxwrk;
return 0;
/* End of DGGEVX */
} /* dggevx_ */
/* Subroutine */ int dlasd8_(integer *icompq, integer *k, doublereal *d__,
doublereal *z__, doublereal *vf, doublereal *vl, doublereal *difl,
doublereal *difr, integer *lddifr, doublereal *dsigma, doublereal *
work, integer *info)
{
/* System generated locals */
integer difr_dim1, difr_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
integer i__, j;
doublereal dj, rho;
integer iwk1, iwk2, iwk3;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
doublereal temp;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
integer iwk2i, iwk3i;
doublereal diflj, difrj, dsigj;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
extern doublereal dlamc3_(doublereal *, doublereal *);
extern /* Subroutine */ int dlasd4_(integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *), dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dlaset_(char *, integer *, integer
*, doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *);
doublereal dsigjp;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASD8 finds the square roots of the roots of the secular equation, */
/* as defined by the values in DSIGMA and Z. It makes the appropriate */
/* calls to DLASD4, and stores, for each element in D, the distance */
/* to its two nearest poles (elements in DSIGMA). It also updates */
/* the arrays VF and VL, the first and last components of all the */
/* right singular vectors of the original bidiagonal matrix. */
/* DLASD8 is called from DLASD6. */
/* Arguments */
/* ========= */
/* ICOMPQ (input) INTEGER */
/* Specifies whether singular vectors are to be computed in */
/* factored form in the calling routine: */
/* = 0: Compute singular values only. */
/* = 1: Compute singular vectors in factored form as well. */
/* K (input) INTEGER */
/* The number of terms in the rational function to be solved */
/* by DLASD4. K >= 1. */
/* D (output) DOUBLE PRECISION array, dimension ( K ) */
/* On output, D contains the updated singular values. */
/* Z (input) DOUBLE PRECISION array, dimension ( K ) */
/* The first K elements of this array contain the components */
/* of the deflation-adjusted updating row vector. */
/* VF (input/output) DOUBLE PRECISION array, dimension ( K ) */
/* On entry, VF contains information passed through DBEDE8. */
/* On exit, VF contains the first K components of the first */
/* components of all right singular vectors of the bidiagonal */
/* matrix. */
/* VL (input/output) DOUBLE PRECISION array, dimension ( K ) */
/* On entry, VL contains information passed through DBEDE8. */
/* On exit, VL contains the first K components of the last */
/* components of all right singular vectors of the bidiagonal */
/* matrix. */
/* DIFL (output) DOUBLE PRECISION array, dimension ( K ) */
/* On exit, DIFL(I) = D(I) - DSIGMA(I). */
/* DIFR (output) DOUBLE PRECISION array, */
/* dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and */
/* dimension ( K ) if ICOMPQ = 0. */
/* On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not */
/* defined and will not be referenced. */
/* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the */
/* normalizing factors for the right singular vector matrix. */
/* LDDIFR (input) INTEGER */
/* The leading dimension of DIFR, must be at least K. */
/* DSIGMA (input) DOUBLE PRECISION array, dimension ( K ) */
/* The first K elements of this array contain the old roots */
/* of the deflated updating problem. These are the poles */
/* of the secular equation. */
/* WORK (workspace) DOUBLE PRECISION array, dimension at least 3 * K */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = 1, an singular value did not converge */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Huan Ren, Computer Science Division, University of */
/* California at Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--z__;
--vf;
--vl;
--difl;
difr_dim1 = *lddifr;
difr_offset = 1 + difr_dim1;
difr -= difr_offset;
--dsigma;
--work;
/* Function Body */
*info = 0;
if (*icompq < 0 || *icompq > 1) {
*info = -1;
} else if (*k < 1) {
*info = -2;
} else if (*lddifr < *k) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLASD8", &i__1);
return 0;
}
/* Quick return if possible */
if (*k == 1) {
d__[1] = abs(z__[1]);
difl[1] = d__[1];
if (*icompq == 1) {
difl[2] = 1.;
difr[(difr_dim1 << 1) + 1] = 1.;
}
return 0;
}
/* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can */
/* be computed with high relative accuracy (barring over/underflow). */
/* This is a problem on machines without a guard digit in */
/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */
/* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), */
/* which on any of these machines zeros out the bottommost */
/* bit of DSIGMA(I) if it is 1; this makes the subsequent */
/* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation */
/* occurs. On binary machines with a guard digit (almost all */
/* machines) it does not change DSIGMA(I) at all. On hexadecimal */
/* and decimal machines with a guard digit, it slightly */
/* changes the bottommost bits of DSIGMA(I). It does not account */
/* for hexadecimal or decimal machines without guard digits */
/* (we know of none). We use a subroutine call to compute */
/* 2*DSIGMA(I) to prevent optimizing compilers from eliminating */
/* this code. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
dsigma[i__] = dlamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__];
/* L10: */
}
/* Book keeping. */
iwk1 = 1;
iwk2 = iwk1 + *k;
iwk3 = iwk2 + *k;
iwk2i = iwk2 - 1;
iwk3i = iwk3 - 1;
/* Normalize Z. */
rho = dnrm2_(k, &z__[1], &c__1);
dlascl_("G", &c__0, &c__0, &rho, &c_b8, k, &c__1, &z__[1], k, info);
rho *= rho;
/* Initialize WORK(IWK3). */
dlaset_("A", k, &c__1, &c_b8, &c_b8, &work[iwk3], k);
/* Compute the updated singular values, the arrays DIFL, DIFR, */
/* and the updated Z. */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
dlasd4_(k, &j, &dsigma[1], &z__[1], &work[iwk1], &rho, &d__[j], &work[
iwk2], info);
/* If the root finder fails, the computation is terminated. */
if (*info != 0) {
return 0;
}
work[iwk3i + j] = work[iwk3i + j] * work[j] * work[iwk2i + j];
difl[j] = -work[j];
difr[j + difr_dim1] = -work[j + 1];
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i +
i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[
j]);
/* L20: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i +
i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[
j]);
/* L30: */
}
/* L40: */
}
/* Compute updated Z. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
d__2 = sqrt((d__1 = work[iwk3i + i__], abs(d__1)));
z__[i__] = d_sign(&d__2, &z__[i__]);
/* L50: */
}
/* Update VF and VL. */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
diflj = difl[j];
dj = d__[j];
dsigj = -dsigma[j];
if (j < *k) {
difrj = -difr[j + difr_dim1];
dsigjp = -dsigma[j + 1];
}
work[j] = -z__[j] / diflj / (dsigma[j] + dj);
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigj) - diflj) / (
dsigma[i__] + dj);
/* L60: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigjp) + difrj) /
(dsigma[i__] + dj);
/* L70: */
}
temp = dnrm2_(k, &work[1], &c__1);
work[iwk2i + j] = ddot_(k, &work[1], &c__1, &vf[1], &c__1) / temp;
work[iwk3i + j] = ddot_(k, &work[1], &c__1, &vl[1], &c__1) / temp;
if (*icompq == 1) {
difr[j + (difr_dim1 << 1)] = temp;
}
/* L80: */
}
dcopy_(k, &work[iwk2], &c__1, &vf[1], &c__1);
dcopy_(k, &work[iwk3], &c__1, &vl[1], &c__1);
return 0;
/* End of DLASD8 */
} /* dlasd8_ */
/* Subroutine */ int dchkhs_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
doublereal *a, integer *lda, doublereal *h__, doublereal *t1,
doublereal *t2, doublereal *u, integer *ldu, doublereal *z__,
doublereal *uz, doublereal *wr1, doublereal *wi1, doublereal *wr3,
doublereal *wi3, doublereal *evectl, doublereal *evectr, doublereal *
evecty, doublereal *evectx, doublereal *uu, doublereal *tau,
doublereal *work, integer *nwork, integer *iwork, logical *select,
doublereal *result, integer *info)
{
/* Initialized data */
static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
/* Format strings */
static char fmt_9999[] = "(\002 DCHKHS: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 DCHKHS: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
"i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(\002 DCHKHS: Selected \002,a,\002 Eigenvector"
"s from \002,a,\002 do not match other eigenvectors \002,9x,\002N="
"\002,i6,\002, JTYPE=\002,i6,\002, ISEED=(\002,3(i5,\002,\002),i5,"
"\002)\002)";
/* System generated locals */
integer a_dim1, a_offset, evectl_dim1, evectl_offset, evectr_dim1,
evectr_offset, evectx_dim1, evectx_offset, evecty_dim1,
evecty_offset, h_dim1, h_offset, t1_dim1, t1_offset, t2_dim1,
t2_offset, u_dim1, u_offset, uu_dim1, uu_offset, uz_dim1,
uz_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static doublereal cond;
static integer jcol, nmax;
static doublereal unfl, ovfl, temp1, temp2;
static integer i__, j, k, n;
static logical badnn;
extern /* Subroutine */ int dget10_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *),
dget22_(char *, char *, char *, integer *, doublereal *, integer *
, doublereal *, integer *, doublereal *, doublereal *, doublereal
*, doublereal *), dgemm_(char *, char *,
integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *);
static logical match;
static integer imode;
static doublereal dumma[6];
static integer iinfo, nselc;
static doublereal conds;
extern /* Subroutine */ int dhst01_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *);
static doublereal aninv, anorm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer nmats, nselr, jsize, nerrs, itype, jtype, ntest, n1;
static doublereal rtulp;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
static integer jj, in;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dgehrd_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *);
static char adumma[1*1];
extern /* Subroutine */ int dlatme_(integer *, char *, integer *,
doublereal *, integer *, doublereal *, doublereal *, char *, char
*, char *, char *, doublereal *, integer *, doublereal *, integer
*, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *), dhsein_(char
*, char *, char *, logical *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
integer *, integer *, integer *, doublereal *, integer *,
integer *, integer *);
static integer idumma[1];
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *);
static integer ioldsd[4];
extern /* Subroutine */ int dlafts_(char *, integer *, integer *, integer
*, integer *, doublereal *, integer *, doublereal *, integer *,
integer *), dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
dlasum_(char *, integer *, integer *, integer *), dhseqr_(
char *, char *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *), dlatmr_(
integer *, integer *, char *, integer *, char *, doublereal *,
integer *, doublereal *, doublereal *, char *, char *, doublereal
*, integer *, doublereal *, doublereal *, integer *, doublereal *,
char *, integer *, integer *, integer *, doublereal *,
doublereal *, char *, doublereal *, integer *, integer *, integer
*), dlatms_(
integer *, integer *, char *, integer *, char *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *, char
*, doublereal *, integer *, doublereal *, integer *), dorghr_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), dormhr_(char *, char *, integer *, integer *, integer
*, integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *),
dtrevc_(char *, char *, logical *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *, integer *, doublereal *, integer *),
xerbla_(char *, integer *);
static doublereal rtunfl, rtovfl, rtulpi, ulpinv;
static integer mtypes, ntestt, ihi, ilo;
static doublereal ulp;
/* Fortran I/O blocks */
static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___60 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___61 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___62 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___63 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___64 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___65 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___66 = { 0, 0, 0, fmt_9999, 0 };
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define h___ref(a_1,a_2) h__[(a_2)*h_dim1 + a_1]
#define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1]
#define uu_ref(a_1,a_2) uu[(a_2)*uu_dim1 + a_1]
#define evectl_ref(a_1,a_2) evectl[(a_2)*evectl_dim1 + a_1]
#define evectr_ref(a_1,a_2) evectr[(a_2)*evectr_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
October 31, 1999
Purpose
=======
DCHKHS checks the nonsymmetric eigenvalue problem routines.
DGEHRD factors A as U H U' , where ' means transpose,
H is hessenberg, and U is an orthogonal matrix.
DORGHR generates the orthogonal matrix U.
DORMHR multiplies a matrix by the orthogonal matrix U.
DHSEQR factors H as Z T Z' , where Z is orthogonal and
T is "quasi-triangular", and the eigenvalue vector W.
DTREVC computes the left and right eigenvector matrices
L and R for T.
DHSEIN computes the left and right eigenvector matrices
Y and X for H, using inverse iteration.
When DCHKHS is called, a number of matrix "sizes" ("n's") and a
number of matrix "types" are specified. For each size ("n")
and each type of matrix, one matrix will be generated and used
to test the nonsymmetric eigenroutines. For each matrix, 14
tests will be performed:
(1) | A - U H U**T | / ( |A| n ulp )
(2) | I - UU**T | / ( n ulp )
(3) | H - Z T Z**T | / ( |H| n ulp )
(4) | I - ZZ**T | / ( n ulp )
(5) | A - UZ H (UZ)**T | / ( |A| n ulp )
(6) | I - UZ (UZ)**T | / ( n ulp )
(7) | T(Z computed) - T(Z not computed) | / ( |T| ulp )
(8) | W(Z computed) - W(Z not computed) | / ( |W| ulp )
(9) | TR - RW | / ( |T| |R| ulp )
(10) | L**H T - W**H L | / ( |T| |L| ulp )
(11) | HX - XW | / ( |H| |X| ulp )
(12) | Y**H H - W**H Y | / ( |H| |Y| ulp )
(13) | AX - XW | / ( |A| |X| ulp )
(14) | Y**H A - W**H Y | / ( |A| |Y| ulp )
The "sizes" are specified by an array NN(1:NSIZES); the value of
each element NN(j) specifies one size.
The "types" are specified by a logical array DOTYPE( 1:NTYPES );
if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
Currently, the list of possible types is:
(1) The zero matrix.
(2) The identity matrix.
(3) A (transposed) Jordan block, with 1's on the diagonal.
(4) A diagonal matrix with evenly spaced entries
1, ..., ULP and random signs.
(ULP = (first number larger than 1) - 1 )
(5) A diagonal matrix with geometrically spaced entries
1, ..., ULP and random signs.
(6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
and random signs.
(7) Same as (4), but multiplied by SQRT( overflow threshold )
(8) Same as (4), but multiplied by SQRT( underflow threshold )
(9) A matrix of the form U' T U, where U is orthogonal and
T has evenly spaced entries 1, ..., ULP with random signs
on the diagonal and random O(1) entries in the upper
triangle.
(10) A matrix of the form U' T U, where U is orthogonal and
T has geometrically spaced entries 1, ..., ULP with random
signs on the diagonal and random O(1) entries in the upper
triangle.
(11) A matrix of the form U' T U, where U is orthogonal and
T has "clustered" entries 1, ULP,..., ULP with random
signs on the diagonal and random O(1) entries in the upper
triangle.
(12) A matrix of the form U' T U, where U is orthogonal and
T has real or complex conjugate paired eigenvalues randomly
chosen from ( ULP, 1 ) and random O(1) entries in the upper
triangle.
(13) A matrix of the form X' T X, where X has condition
SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
with random signs on the diagonal and random O(1) entries
in the upper triangle.
(14) A matrix of the form X' T X, where X has condition
SQRT( ULP ) and T has geometrically spaced entries
1, ..., ULP with random signs on the diagonal and random
O(1) entries in the upper triangle.
(15) A matrix of the form X' T X, where X has condition
SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
with random signs on the diagonal and random O(1) entries
in the upper triangle.
(16) A matrix of the form X' T X, where X has condition
SQRT( ULP ) and T has real or complex conjugate paired
eigenvalues randomly chosen from ( ULP, 1 ) and random
O(1) entries in the upper triangle.
(17) Same as (16), but multiplied by SQRT( overflow threshold )
(18) Same as (16), but multiplied by SQRT( underflow threshold )
(19) Nonsymmetric matrix with random entries chosen from (-1,1).
(20) Same as (19), but multiplied by SQRT( overflow threshold )
(21) Same as (19), but multiplied by SQRT( underflow threshold )
Arguments
==========
NSIZES - INTEGER
The number of sizes of matrices to use. If it is zero,
DCHKHS does nothing. It must be at least zero.
Not modified.
NN - INTEGER array, dimension (NSIZES)
An array containing the sizes to be used for the matrices.
Zero values will be skipped. The values must be at least
zero.
Not modified.
NTYPES - INTEGER
The number of elements in DOTYPE. If it is zero, DCHKHS
does nothing. It must be at least zero. If it is MAXTYP+1
and NSIZES is 1, then an additional type, MAXTYP+1 is
defined, which is to use whatever matrix is in A. This
is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
DOTYPE(MAXTYP+1) is .TRUE. .
Not modified.
DOTYPE - LOGICAL array, dimension (NTYPES)
If DOTYPE(j) is .TRUE., then for each size in NN a
matrix of that size and of type j will be generated.
If NTYPES is smaller than the maximum number of types
defined (PARAMETER MAXTYP), then types NTYPES+1 through
MAXTYP will not be generated. If NTYPES is larger
than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
will be ignored.
Not modified.
ISEED - INTEGER array, dimension (4)
On entry ISEED specifies the seed of the random number
generator. The array elements should be between 0 and 4095;
if not they will be reduced mod 4096. Also, ISEED(4) must
be odd. The random number generator uses a linear
congruential sequence limited to small integers, and so
should produce machine independent random numbers. The
values of ISEED are changed on exit, and can be used in the
next call to DCHKHS to continue the same random number
sequence.
Modified.
THRESH - DOUBLE PRECISION
A test will count as "failed" if the "error", computed as
described above, exceeds THRESH. Note that the error
is scaled to be O(1), so THRESH should be a reasonably
small multiple of 1, e.g., 10 or 100. In particular,
it should not depend on the precision (single vs. double)
or the size of the matrix. It must be at least zero.
Not modified.
NOUNIT - INTEGER
The FORTRAN unit number for printing out error messages
(e.g., if a routine returns IINFO not equal to 0.)
Not modified.
A - DOUBLE PRECISION array, dimension (LDA,max(NN))
Used to hold the matrix whose eigenvalues are to be
computed. On exit, A contains the last matrix actually
used.
Modified.
LDA - INTEGER
The leading dimension of A, H, T1 and T2. It must be at
least 1 and at least max( NN ).
Not modified.
H - DOUBLE PRECISION array, dimension (LDA,max(NN))
The upper hessenberg matrix computed by DGEHRD. On exit,
H contains the Hessenberg form of the matrix in A.
Modified.
T1 - DOUBLE PRECISION array, dimension (LDA,max(NN))
The Schur (="quasi-triangular") matrix computed by DHSEQR
if Z is computed. On exit, T1 contains the Schur form of
the matrix in A.
Modified.
T2 - DOUBLE PRECISION array, dimension (LDA,max(NN))
The Schur matrix computed by DHSEQR when Z is not computed.
This should be identical to T1.
Modified.
LDU - INTEGER
The leading dimension of U, Z, UZ and UU. It must be at
least 1 and at least max( NN ).
Not modified.
U - DOUBLE PRECISION array, dimension (LDU,max(NN))
The orthogonal matrix computed by DGEHRD.
Modified.
Z - DOUBLE PRECISION array, dimension (LDU,max(NN))
The orthogonal matrix computed by DHSEQR.
Modified.
UZ - DOUBLE PRECISION array, dimension (LDU,max(NN))
The product of U times Z.
Modified.
WR1 - DOUBLE PRECISION array, dimension (max(NN))
WI1 - DOUBLE PRECISION array, dimension (max(NN))
The real and imaginary parts of the eigenvalues of A,
as computed when Z is computed.
On exit, WR1 + WI1*i are the eigenvalues of the matrix in A.
Modified.
WR3 - DOUBLE PRECISION array, dimension (max(NN))
WI3 - DOUBLE PRECISION array, dimension (max(NN))
Like WR1, WI1, these arrays contain the eigenvalues of A,
but those computed when DHSEQR only computes the
eigenvalues, i.e., not the Schur vectors and no more of the
Schur form than is necessary for computing the
eigenvalues.
Modified.
EVECTL - DOUBLE PRECISION array, dimension (LDU,max(NN))
The (upper triangular) left eigenvector matrix for the
matrix in T1. For complex conjugate pairs, the real part
is stored in one row and the imaginary part in the next.
Modified.
EVEZTR - DOUBLE PRECISION array, dimension (LDU,max(NN))
The (upper triangular) right eigenvector matrix for the
matrix in T1. For complex conjugate pairs, the real part
is stored in one column and the imaginary part in the next.
Modified.
EVECTY - DOUBLE PRECISION array, dimension (LDU,max(NN))
The left eigenvector matrix for the
matrix in H. For complex conjugate pairs, the real part
is stored in one row and the imaginary part in the next.
Modified.
EVECTX - DOUBLE PRECISION array, dimension (LDU,max(NN))
The right eigenvector matrix for the
matrix in H. For complex conjugate pairs, the real part
is stored in one column and the imaginary part in the next.
Modified.
UU - DOUBLE PRECISION array, dimension (LDU,max(NN))
Details of the orthogonal matrix computed by DGEHRD.
Modified.
TAU - DOUBLE PRECISION array, dimension(max(NN))
Further details of the orthogonal matrix computed by DGEHRD.
Modified.
WORK - DOUBLE PRECISION array, dimension (NWORK)
Workspace.
Modified.
NWORK - INTEGER
The number of entries in WORK. NWORK >= 4*NN(j)*NN(j) + 2.
IWORK - INTEGER array, dimension (max(NN))
Workspace.
Modified.
SELECT - LOGICAL array, dimension (max(NN))
Workspace.
Modified.
RESULT - DOUBLE PRECISION array, dimension (14)
The values computed by the fourteen tests described above.
The values are currently limited to 1/ulp, to avoid
overflow.
Modified.
INFO - INTEGER
If 0, then everything ran OK.
-1: NSIZES < 0
-2: Some NN(j) < 0
-3: NTYPES < 0
-6: THRESH < 0
-9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
-14: LDU < 1 or LDU < NMAX.
-28: NWORK too small.
If DLATMR, SLATMS, or SLATME returns an error code, the
absolute value of it is returned.
If 1, then DHSEQR could not find all the shifts.
If 2, then the EISPACK code (for small blocks) failed.
If >2, then 30*N iterations were not enough to find an
eigenvalue or to decompose the problem.
Modified.
-----------------------------------------------------------------------
Some Local Variables and Parameters:
---- ----- --------- --- ----------
ZERO, ONE Real 0 and 1.
MAXTYP The number of types defined.
MTEST The number of tests defined: care must be taken
that (1) the size of RESULT, (2) the number of
tests actually performed, and (3) MTEST agree.
NTEST The number of tests performed on this matrix
so far. This should be less than MTEST, and
equal to it by the last test. It will be less
if any of the routines being tested indicates
that it could not compute the matrices that
would be tested.
NMAX Largest value in NN.
NMATS The number of matrices generated so far.
NERRS The number of tests which have exceeded THRESH
so far (computed by DLAFTS).
COND, CONDS,
IMODE Values to be passed to the matrix generators.
ANORM Norm of A; passed to matrix generators.
OVFL, UNFL Overflow and underflow thresholds.
ULP, ULPINV Finest relative precision and its inverse.
RTOVFL, RTUNFL,
RTULP, RTULPI Square roots of the previous 4 values.
The following four arrays decode JTYPE:
KTYPE(j) The general type (1-10) for type "j".
KMODE(j) The MODE value to be passed to the matrix
generator for type "j".
KMAGN(j) The order of magnitude ( O(1),
O(overflow^(1/2) ), O(underflow^(1/2) )
KCONDS(j) Selects whether CONDS is to be 1 or
1/sqrt(ulp). (0 means irrelevant.)
=====================================================================
Parameter adjustments */
--nn;
--dotype;
--iseed;
t2_dim1 = *lda;
t2_offset = 1 + t2_dim1 * 1;
t2 -= t2_offset;
t1_dim1 = *lda;
t1_offset = 1 + t1_dim1 * 1;
t1 -= t1_offset;
h_dim1 = *lda;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
uu_dim1 = *ldu;
uu_offset = 1 + uu_dim1 * 1;
uu -= uu_offset;
evectx_dim1 = *ldu;
evectx_offset = 1 + evectx_dim1 * 1;
evectx -= evectx_offset;
evecty_dim1 = *ldu;
evecty_offset = 1 + evecty_dim1 * 1;
evecty -= evecty_offset;
evectr_dim1 = *ldu;
evectr_offset = 1 + evectr_dim1 * 1;
evectr -= evectr_offset;
evectl_dim1 = *ldu;
evectl_offset = 1 + evectl_dim1 * 1;
evectl -= evectl_offset;
uz_dim1 = *ldu;
uz_offset = 1 + uz_dim1 * 1;
uz -= uz_offset;
z_dim1 = *ldu;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
--wr1;
--wi1;
--wr3;
--wi3;
--tau;
--work;
--iwork;
--select;
--result;
/* Function Body
Check for errors */
ntestt = 0;
*info = 0;
badnn = FALSE_;
nmax = 0;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -9;
} else if (*ldu <= 1 || *ldu < nmax) {
*info = -14;
} else if ((nmax << 2) * nmax + 2 > *nwork) {
*info = -28;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DCHKHS", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
/* More important constants */
unfl = dlamch_("Safe minimum");
ovfl = dlamch_("Overflow");
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Epsilon") * dlamch_("Base");
ulpinv = 1. / ulp;
rtunfl = sqrt(unfl);
rtovfl = sqrt(ovfl);
rtulp = sqrt(ulp);
rtulpi = 1. / rtulp;
/* Loop over sizes, types */
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
if (n == 0) {
goto L270;
}
n1 = max(1,n);
aninv = 1. / (doublereal) n1;
if (*nsizes != 1) {
mtypes = min(21,*ntypes);
} else {
mtypes = min(22,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L260;
}
++nmats;
ntest = 0;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Initialize RESULT */
for (j = 1; j <= 14; ++j) {
result[j] = 0.;
/* L30: */
}
/* Compute "A"
Control parameters:
KMAGN KCONDS KMODE KTYPE
=1 O(1) 1 clustered 1 zero
=2 large large clustered 2 identity
=3 small exponential Jordan
=4 arithmetic diagonal, (w/ eigenvalues)
=5 random log symmetric, w/ eigenvalues
=6 random general, w/ eigenvalues
=7 random diagonal
=8 random symmetric
=9 random general
=10 random triangular */
if (mtypes > 21) {
goto L100;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L40;
case 2: goto L50;
case 3: goto L60;
}
L40:
anorm = 1.;
goto L70;
L50:
anorm = rtovfl * ulp * aninv;
goto L70;
L60:
anorm = rtunfl * n * ulpinv;
goto L70;
L70:
dlaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
/* Special Matrices */
if (itype == 1) {
/* Zero */
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
a_ref(jcol, jcol) = anorm;
/* L80: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
a_ref(jcol, jcol) = anorm;
if (jcol > 1) {
a_ref(jcol, jcol - 1) = 1.;
}
/* L90: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
&anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ 1], &iinfo);
} else if (itype == 5) {
/* Symmetric, eigenvalues specified */
dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
&anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
&iinfo);
} else if (itype == 6) {
/* General, eigenvalues specified */
if (kconds[jtype - 1] == 1) {
conds = 1.;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.;
}
*(unsigned char *)&adumma[0] = ' ';
dlatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b32,
adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
&iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &c__0, &
c__0, &c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 8) {
/* Symmetric, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 10) {
/* Triangular, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &c__0, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___36.ciunit = *nounit;
s_wsfe(&io___36);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L100:
/* Call DGEHRD to compute H and U, do tests. */
dlacpy_(" ", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
ntest = 1;
ilo = 1;
ihi = n;
i__3 = *nwork - n;
dgehrd_(&n, &ilo, &ihi, &h__[h_offset], lda, &work[1], &work[n +
1], &i__3, &iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___39.ciunit = *nounit;
s_wsfe(&io___39);
do_fio(&c__1, "DGEHRD", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L250;
}
i__3 = n - 1;
for (j = 1; j <= i__3; ++j) {
uu_ref(j + 1, j) = 0.;
i__4 = n;
for (i__ = j + 2; i__ <= i__4; ++i__) {
u_ref(i__, j) = h___ref(i__, j);
uu_ref(i__, j) = h___ref(i__, j);
h___ref(i__, j) = 0.;
/* L110: */
}
/* L120: */
}
dcopy_(&n, &work[1], &c__1, &tau[1], &c__1);
i__3 = *nwork - n;
dorghr_(&n, &ilo, &ihi, &u[u_offset], ldu, &work[1], &work[n + 1],
&i__3, &iinfo);
ntest = 2;
dhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &h__[h_offset], lda, &
u[u_offset], ldu, &work[1], nwork, &result[1]);
/* Call DHSEQR to compute T1, T2 and Z, do tests.
Eigenvalues only (WR3,WI3) */
dlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
ntest = 3;
result[3] = ulpinv;
dhseqr_("E", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &wr3[1], &
wi3[1], &uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, "DHSEQR(E)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
if (iinfo <= n + 2) {
*info = abs(iinfo);
goto L250;
}
}
/* Eigenvalues (WR1,WI1) and Full Schur Form (T2) */
dlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
dhseqr_("S", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &wr1[1], &
wi1[1], &uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0 && iinfo <= n + 2) {
io___42.ciunit = *nounit;
s_wsfe(&io___42);
do_fio(&c__1, "DHSEQR(S)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L250;
}
/* Eigenvalues (WR1,WI1), Schur Form (T1), and Schur vectors
(UZ) */
dlacpy_(" ", &n, &n, &h__[h_offset], lda, &t1[t1_offset], lda);
dlacpy_(" ", &n, &n, &u[u_offset], ldu, &uz[uz_offset], lda);
dhseqr_("S", "V", &n, &ilo, &ihi, &t1[t1_offset], lda, &wr1[1], &
wi1[1], &uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0 && iinfo <= n + 2) {
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, "DHSEQR(V)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L250;
}
/* Compute Z = U' UZ */
dgemm_("T", "N", &n, &n, &n, &c_b32, &u[u_offset], ldu, &uz[
uz_offset], ldu, &c_b18, &z__[z_offset], ldu);
ntest = 8;
/* Do Tests 3: | H - Z T Z' | / ( |H| n ulp )
and 4: | I - Z Z' | / ( n ulp ) */
dhst01_(&n, &ilo, &ihi, &h__[h_offset], lda, &t1[t1_offset], lda,
&z__[z_offset], ldu, &work[1], nwork, &result[3]);
/* Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp )
and 6: | I - UZ (UZ)' | / ( n ulp ) */
dhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &t1[t1_offset], lda, &
uz[uz_offset], ldu, &work[1], nwork, &result[5]);
/* Do Test 7: | T2 - T1 | / ( |T| n ulp ) */
dget10_(&n, &n, &t2[t2_offset], lda, &t1[t1_offset], lda, &work[1]
, &result[7]);
/* Do Test 8: | W3 - W1 | / ( max(|W1|,|W3|) ulp ) */
temp1 = 0.;
temp2 = 0.;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
/* Computing MAX */
d__5 = temp1, d__6 = (d__1 = wr1[j], abs(d__1)) + (d__2 = wi1[
j], abs(d__2)), d__5 = max(d__5,d__6), d__6 = (d__3 =
wr3[j], abs(d__3)) + (d__4 = wi3[j], abs(d__4));
temp1 = max(d__5,d__6);
/* Computing MAX */
d__3 = temp2, d__4 = (d__1 = wr1[j] - wr3[j], abs(d__1)) + (
d__2 = wr1[j] - wr3[j], abs(d__2));
temp2 = max(d__3,d__4);
/* L130: */
}
/* Computing MAX */
d__1 = unfl, d__2 = ulp * max(temp1,temp2);
result[8] = temp2 / max(d__1,d__2);
/* Compute the Left and Right Eigenvectors of T
Compute the Right eigenvector Matrix: */
ntest = 9;
result[9] = ulpinv;
/* Select last max(N/4,1) real, max(N/4,1) complex eigenvectors */
nselc = 0;
nselr = 0;
j = n;
L140:
if (wi1[j] == 0.) {
/* Computing MAX */
i__3 = n / 4;
if (nselr < max(i__3,1)) {
++nselr;
select[j] = TRUE_;
} else {
select[j] = FALSE_;
}
--j;
} else {
/* Computing MAX */
i__3 = n / 4;
if (nselc < max(i__3,1)) {
++nselc;
select[j] = TRUE_;
select[j - 1] = FALSE_;
} else {
select[j] = FALSE_;
select[j - 1] = FALSE_;
}
j += -2;
}
if (j > 0) {
goto L140;
}
dtrevc_("Right", "All", &select[1], &n, &t1[t1_offset], lda,
dumma, ldu, &evectr[evectr_offset], ldu, &n, &in, &work[1]
, &iinfo);
if (iinfo != 0) {
io___50.ciunit = *nounit;
s_wsfe(&io___50);
do_fio(&c__1, "DTREVC(R,A)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L250;
}
/* Test 9: | TR - RW | / ( |T| |R| ulp ) */
dget22_("N", "N", "N", &n, &t1[t1_offset], lda, &evectr[
evectr_offset], ldu, &wr1[1], &wi1[1], &work[1], dumma);
result[9] = dumma[0];
if (dumma[1] > *thresh) {
io___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "DTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute selected right eigenvectors and confirm that
they agree with previous right eigenvectors */
dtrevc_("Right", "Some", &select[1], &n, &t1[t1_offset], lda,
dumma, ldu, &evectl[evectl_offset], ldu, &n, &in, &work[1]
, &iinfo);
if (iinfo != 0) {
io___52.ciunit = *nounit;
s_wsfe(&io___52);
do_fio(&c__1, "DTREVC(R,S)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L250;
}
k = 1;
match = TRUE_;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
if (select[j] && wi1[j] == 0.) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
if (evectr_ref(jj, j) != evectl_ref(jj, k)) {
match = FALSE_;
goto L180;
}
/* L150: */
}
++k;
} else if (select[j] && wi1[j] != 0.) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
if (evectr_ref(jj, j) != evectl_ref(jj, k) ||
evectr_ref(jj, j + 1) != evectl_ref(jj, k + 1)
) {
match = FALSE_;
goto L180;
}
/* L160: */
}
k += 2;
}
/* L170: */
}
L180:
if (! match) {
io___56.ciunit = *nounit;
s_wsfe(&io___56);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "DTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute the Left eigenvector Matrix: */
ntest = 10;
result[10] = ulpinv;
dtrevc_("Left", "All", &select[1], &n, &t1[t1_offset], lda, &
evectl[evectl_offset], ldu, dumma, ldu, &n, &in, &work[1],
&iinfo);
if (iinfo != 0) {
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, "DTREVC(L,A)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L250;
}
/* Test 10: | LT - WL | / ( |T| |L| ulp ) */
dget22_("Trans", "N", "Conj", &n, &t1[t1_offset], lda, &evectl[
evectl_offset], ldu, &wr1[1], &wi1[1], &work[1], &dumma[2]
);
result[10] = dumma[2];
if (dumma[3] > *thresh) {
io___58.ciunit = *nounit;
s_wsfe(&io___58);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "DTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute selected left eigenvectors and confirm that
they agree with previous left eigenvectors */
dtrevc_("Left", "Some", &select[1], &n, &t1[t1_offset], lda, &
evectr[evectr_offset], ldu, dumma, ldu, &n, &in, &work[1],
&iinfo);
if (iinfo != 0) {
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, "DTREVC(L,S)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L250;
}
k = 1;
match = TRUE_;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
if (select[j] && wi1[j] == 0.) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
if (evectl_ref(jj, j) != evectr_ref(jj, k)) {
match = FALSE_;
goto L220;
}
/* L190: */
}
++k;
} else if (select[j] && wi1[j] != 0.) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
if (evectl_ref(jj, j) != evectr_ref(jj, k) ||
evectl_ref(jj, j + 1) != evectr_ref(jj, k + 1)
) {
match = FALSE_;
goto L220;
}
/* L200: */
}
k += 2;
}
/* L210: */
}
L220:
if (! match) {
io___60.ciunit = *nounit;
s_wsfe(&io___60);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "DTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Call DHSEIN for Right eigenvectors of H, do test 11 */
ntest = 11;
result[11] = ulpinv;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
select[j] = TRUE_;
/* L230: */
}
dhsein_("Right", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
lda, &wr3[1], &wi3[1], dumma, ldu, &evectx[evectx_offset],
ldu, &n1, &in, &work[1], &iwork[1], &iwork[1], &iinfo);
if (iinfo != 0) {
io___61.ciunit = *nounit;
s_wsfe(&io___61);
do_fio(&c__1, "DHSEIN(R)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L250;
}
} else {
/* Test 11: | HX - XW | / ( |H| |X| ulp )
(from inverse iteration) */
dget22_("N", "N", "N", &n, &h__[h_offset], lda, &evectx[
evectx_offset], ldu, &wr3[1], &wi3[1], &work[1],
dumma);
if (dumma[0] < ulpinv) {
result[11] = dumma[0] * aninv;
}
if (dumma[1] > *thresh) {
io___62.ciunit = *nounit;
s_wsfe(&io___62);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "DHSEIN", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
}
}
/* Call DHSEIN for Left eigenvectors of H, do test 12 */
ntest = 12;
result[12] = ulpinv;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
select[j] = TRUE_;
/* L240: */
}
dhsein_("Left", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
lda, &wr3[1], &wi3[1], &evecty[evecty_offset], ldu, dumma,
ldu, &n1, &in, &work[1], &iwork[1], &iwork[1], &iinfo);
if (iinfo != 0) {
io___63.ciunit = *nounit;
s_wsfe(&io___63);
do_fio(&c__1, "DHSEIN(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L250;
}
} else {
/* Test 12: | YH - WY | / ( |H| |Y| ulp )
(from inverse iteration) */
dget22_("C", "N", "C", &n, &h__[h_offset], lda, &evecty[
evecty_offset], ldu, &wr3[1], &wi3[1], &work[1], &
dumma[2]);
if (dumma[2] < ulpinv) {
result[12] = dumma[2] * aninv;
}
if (dumma[3] > *thresh) {
io___64.ciunit = *nounit;
s_wsfe(&io___64);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "DHSEIN", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
}
}
/* Call DORMHR for Right eigenvectors of A, do test 13 */
ntest = 13;
result[13] = ulpinv;
dormhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
, ldu, &tau[1], &evectx[evectx_offset], ldu, &work[1],
nwork, &iinfo);
if (iinfo != 0) {
io___65.ciunit = *nounit;
s_wsfe(&io___65);
do_fio(&c__1, "DORMHR(R)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L250;
}
} else {
/* Test 13: | AX - XW | / ( |A| |X| ulp )
(from inverse iteration) */
dget22_("N", "N", "N", &n, &a[a_offset], lda, &evectx[
evectx_offset], ldu, &wr3[1], &wi3[1], &work[1],
dumma);
if (dumma[0] < ulpinv) {
result[13] = dumma[0] * aninv;
}
}
/* Call DORMHR for Left eigenvectors of A, do test 14 */
ntest = 14;
result[14] = ulpinv;
dormhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
, ldu, &tau[1], &evecty[evecty_offset], ldu, &work[1],
nwork, &iinfo);
if (iinfo != 0) {
io___66.ciunit = *nounit;
s_wsfe(&io___66);
do_fio(&c__1, "DORMHR(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L250;
}
} else {
/* Test 14: | YA - WY | / ( |A| |Y| ulp )
(from inverse iteration) */
dget22_("C", "N", "C", &n, &a[a_offset], lda, &evecty[
evecty_offset], ldu, &wr3[1], &wi3[1], &work[1], &
dumma[2]);
if (dumma[2] < ulpinv) {
result[14] = dumma[2] * aninv;
}
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L250:
ntestt += ntest;
dlafts_("DHS", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh,
nounit, &nerrs);
L260:
;
}
L270:
;
}
/* Summary */
dlasum_("DHS", nounit, &nerrs, &ntestt);
return 0;
/* End of DCHKHS */
} /* dchkhs_ */
/* Subroutine */ int dgegv_(char *jobvl, char *jobvr, integer *n, doublereal *
a, integer *lda, doublereal *b, integer *ldb, doublereal *alphar,
doublereal *alphai, doublereal *beta, doublereal *vl, integer *ldvl,
doublereal *vr, integer *ldvr, doublereal *work, integer *lwork,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
vr_offset, i__1, i__2;
doublereal d__1, d__2, d__3, d__4;
/* Local variables */
integer jc, nb, in, jr, nb1, nb2, nb3, ihi, ilo;
doublereal eps;
logical ilv;
doublereal absb, anrm, bnrm;
integer itau;
doublereal temp;
logical ilvl, ilvr;
integer lopt;
doublereal anrm1, anrm2, bnrm1, bnrm2, absai, scale, absar, sbeta;
integer ileft, iinfo, icols, iwork, irows;
doublereal salfai;
doublereal salfar;
doublereal safmin;
doublereal safmax;
char chtemp[1];
logical ldumma[1];
integer ijobvl, iright;
logical ilimit;
integer ijobvr;
doublereal onepls;
integer lwkmin;
integer lwkopt;
logical lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* This routine is deprecated and has been replaced by routine DGGEV. */
/* DGEGV computes the eigenvalues and, optionally, the left and/or right */
/* eigenvectors of a real matrix pair (A,B). */
/* Given two square matrices A and B, */
/* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the */
/* eigenvalues lambda and corresponding (non-zero) eigenvectors x such */
/* that */
/* A*x = lambda*B*x. */
/* An alternate form is to find the eigenvalues mu and corresponding */
/* eigenvectors y such that */
/* mu*A*y = B*y. */
/* These two forms are equivalent with mu = 1/lambda and x = y if */
/* neither lambda nor mu is zero. In order to deal with the case that */
/* lambda or mu is zero or small, two values alpha and beta are returned */
/* for each eigenvalue, such that lambda = alpha/beta and */
/* mu = beta/alpha. */
/* The vectors x and y in the above equations are right eigenvectors of */
/* the matrix pair (A,B). Vectors u and v satisfying */
/* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B */
/* are left eigenvectors of (A,B). */
/* Note: this routine performs "full balancing" on A and B -- see */
/* "Further Details", below. */
/* Arguments */
/* ========= */
/* JOBVL (input) CHARACTER*1 */
/* = 'N': do not compute the left generalized eigenvectors; */
/* = 'V': compute the left generalized eigenvectors (returned */
/* in VL). */
/* JOBVR (input) CHARACTER*1 */
/* = 'N': do not compute the right generalized eigenvectors; */
/* = 'V': compute the right generalized eigenvectors (returned */
/* in VR). */
/* N (input) INTEGER */
/* The order of the matrices A, B, VL, and VR. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
/* On entry, the matrix A. */
/* If JOBVL = 'V' or JOBVR = 'V', then on exit A */
/* contains the real Schur form of A from the generalized Schur */
/* factorization of the pair (A,B) after balancing. */
/* If no eigenvectors were computed, then only the diagonal */
/* blocks from the Schur form will be correct. See DGGHRD and */
/* DHGEQZ for details. */
/* LDA (input) INTEGER */
/* The leading dimension of A. LDA >= max(1,N). */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */
/* On entry, the matrix B. */
/* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the */
/* upper triangular matrix obtained from B in the generalized */
/* Schur factorization of the pair (A,B) after balancing. */
/* If no eigenvectors were computed, then only those elements of */
/* B corresponding to the diagonal blocks from the Schur form of */
/* A will be correct. See DGGHRD and DHGEQZ for details. */
/* LDB (input) INTEGER */
/* The leading dimension of B. LDB >= max(1,N). */
/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */
/* The real parts of each scalar alpha defining an eigenvalue of */
/* GNEP. */
/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */
/* The imaginary parts of each scalar alpha defining an */
/* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th */
/* eigenvalue is real; if positive, then the j-th and */
/* (j+1)-st eigenvalues are a complex conjugate pair, with */
/* ALPHAI(j+1) = -ALPHAI(j). */
/* BETA (output) DOUBLE PRECISION array, dimension (N) */
/* The scalars beta that define the eigenvalues of GNEP. */
/* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and */
/* beta = BETA(j) represent the j-th eigenvalue of the matrix */
/* pair (A,B), in one of the forms lambda = alpha/beta or */
/* mu = beta/alpha. Since either lambda or mu may overflow, */
/* they should not, in general, be computed. */
/* VL (output) DOUBLE PRECISION array, dimension (LDVL,N) */
/* If JOBVL = 'V', the left eigenvectors u(j) are stored */
/* in the columns of VL, in the same order as their eigenvalues. */
/* If the j-th eigenvalue is real, then u(j) = VL(:,j). */
/* If the j-th and (j+1)-st eigenvalues form a complex conjugate */
/* pair, then */
/* u(j) = VL(:,j) + i*VL(:,j+1) */
/* and */
/* u(j+1) = VL(:,j) - i*VL(:,j+1). */
/* Each eigenvector is scaled so that its largest component has */
/* abs(real part) + abs(imag. part) = 1, except for eigenvectors */
/* corresponding to an eigenvalue with alpha = beta = 0, which */
/* are set to zero. */
/* Not referenced if JOBVL = 'N'. */
/* LDVL (input) INTEGER */
/* The leading dimension of the matrix VL. LDVL >= 1, and */
/* if JOBVL = 'V', LDVL >= N. */
/* VR (output) DOUBLE PRECISION array, dimension (LDVR,N) */
/* If JOBVR = 'V', the right eigenvectors x(j) are stored */
/* in the columns of VR, in the same order as their eigenvalues. */
/* If the j-th eigenvalue is real, then x(j) = VR(:,j). */
/* If the j-th and (j+1)-st eigenvalues form a complex conjugate */
/* pair, then */
/* x(j) = VR(:,j) + i*VR(:,j+1) */
/* and */
/* x(j+1) = VR(:,j) - i*VR(:,j+1). */
/* Each eigenvector is scaled so that its largest component has */
/* abs(real part) + abs(imag. part) = 1, except for eigenvalues */
/* corresponding to an eigenvalue with alpha = beta = 0, which */
/* are set to zero. */
/* Not referenced if JOBVR = 'N'. */
/* LDVR (input) INTEGER */
/* The leading dimension of the matrix VR. LDVR >= 1, and */
/* if JOBVR = 'V', LDVR >= N. */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,8*N). */
/* For good performance, LWORK must generally be larger. */
/* To compute the optimal value of LWORK, call ILAENV to get */
/* blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute: */
/* NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR; */
/* The optimal LWORK is: */
/* 2*N + MAX( 6*N, N*(NB+1) ). */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* The QZ iteration failed. No eigenvectors have been */
/* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) */
/* > N: errors that usually indicate LAPACK problems: */
/* =N+1: error return from DGGBAL */
/* =N+2: error return from DGEQRF */
/* =N+3: error return from DORMQR */
/* =N+4: error return from DORGQR */
/* =N+5: error return from DGGHRD */
/* =N+6: error return from DHGEQZ (other than failed */
/* iteration) */
/* =N+7: error return from DTGEVC */
/* =N+8: error return from DGGBAK (computing VL) */
/* =N+9: error return from DGGBAK (computing VR) */
/* =N+10: error return from DLASCL (various calls) */
/* Further Details */
/* =============== */
/* Balancing */
/* --------- */
/* This driver calls DGGBAL to both permute and scale rows and columns */
/* of A and B. The permutations PL and PR are chosen so that PL*A*PR */
/* and PL*B*R will be upper triangular except for the diagonal blocks */
/* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as */
/* possible. The diagonal scaling matrices DL and DR are chosen so */
/* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to */
/* one (except for the elements that start out zero.) */
/* After the eigenvalues and eigenvectors of the balanced matrices */
/* have been computed, DGGBAK transforms the eigenvectors back to what */
/* they would have been (in perfect arithmetic) if they had not been */
/* balanced. */
/* Contents of A and B on Exit */
/* -------- -- - --- - -- ---- */
/* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or */
/* both), then on exit the arrays A and B will contain the real Schur */
/* form[*] of the "balanced" versions of A and B. If no eigenvectors */
/* are computed, then only the diagonal blocks will be correct. */
/* [*] See DHGEQZ, DGEGS, or read the book "Matrix Computations", */
/* by Golub & van Loan, pub. by Johns Hopkins U. Press. */
/* ===================================================================== */
/* Decode the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--alphar;
--alphai;
--beta;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--work;
/* Function Body */
if (lsame_(jobvl, "N")) {
ijobvl = 1;
ilvl = FALSE_;
} else if (lsame_(jobvl, "V")) {
ijobvl = 2;
ilvl = TRUE_;
} else {
ijobvl = -1;
ilvl = FALSE_;
}
if (lsame_(jobvr, "N")) {
ijobvr = 1;
ilvr = FALSE_;
} else if (lsame_(jobvr, "V")) {
ijobvr = 2;
ilvr = TRUE_;
} else {
ijobvr = -1;
ilvr = FALSE_;
}
ilv = ilvl || ilvr;
/* Test the input arguments */
/* Computing MAX */
i__1 = *n << 3;
lwkmin = max(i__1,1);
lwkopt = lwkmin;
work[1] = (doublereal) lwkopt;
lquery = *lwork == -1;
*info = 0;
if (ijobvl <= 0) {
*info = -1;
} else if (ijobvr <= 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
} else if (*ldvl < 1 || ilvl && *ldvl < *n) {
*info = -12;
} else if (*ldvr < 1 || ilvr && *ldvr < *n) {
*info = -14;
} else if (*lwork < lwkmin && ! lquery) {
*info = -16;
}
if (*info == 0) {
nb1 = ilaenv_(&c__1, "DGEQRF", " ", n, n, &c_n1, &c_n1);
nb2 = ilaenv_(&c__1, "DORMQR", " ", n, n, n, &c_n1);
nb3 = ilaenv_(&c__1, "DORGQR", " ", n, n, n, &c_n1);
/* Computing MAX */
i__1 = max(nb1,nb2);
nb = max(i__1,nb3);
/* Computing MAX */
i__1 = *n * 6, i__2 = *n * (nb + 1);
lopt = (*n << 1) + max(i__1,i__2);
work[1] = (doublereal) lopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEGV ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = dlamch_("E") * dlamch_("B");
safmin = dlamch_("S");
safmin += safmin;
safmax = 1. / safmin;
onepls = eps * 4 + 1.;
/* Scale A */
anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]);
anrm1 = anrm;
anrm2 = 1.;
if (anrm < 1.) {
if (safmax * anrm < 1.) {
anrm1 = safmin;
anrm2 = safmax * anrm;
}
}
if (anrm > 0.) {
dlascl_("G", &c_n1, &c_n1, &anrm, &c_b27, n, n, &a[a_offset], lda, &
iinfo);
if (iinfo != 0) {
*info = *n + 10;
return 0;
}
}
/* Scale B */
bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]);
bnrm1 = bnrm;
bnrm2 = 1.;
if (bnrm < 1.) {
if (safmax * bnrm < 1.) {
bnrm1 = safmin;
bnrm2 = safmax * bnrm;
}
}
if (bnrm > 0.) {
dlascl_("G", &c_n1, &c_n1, &bnrm, &c_b27, n, n, &b[b_offset], ldb, &
iinfo);
if (iinfo != 0) {
*info = *n + 10;
return 0;
}
}
/* Permute the matrix to make it more nearly triangular */
/* Workspace layout: (8*N words -- "work" requires 6*N words) */
ileft = 1;
iright = *n + 1;
iwork = iright + *n;
dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[
ileft], &work[iright], &work[iwork], &iinfo);
if (iinfo != 0) {
*info = *n + 1;
goto L120;
}
/* Reduce B to triangular form, and initialize VL and/or VR */
irows = ihi + 1 - ilo;
if (ilv) {
icols = *n + 1 - ilo;
} else {
icols = irows;
}
itau = iwork;
iwork = itau + irows;
i__1 = *lwork + 1 - iwork;
dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 2;
goto L120;
}
i__1 = *lwork + 1 - iwork;
dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, &
iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 3;
goto L120;
}
if (ilvl) {
dlaset_("Full", n, n, &c_b38, &c_b27, &vl[vl_offset], ldvl)
;
i__1 = irows - 1;
i__2 = irows - 1;
dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vl[ilo +
1 + ilo * vl_dim1], ldvl);
i__1 = *lwork + 1 - iwork;
dorgqr_(&irows, &irows, &irows, &vl[ilo + ilo * vl_dim1], ldvl, &work[
itau], &work[iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 4;
goto L120;
}
}
if (ilvr) {
dlaset_("Full", n, n, &c_b38, &c_b27, &vr[vr_offset], ldvr)
;
}
/* Reduce to generalized Hessenberg form */
if (ilv) {
/* Eigenvectors requested -- work on whole matrix. */
dgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &iinfo);
} else {
dgghrd_("N", "N", &irows, &c__1, &irows, &a[ilo + ilo * a_dim1], lda,
&b[ilo + ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[
vr_offset], ldvr, &iinfo);
}
if (iinfo != 0) {
*info = *n + 5;
goto L120;
}
/* Perform QZ algorithm */
iwork = itau;
if (ilv) {
*(unsigned char *)chtemp = 'S';
} else {
*(unsigned char *)chtemp = 'E';
}
i__1 = *lwork + 1 - iwork;
dhgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[
b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset],
ldvl, &vr[vr_offset], ldvr, &work[iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
if (iinfo > 0 && iinfo <= *n) {
*info = iinfo;
} else if (iinfo > *n && iinfo <= *n << 1) {
*info = iinfo - *n;
} else {
*info = *n + 6;
}
goto L120;
}
if (ilv) {
/* Compute Eigenvectors (DTGEVC requires 6*N words of workspace) */
if (ilvl) {
if (ilvr) {
*(unsigned char *)chtemp = 'B';
} else {
*(unsigned char *)chtemp = 'L';
}
} else {
*(unsigned char *)chtemp = 'R';
}
dtgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb,
&vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[
iwork], &iinfo);
if (iinfo != 0) {
*info = *n + 7;
goto L120;
}
/* Undo balancing on VL and VR, rescale */
if (ilvl) {
dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &
vl[vl_offset], ldvl, &iinfo);
if (iinfo != 0) {
*info = *n + 8;
goto L120;
}
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
if (alphai[jc] < 0.) {
goto L50;
}
temp = 0.;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = vl[jr + jc * vl_dim1],
abs(d__1));
temp = max(d__2,d__3);
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__3 = temp, d__4 = (d__1 = vl[jr + jc * vl_dim1],
abs(d__1)) + (d__2 = vl[jr + (jc + 1) *
vl_dim1], abs(d__2));
temp = max(d__3,d__4);
}
}
if (temp < safmin) {
goto L50;
}
temp = 1. / temp;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vl[jr + jc * vl_dim1] *= temp;
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vl[jr + jc * vl_dim1] *= temp;
vl[jr + (jc + 1) * vl_dim1] *= temp;
}
}
L50:
;
}
}
if (ilvr) {
dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &
vr[vr_offset], ldvr, &iinfo);
if (iinfo != 0) {
*info = *n + 9;
goto L120;
}
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
if (alphai[jc] < 0.) {
goto L100;
}
temp = 0.;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = vr[jr + jc * vr_dim1],
abs(d__1));
temp = max(d__2,d__3);
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__3 = temp, d__4 = (d__1 = vr[jr + jc * vr_dim1],
abs(d__1)) + (d__2 = vr[jr + (jc + 1) *
vr_dim1], abs(d__2));
temp = max(d__3,d__4);
}
}
if (temp < safmin) {
goto L100;
}
temp = 1. / temp;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vr[jr + jc * vr_dim1] *= temp;
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vr[jr + jc * vr_dim1] *= temp;
vr[jr + (jc + 1) * vr_dim1] *= temp;
}
}
L100:
;
}
}
/* End of eigenvector calculation */
}
/* Undo scaling in alpha, beta */
/* Note: this does not give the alpha and beta for the unscaled */
/* problem. */
/* Un-scaling is limited to avoid underflow in alpha and beta */
/* if they are significant. */
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
absar = (d__1 = alphar[jc], abs(d__1));
absai = (d__1 = alphai[jc], abs(d__1));
absb = (d__1 = beta[jc], abs(d__1));
salfar = anrm * alphar[jc];
salfai = anrm * alphai[jc];
sbeta = bnrm * beta[jc];
ilimit = FALSE_;
scale = 1.;
/* Check for significant underflow in ALPHAI */
/* Computing MAX */
d__1 = safmin, d__2 = eps * absar, d__1 = max(d__1,d__2), d__2 = eps *
absb;
if (abs(salfai) < safmin && absai >= max(d__1,d__2)) {
ilimit = TRUE_;
/* Computing MAX */
d__1 = onepls * safmin, d__2 = anrm2 * absai;
scale = onepls * safmin / anrm1 / max(d__1,d__2);
} else if (salfai == 0.) {
/* If insignificant underflow in ALPHAI, then make the */
/* conjugate eigenvalue real. */
if (alphai[jc] < 0. && jc > 1) {
alphai[jc - 1] = 0.;
} else if (alphai[jc] > 0. && jc < *n) {
alphai[jc + 1] = 0.;
}
}
/* Check for significant underflow in ALPHAR */
/* Computing MAX */
d__1 = safmin, d__2 = eps * absai, d__1 = max(d__1,d__2), d__2 = eps *
absb;
if (abs(salfar) < safmin && absar >= max(d__1,d__2)) {
ilimit = TRUE_;
/* Computing MAX */
/* Computing MAX */
d__3 = onepls * safmin, d__4 = anrm2 * absar;
d__1 = scale, d__2 = onepls * safmin / anrm1 / max(d__3,d__4);
scale = max(d__1,d__2);
}
/* Check for significant underflow in BETA */
/* Computing MAX */
d__1 = safmin, d__2 = eps * absar, d__1 = max(d__1,d__2), d__2 = eps *
absai;
if (abs(sbeta) < safmin && absb >= max(d__1,d__2)) {
ilimit = TRUE_;
/* Computing MAX */
/* Computing MAX */
d__3 = onepls * safmin, d__4 = bnrm2 * absb;
d__1 = scale, d__2 = onepls * safmin / bnrm1 / max(d__3,d__4);
scale = max(d__1,d__2);
}
/* Check for possible overflow when limiting scaling */
if (ilimit) {
/* Computing MAX */
d__1 = abs(salfar), d__2 = abs(salfai), d__1 = max(d__1,d__2),
d__2 = abs(sbeta);
temp = scale * safmin * max(d__1,d__2);
if (temp > 1.) {
scale /= temp;
}
if (scale < 1.) {
ilimit = FALSE_;
}
}
/* Recompute un-scaled ALPHAR, ALPHAI, BETA if necessary. */
if (ilimit) {
salfar = scale * alphar[jc] * anrm;
salfai = scale * alphai[jc] * anrm;
sbeta = scale * beta[jc] * bnrm;
}
alphar[jc] = salfar;
alphai[jc] = salfai;
beta[jc] = sbeta;
}
L120:
work[1] = (doublereal) lwkopt;
return 0;
/* End of DGEGV */
} /* dgegv_ */
doublereal drzt02_(integer *m, integer *n, doublereal *af, integer *lda,
doublereal *tau, doublereal *work, integer *lwork)
{
/* System generated locals */
integer af_dim1, af_offset, i__1, i__2;
doublereal ret_val;
/* Local variables */
integer i__, info;
doublereal rwork[1];
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *), dormrz_(char *, char *,
integer *, integer *, integer *, integer *, doublereal *, integer
*, doublereal *, doublereal *, integer *, doublereal *, integer *,
integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DRZT02 returns */
/* || I - Q'*Q || / ( M * eps) */
/* where the matrix Q is defined by the Householder transformations */
/* generated by DTZRZF. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix AF. */
/* N (input) INTEGER */
/* The number of columns of the matrix AF. */
/* AF (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The output of DTZRZF. */
/* LDA (input) INTEGER */
/* The leading dimension of the array AF. */
/* TAU (input) DOUBLE PRECISION array, dimension (M) */
/* Details of the Householder transformations as returned by */
/* DTZRZF. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* length of WORK array. LWORK >= N*N+N*NB. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
--tau;
--work;
/* Function Body */
ret_val = 0.;
if (*lwork < *n * *n + *n) {
xerbla_("DRZT02", &c__7);
return ret_val;
}
/* Quick return if possible */
if (*m <= 0 || *n <= 0) {
return ret_val;
}
/* Q := I */
dlaset_("Full", n, n, &c_b5, &c_b6, &work[1], n);
/* Q := P(1) * ... * P(m) * Q */
i__1 = *n - *m;
i__2 = *lwork - *n * *n;
dormrz_("Left", "No transpose", n, n, m, &i__1, &af[af_offset], lda, &tau[
1], &work[1], n, &work[*n * *n + 1], &i__2, &info);
/* Q := P(m) * ... * P(1) * Q */
i__1 = *n - *m;
i__2 = *lwork - *n * *n;
dormrz_("Left", "Transpose", n, n, m, &i__1, &af[af_offset], lda, &tau[1],
&work[1], n, &work[*n * *n + 1], &i__2, &info);
/* Q := Q - I */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[(i__ - 1) * *n + i__] += -1.;
/* L10: */
}
ret_val = dlange_("One-norm", n, n, &work[1], n, rwork) / (
dlamch_("Epsilon") * (doublereal) max(*m,*n));
return ret_val;
/* End of DRZT02 */
} /* drzt02_ */
/* Subroutine */ int dgelsx_(integer *m, integer *n, integer *nrhs,
doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *
jpvt, doublereal *rcond, integer *rank, doublereal *work, integer *
info)
{
/* -- LAPACK driver routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
This routine is deprecated and has been replaced by routine DGELSY.
DGELSX computes the minimum-norm solution to a real linear least
squares problem:
minimize || A * X - B ||
using a complete orthogonal factorization 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 routine first computes a QR factorization with column pivoting:
A * P = Q * [ R11 R12 ]
[ 0 R22 ]
with R11 defined as the largest leading submatrix whose estimated
condition number is less than 1/RCOND. The order of R11, RANK,
is the effective rank of A.
Then, R22 is considered to be negligible, and R12 is annihilated
by orthogonal transformations from the right, arriving at the
complete orthogonal factorization:
A * P = Q * [ T11 0 ] * Z
[ 0 0 ]
The minimum-norm solution is then
X = P * Z' [ inv(T11)*Q1'*B ]
[ 0 ]
where Q1 consists of the first RANK columns of Q.
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 matrices B and X. NRHS >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, A has been overwritten by details of its
complete orthogonal factorization.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
On entry, the M-by-NRHS right hand side matrix B.
On exit, 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).
JPVT (input/output) INTEGER array, dimension (N)
On entry, if JPVT(i) .ne. 0, the i-th column of A is an
initial column, otherwise it is a free column. Before
the QR factorization of A, all initial columns are
permuted to the leading positions; only the remaining
free columns are moved as a result of column pivoting
during the factorization.
On exit, if JPVT(i) = k, then the i-th column of A*P
was the k-th column of A.
RCOND (input) DOUBLE PRECISION
RCOND is used to determine the effective rank of A, which
is defined as the order of the largest leading triangular
submatrix R11 in the QR factorization with pivoting of A,
whose estimated condition number < 1/RCOND.
RANK (output) INTEGER
The effective rank of A, i.e., the order of the submatrix
R11. This is the same as the order of the submatrix T11
in the complete orthogonal factorization of A.
WORK (workspace) DOUBLE PRECISION array, dimension
(max( min(M,N)+3*N, 2*min(M,N)+NRHS )),
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__0 = 0;
static doublereal c_b13 = 0.;
static integer c__2 = 2;
static integer c__1 = 1;
static doublereal c_b36 = 1.;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
static doublereal anrm, bnrm, smin, smax;
static integer i__, j, k, iascl, ibscl, ismin, ismax;
static doublereal c1, c2;
extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *), dlaic1_(
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *);
static doublereal s1, s2, t1, t2;
extern /* Subroutine */ int dorm2r_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *), dlabad_(
doublereal *, doublereal *);
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 *), dgeqpf_(integer *, integer *,
doublereal *, integer *, integer *, doublereal *, doublereal *,
integer *), dlaset_(char *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *), xerbla_(char *,
integer *);
static doublereal bignum;
extern /* Subroutine */ int dlatzm_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *);
static doublereal sminpr, smaxpr, smlnum;
extern /* Subroutine */ int dtzrqf_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *);
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--jpvt;
--work;
/* Function Body */
mn = min(*m,*n);
ismin = mn + 1;
ismax = (mn << 1) + 1;
/* Test the input arguments. */
*info = 0;
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(complicated condition) */ {
/* Computing MAX */
i__1 = max(1,*m);
if (*ldb < max(i__1,*n)) {
*info = -7;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGELSX", &i__1);
return 0;
}
/* Quick return if possible
Computing MIN */
i__1 = min(*m,*n);
if (min(i__1,*nrhs) == 0) {
*rank = 0;
return 0;
}
/* Get machine parameters */
smlnum = dlamch_("S") / dlamch_("P");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
/* Scale A, B if max elements outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", m, n, &a[a_offset], lda, &work[1]);
iascl = 0;
if (anrm > 0. && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
info);
iascl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM */
dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
info);
iascl = 2;
} else if (anrm == 0.) {
/* Matrix all zero. Return zero solution. */
i__1 = max(*m,*n);
dlaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb);
*rank = 0;
goto L100;
}
bnrm = dlange_("M", m, nrhs, &b[b_offset], ldb, &work[1]);
ibscl = 0;
if (bnrm > 0. && bnrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
info);
ibscl = 1;
} else if (bnrm > bignum) {
/* Scale matrix norm down to BIGNUM */
dlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
info);
ibscl = 2;
}
/* Compute QR factorization with column pivoting of A:
A * P = Q * R */
dgeqpf_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], info);
/* workspace 3*N. Details of Householder rotations stored
in WORK(1:MN).
Determine RANK using incremental condition estimation */
work[ismin] = 1.;
work[ismax] = 1.;
smax = (d__1 = a_ref(1, 1), abs(d__1));
smin = smax;
if ((d__1 = a_ref(1, 1), abs(d__1)) == 0.) {
*rank = 0;
i__1 = max(*m,*n);
dlaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb);
goto L100;
} else {
*rank = 1;
}
L10:
if (*rank < mn) {
i__ = *rank + 1;
dlaic1_(&c__2, rank, &work[ismin], &smin, &a_ref(1, i__), &a_ref(i__,
i__), &sminpr, &s1, &c1);
dlaic1_(&c__1, rank, &work[ismax], &smax, &a_ref(1, i__), &a_ref(i__,
i__), &smaxpr, &s2, &c2);
if (smaxpr * *rcond <= sminpr) {
i__1 = *rank;
for (i__ = 1; i__ <= i__1; ++i__) {
work[ismin + i__ - 1] = s1 * work[ismin + i__ - 1];
work[ismax + i__ - 1] = s2 * work[ismax + i__ - 1];
/* L20: */
}
work[ismin + *rank] = c1;
work[ismax + *rank] = c2;
smin = sminpr;
smax = smaxpr;
++(*rank);
goto L10;
}
}
/* Logically partition R = [ R11 R12 ]
[ 0 R22 ]
where R11 = R(1:RANK,1:RANK)
[R11,R12] = [ T11, 0 ] * Y */
if (*rank < *n) {
dtzrqf_(rank, n, &a[a_offset], lda, &work[mn + 1], info);
}
/* Details of Householder rotations stored in WORK(MN+1:2*MN)
B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */
dorm2r_("Left", "Transpose", m, nrhs, &mn, &a[a_offset], lda, &work[1], &
b[b_offset], ldb, &work[(mn << 1) + 1], info);
/* workspace NRHS
B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */
dtrsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b36, &
a[a_offset], lda, &b[b_offset], ldb);
i__1 = *n;
for (i__ = *rank + 1; i__ <= i__1; ++i__) {
i__2 = *nrhs;
for (j = 1; j <= i__2; ++j) {
b_ref(i__, j) = 0.;
/* L30: */
}
/* L40: */
}
/* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) */
if (*rank < *n) {
i__1 = *rank;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n - *rank + 1;
dlatzm_("Left", &i__2, nrhs, &a_ref(i__, *rank + 1), lda, &work[
mn + i__], &b_ref(i__, 1), &b_ref(*rank + 1, 1), ldb, &
work[(mn << 1) + 1]);
/* L50: */
}
}
/* workspace NRHS
B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[(mn << 1) + i__] = 1.;
/* L60: */
}
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[(mn << 1) + i__] == 1.) {
if (jpvt[i__] != i__) {
k = i__;
t1 = b_ref(k, j);
t2 = b_ref(jpvt[k], j);
L70:
b_ref(jpvt[k], j) = t1;
work[(mn << 1) + k] = 0.;
t1 = t2;
k = jpvt[k];
t2 = b_ref(jpvt[k], j);
if (jpvt[k] != i__) {
goto L70;
}
b_ref(i__, j) = t1;
work[(mn << 1) + k] = 0.;
}
}
/* L80: */
}
/* L90: */
}
/* Undo scaling */
if (iascl == 1) {
dlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
info);
dlascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset],
lda, info);
} else if (iascl == 2) {
dlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
info);
dlascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset],
lda, info);
}
if (ibscl == 1) {
dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
info);
} else if (ibscl == 2) {
dlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
info);
}
L100:
return 0;
/* End of DGELSX */
} /* dgelsx_ */
/* Subroutine */ int dgelqs_(integer *m, integer *n, integer *nrhs,
doublereal *a, integer *lda, doublereal *tau, doublereal *b, integer *
ldb, doublereal *work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
/* Local variables */
extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *), dlaset_(
char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *), xerbla_(char *, integer *), dormlq_(char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* Compute a minimum-norm solution */
/* min || A*X - B || */
/* using the LQ factorization */
/* A = L*Q */
/* computed by DGELQF. */
/* 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 >= M >= 0. */
/* NRHS (input) INTEGER */
/* The number of columns of B. NRHS >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* Details of the LQ factorization of the original matrix A as */
/* returned by DGELQF. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= M. */
/* TAU (input) DOUBLE PRECISION array, dimension (M) */
/* Details of the orthogonal matrix Q. */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* On entry, the m-by-nrhs right hand side matrix B. */
/* On exit, the n-by-nrhs solution matrix X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= N. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK must be at least NRHS, */
/* and should be at least NRHS*NB, where NB is the block size */
/* for this environment. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0 || *m > *n) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*lwork < 1 || *lwork < *nrhs && *m > 0 && *n > 0) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGELQS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0 || *m == 0) {
return 0;
}
/* Solve L*X = B(1:m,:) */
dtrsm_("Left", "Lower", "No transpose", "Non-unit", m, nrhs, &c_b7, &a[
a_offset], lda, &b[b_offset], ldb);
/* Set B(m+1:n,:) to zero */
if (*m < *n) {
i__1 = *n - *m;
dlaset_("Full", &i__1, nrhs, &c_b9, &c_b9, &b[*m + 1 + b_dim1], ldb);
}
/* B := Q' * B */
dormlq_("Left", "Transpose", n, nrhs, m, &a[a_offset], lda, &tau[1], &b[
b_offset], ldb, &work[1], lwork, info);
return 0;
/* End of DGELQS */
} /* dgelqs_ */
/* Subroutine */ int dlqt03_(integer *m, integer *n, integer *k, doublereal *
af, doublereal *c__, doublereal *cc, doublereal *q, integer *lda,
doublereal *tau, doublereal *work, integer *lwork, doublereal *rwork,
doublereal *result)
{
/* Initialized data */
static integer iseed[4] = { 1988,1989,1990,1991 };
/* System generated locals */
integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1,
q_offset, i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer j, mc, nc;
doublereal eps;
char side[1];
integer info;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
integer iside;
extern logical lsame_(char *, char *);
doublereal resid, cnorm;
char trans[1];
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *), dlarnv_(integer *, integer *,
integer *, doublereal *), dorglq_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), dormlq_(char *, char *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *);
integer itrans;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLQT03 tests DORMLQ, which computes Q*C, Q'*C, C*Q or C*Q'. */
/* DLQT03 compares the results of a call to DORMLQ with the results of */
/* forming Q explicitly by a call to DORGLQ and then performing matrix */
/* multiplication by a call to DGEMM. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows or columns of the matrix C; C is n-by-m if */
/* Q is applied from the left, or m-by-n if Q is applied from */
/* the right. M >= 0. */
/* N (input) INTEGER */
/* The order of the orthogonal matrix Q. N >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* orthogonal matrix Q. N >= K >= 0. */
/* AF (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* Details of the LQ factorization of an m-by-n matrix, as */
/* returned by DGELQF. See SGELQF for further details. */
/* C (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
/* CC (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
/* Q (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays AF, C, CC, and Q. */
/* TAU (input) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors corresponding */
/* to the LQ factorization in AF. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The length of WORK. LWORK must be at least M, and should be */
/* M*NB, where NB is the blocksize for this environment. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
/* The test ratios compare two techniques for multiplying a */
/* random matrix C by an n-by-n orthogonal matrix Q. */
/* RESULT(1) = norm( Q*C - Q*C ) / ( N * norm(C) * EPS ) */
/* RESULT(2) = norm( C*Q - C*Q ) / ( N * norm(C) * EPS ) */
/* RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS ) */
/* RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
cc_dim1 = *lda;
cc_offset = 1 + cc_dim1;
cc -= cc_offset;
c_dim1 = *lda;
c_offset = 1 + c_dim1;
c__ -= c_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
eps = dlamch_("Epsilon");
/* Copy the first k rows of the factorization to the array Q */
dlaset_("Full", n, n, &c_b4, &c_b4, &q[q_offset], lda);
i__1 = *n - 1;
dlacpy_("Upper", k, &i__1, &af[(af_dim1 << 1) + 1], lda, &q[(q_dim1 << 1)
+ 1], lda);
/* Generate the n-by-n matrix Q */
s_copy(srnamc_1.srnamt, "DORGLQ", (ftnlen)6, (ftnlen)6);
dorglq_(n, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
for (iside = 1; iside <= 2; ++iside) {
if (iside == 1) {
*(unsigned char *)side = 'L';
mc = *n;
nc = *m;
} else {
*(unsigned char *)side = 'R';
mc = *m;
nc = *n;
}
/* Generate MC by NC matrix C */
i__1 = nc;
for (j = 1; j <= i__1; ++j) {
dlarnv_(&c__2, iseed, &mc, &c__[j * c_dim1 + 1]);
/* L10: */
}
cnorm = dlange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]);
if (cnorm == 0.) {
cnorm = 1.;
}
for (itrans = 1; itrans <= 2; ++itrans) {
if (itrans == 1) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'T';
}
/* Copy C */
dlacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
lda);
/* Apply Q or Q' to C */
s_copy(srnamc_1.srnamt, "DORMLQ", (ftnlen)6, (ftnlen)6);
dormlq_(side, trans, &mc, &nc, k, &af[af_offset], lda, &tau[1], &
cc[cc_offset], lda, &work[1], lwork, &info);
/* Form explicit product and subtract */
if (lsame_(side, "L")) {
dgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b21, &q[
q_offset], lda, &c__[c_offset], lda, &c_b22, &cc[
cc_offset], lda);
} else {
dgemm_("No transpose", trans, &mc, &nc, &nc, &c_b21, &c__[
c_offset], lda, &q[q_offset], lda, &c_b22, &cc[
cc_offset], lda);
}
/* Compute error in the difference */
resid = dlange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
result[(iside - 1 << 1) + itrans] = resid / ((doublereal) max(1,*
n) * cnorm * eps);
/* L20: */
}
/* L30: */
}
return 0;
/* End of DLQT03 */
} /* dlqt03_ */
/* Subroutine */ int dlasda_(integer *icompq, integer *smlsiz, integer *n,
integer *sqre, doublereal *d__, doublereal *e, doublereal *u, integer
*ldu, doublereal *vt, integer *k, doublereal *difl, doublereal *difr,
doublereal *z__, doublereal *poles, integer *givptr, integer *givcol,
integer *ldgcol, integer *perm, doublereal *givnum, doublereal *c__,
doublereal *s, doublereal *work, integer *iwork, integer *info)
{
/* System generated locals */
integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, difl_dim1,
difl_offset, difr_dim1, difr_offset, givnum_dim1, givnum_offset,
poles_dim1, poles_offset, u_dim1, u_offset, vt_dim1, vt_offset,
z_dim1, z_offset, i__1, i__2;
/* Builtin functions */
integer pow_ii(integer *, integer *);
/* Local variables */
static doublereal beta;
static integer idxq, nlvl, i__, j, m;
static doublereal alpha;
static integer inode, ndiml, ndimr, idxqi, itemp;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer sqrei, i1;
extern /* Subroutine */ int dlasd6_(integer *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *);
static integer ic, nwork1, lf, nd, nwork2, ll, nl, vf, nr, vl;
extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer
*, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *), dlasdt_(integer *, integer *,
integer *, integer *, integer *, integer *, integer *), dlaset_(
char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *), xerbla_(char *, integer *);
static integer im1, smlszp, ncc, nlf, nrf, vfi, iwk, vli, lvl, nru, ndb1,
nlp1, lvl2, nrp1;
#define difl_ref(a_1,a_2) difl[(a_2)*difl_dim1 + a_1]
#define difr_ref(a_1,a_2) difr[(a_2)*difr_dim1 + a_1]
#define perm_ref(a_1,a_2) perm[(a_2)*perm_dim1 + a_1]
#define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1]
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
#define poles_ref(a_1,a_2) poles[(a_2)*poles_dim1 + a_1]
#define vt_ref(a_1,a_2) vt[(a_2)*vt_dim1 + a_1]
#define givcol_ref(a_1,a_2) givcol[(a_2)*givcol_dim1 + a_1]
#define givnum_ref(a_1,a_2) givnum[(a_2)*givnum_dim1 + a_1]
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1999
Purpose
=======
Using a divide and conquer approach, DLASDA computes the singular
value decomposition (SVD) of a real upper bidiagonal N-by-M matrix
B with diagonal D and offdiagonal E, where M = N + SQRE. The
algorithm computes the singular values in the SVD B = U * S * VT.
The orthogonal matrices U and VT are optionally computed in
compact form.
A related subroutine, DLASD0, computes the singular values and
the singular vectors in explicit form.
Arguments
=========
ICOMPQ (input) INTEGER
Specifies whether singular vectors are to be computed
in compact form, as follows
= 0: Compute singular values only.
= 1: Compute singular vectors of upper bidiagonal
matrix in compact form.
SMLSIZ (input) INTEGER
The maximum size of the subproblems at the bottom of the
computation tree.
N (input) INTEGER
The row dimension of the upper bidiagonal matrix. This is
also the dimension of the main diagonal array D.
SQRE (input) INTEGER
Specifies the column dimension of the bidiagonal matrix.
= 0: The bidiagonal matrix has column dimension M = N;
= 1: The bidiagonal matrix has column dimension M = N + 1.
D (input/output) DOUBLE PRECISION array, dimension ( N )
On entry D contains the main diagonal of the bidiagonal
matrix. On exit D, if INFO = 0, contains its singular values.
E (input) DOUBLE PRECISION array, dimension ( M-1 )
Contains the subdiagonal entries of the bidiagonal matrix.
On exit, E has been destroyed.
U (output) DOUBLE PRECISION array,
dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced
if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left
singular vector matrices of all subproblems at the bottom
level.
LDU (input) INTEGER, LDU = > N.
The leading dimension of arrays U, VT, DIFL, DIFR, POLES,
GIVNUM, and Z.
VT (output) DOUBLE PRECISION array,
dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced
if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right
singular vector matrices of all subproblems at the bottom
level.
K (output) INTEGER array,
dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0.
If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th
secular equation on the computation tree.
DIFL (output) DOUBLE PRECISION array, dimension ( LDU, NLVL ),
where NLVL = floor(log_2 (N/SMLSIZ))).
DIFR (output) DOUBLE PRECISION array,
dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and
dimension ( N ) if ICOMPQ = 0.
If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1)
record distances between singular values on the I-th
level and singular values on the (I -1)-th level, and
DIFR(1:N, 2 * I ) contains the normalizing factors for
the right singular vector matrix. See DLASD8 for details.
Z (output) DOUBLE PRECISION array,
dimension ( LDU, NLVL ) if ICOMPQ = 1 and
dimension ( N ) if ICOMPQ = 0.
The first K elements of Z(1, I) contain the components of
the deflation-adjusted updating row vector for subproblems
on the I-th level.
POLES (output) DOUBLE PRECISION array,
dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced
if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and
POLES(1, 2*I) contain the new and old singular values
involved in the secular equations on the I-th level.
GIVPTR (output) INTEGER array,
dimension ( N ) if ICOMPQ = 1, and not referenced if
ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records
the number of Givens rotations performed on the I-th
problem on the computation tree.
GIVCOL (output) INTEGER array,
dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not
referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,
GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations
of Givens rotations performed on the I-th level on the
computation tree.
LDGCOL (input) INTEGER, LDGCOL = > N.
The leading dimension of arrays GIVCOL and PERM.
PERM (output) INTEGER array,
dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced
if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records
permutations done on the I-th level of the computation tree.
GIVNUM (output) DOUBLE PRECISION array,
dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not
referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,
GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S-
values of Givens rotations performed on the I-th level on
the computation tree.
C (output) DOUBLE PRECISION array,
dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0.
If ICOMPQ = 1 and the I-th subproblem is not square, on exit,
C( I ) contains the C-value of a Givens rotation related to
the right null space of the I-th subproblem.
S (output) DOUBLE PRECISION array, dimension ( N ) if
ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1
and the I-th subproblem is not square, on exit, S( I )
contains the S-value of a Givens rotation related to
the right null space of the I-th subproblem.
WORK (workspace) DOUBLE PRECISION array, dimension
(6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)).
IWORK (workspace) INTEGER array.
Dimension must be at least (7 * N).
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: if INFO = 1, an singular value did not converge
Further Details
===============
Based on contributions by
Ming Gu and Huan Ren, Computer Science Division, University of
California at Berkeley, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
--e;
givnum_dim1 = *ldu;
givnum_offset = 1 + givnum_dim1 * 1;
givnum -= givnum_offset;
poles_dim1 = *ldu;
poles_offset = 1 + poles_dim1 * 1;
poles -= poles_offset;
z_dim1 = *ldu;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
difr_dim1 = *ldu;
difr_offset = 1 + difr_dim1 * 1;
difr -= difr_offset;
difl_dim1 = *ldu;
difl_offset = 1 + difl_dim1 * 1;
difl -= difl_offset;
vt_dim1 = *ldu;
vt_offset = 1 + vt_dim1 * 1;
vt -= vt_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
--k;
--givptr;
perm_dim1 = *ldgcol;
perm_offset = 1 + perm_dim1 * 1;
perm -= perm_offset;
givcol_dim1 = *ldgcol;
givcol_offset = 1 + givcol_dim1 * 1;
givcol -= givcol_offset;
--c__;
--s;
--work;
--iwork;
/* Function Body */
*info = 0;
if (*icompq < 0 || *icompq > 1) {
*info = -1;
} else if (*smlsiz < 3) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*sqre < 0 || *sqre > 1) {
*info = -4;
} else if (*ldu < *n + *sqre) {
*info = -8;
} else if (*ldgcol < *n) {
*info = -17;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLASDA", &i__1);
return 0;
}
m = *n + *sqre;
/* If the input matrix is too small, call DLASDQ to find the SVD. */
if (*n <= *smlsiz) {
if (*icompq == 0) {
dlasdq_("U", sqre, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[
vt_offset], ldu, &u[u_offset], ldu, &u[u_offset], ldu, &
work[1], info);
} else {
dlasdq_("U", sqre, n, &m, n, &c__0, &d__[1], &e[1], &vt[vt_offset]
, ldu, &u[u_offset], ldu, &u[u_offset], ldu, &work[1],
info);
}
return 0;
}
/* Book-keeping and set up the computation tree. */
inode = 1;
ndiml = inode + *n;
ndimr = ndiml + *n;
idxq = ndimr + *n;
iwk = idxq + *n;
ncc = 0;
nru = 0;
smlszp = *smlsiz + 1;
vf = 1;
vl = vf + m;
nwork1 = vl + m;
nwork2 = nwork1 + smlszp * smlszp;
dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr],
smlsiz);
/* for the nodes on bottom level of the tree, solve
their subproblems by DLASDQ. */
ndb1 = (nd + 1) / 2;
i__1 = nd;
for (i__ = ndb1; i__ <= i__1; ++i__) {
/* IC : center row of each node
NL : number of rows of left subproblem
NR : number of rows of right subproblem
NLF: starting row of the left subproblem
NRF: starting row of the right subproblem */
i1 = i__ - 1;
ic = iwork[inode + i1];
nl = iwork[ndiml + i1];
nlp1 = nl + 1;
nr = iwork[ndimr + i1];
nlf = ic - nl;
nrf = ic + 1;
idxqi = idxq + nlf - 2;
vfi = vf + nlf - 1;
vli = vl + nlf - 1;
sqrei = 1;
if (*icompq == 0) {
dlaset_("A", &nlp1, &nlp1, &c_b11, &c_b12, &work[nwork1], &smlszp);
dlasdq_("U", &sqrei, &nl, &nlp1, &nru, &ncc, &d__[nlf], &e[nlf], &
work[nwork1], &smlszp, &work[nwork2], &nl, &work[nwork2],
&nl, &work[nwork2], info);
itemp = nwork1 + nl * smlszp;
dcopy_(&nlp1, &work[nwork1], &c__1, &work[vfi], &c__1);
dcopy_(&nlp1, &work[itemp], &c__1, &work[vli], &c__1);
} else {
dlaset_("A", &nl, &nl, &c_b11, &c_b12, &u_ref(nlf, 1), ldu);
dlaset_("A", &nlp1, &nlp1, &c_b11, &c_b12, &vt_ref(nlf, 1), ldu);
dlasdq_("U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], &
vt_ref(nlf, 1), ldu, &u_ref(nlf, 1), ldu, &u_ref(nlf, 1),
ldu, &work[nwork1], info);
dcopy_(&nlp1, &vt_ref(nlf, 1), &c__1, &work[vfi], &c__1);
dcopy_(&nlp1, &vt_ref(nlf, nlp1), &c__1, &work[vli], &c__1);
}
if (*info != 0) {
return 0;
}
i__2 = nl;
for (j = 1; j <= i__2; ++j) {
iwork[idxqi + j] = j;
/* L10: */
}
if (i__ == nd && *sqre == 0) {
sqrei = 0;
} else {
sqrei = 1;
}
idxqi += nlp1;
vfi += nlp1;
vli += nlp1;
nrp1 = nr + sqrei;
if (*icompq == 0) {
dlaset_("A", &nrp1, &nrp1, &c_b11, &c_b12, &work[nwork1], &smlszp);
dlasdq_("U", &sqrei, &nr, &nrp1, &nru, &ncc, &d__[nrf], &e[nrf], &
work[nwork1], &smlszp, &work[nwork2], &nr, &work[nwork2],
&nr, &work[nwork2], info);
itemp = nwork1 + (nrp1 - 1) * smlszp;
dcopy_(&nrp1, &work[nwork1], &c__1, &work[vfi], &c__1);
dcopy_(&nrp1, &work[itemp], &c__1, &work[vli], &c__1);
} else {
dlaset_("A", &nr, &nr, &c_b11, &c_b12, &u_ref(nrf, 1), ldu);
dlaset_("A", &nrp1, &nrp1, &c_b11, &c_b12, &vt_ref(nrf, 1), ldu);
dlasdq_("U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], &
vt_ref(nrf, 1), ldu, &u_ref(nrf, 1), ldu, &u_ref(nrf, 1),
ldu, &work[nwork1], info);
dcopy_(&nrp1, &vt_ref(nrf, 1), &c__1, &work[vfi], &c__1);
dcopy_(&nrp1, &vt_ref(nrf, nrp1), &c__1, &work[vli], &c__1);
}
if (*info != 0) {
return 0;
}
i__2 = nr;
for (j = 1; j <= i__2; ++j) {
iwork[idxqi + j] = j;
/* L20: */
}
/* L30: */
}
/* Now conquer each subproblem bottom-up. */
j = pow_ii(&c__2, &nlvl);
for (lvl = nlvl; lvl >= 1; --lvl) {
lvl2 = (lvl << 1) - 1;
/* Find the first node LF and last node LL on
the current level LVL. */
if (lvl == 1) {
lf = 1;
ll = 1;
} else {
i__1 = lvl - 1;
lf = pow_ii(&c__2, &i__1);
ll = (lf << 1) - 1;
}
i__1 = ll;
for (i__ = lf; i__ <= i__1; ++i__) {
im1 = i__ - 1;
ic = iwork[inode + im1];
nl = iwork[ndiml + im1];
nr = iwork[ndimr + im1];
nlf = ic - nl;
nrf = ic + 1;
if (i__ == ll) {
sqrei = *sqre;
} else {
sqrei = 1;
}
vfi = vf + nlf - 1;
vli = vl + nlf - 1;
idxqi = idxq + nlf - 1;
alpha = d__[ic];
beta = e[ic];
if (*icompq == 0) {
dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], &
work[vli], &alpha, &beta, &iwork[idxqi], &perm[
perm_offset], &givptr[1], &givcol[givcol_offset],
ldgcol, &givnum[givnum_offset], ldu, &poles[
poles_offset], &difl[difl_offset], &difr[difr_offset],
&z__[z_offset], &k[1], &c__[1], &s[1], &work[nwork1],
&iwork[iwk], info);
} else {
--j;
dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], &
work[vli], &alpha, &beta, &iwork[idxqi], &perm_ref(
nlf, lvl), &givptr[j], &givcol_ref(nlf, lvl2), ldgcol,
&givnum_ref(nlf, lvl2), ldu, &poles_ref(nlf, lvl2), &
difl_ref(nlf, lvl), &difr_ref(nlf, lvl2), &z___ref(
nlf, lvl), &k[j], &c__[j], &s[j], &work[nwork1], &
iwork[iwk], info);
}
if (*info != 0) {
return 0;
}
/* L40: */
}
/* L50: */
}
return 0;
/* End of DLASDA */
} /* dlasda_ */
/* Subroutine */ int dlasd2_(integer *nl, integer *nr, integer *sqre, integer
*k, doublereal *d__, doublereal *z__, doublereal *alpha, doublereal *
beta, doublereal *u, integer *ldu, doublereal *vt, integer *ldvt,
doublereal *dsigma, doublereal *u2, integer *ldu2, doublereal *vt2,
integer *ldvt2, integer *idxp, integer *idx, integer *idxc, integer *
idxq, integer *coltyp, integer *info)
{
/* System generated locals */
integer u_dim1, u_offset, u2_dim1, u2_offset, vt_dim1, vt_offset,
vt2_dim1, vt2_offset, i__1;
doublereal d__1, d__2;
/* Local variables */
doublereal c__;
integer i__, j, m, n;
doublereal s;
integer k2;
doublereal z1;
integer ct, jp;
doublereal eps, tau, tol;
integer psm[4], nlp1, nlp2, idxi, idxj;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
integer ctot[4], idxjp;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
integer jprev;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *,
integer *, integer *, integer *), dlacpy_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *), dlaset_(char *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *), xerbla_(char *,
integer *);
doublereal hlftol;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASD2 merges the two sets of singular values together into a single */
/* sorted set. Then it tries to deflate the size of the problem. */
/* There are two ways in which deflation can occur: when two or more */
/* singular values are close together or if there is a tiny entry in the */
/* Z vector. For each such occurrence the order of the related secular */
/* equation problem is reduced by one. */
/* DLASD2 is called from DLASD1. */
/* Arguments */
/* ========= */
/* NL (input) INTEGER */
/* The row dimension of the upper block. NL >= 1. */
/* NR (input) INTEGER */
/* The row dimension of the lower block. NR >= 1. */
/* SQRE (input) INTEGER */
/* = 0: the lower block is an NR-by-NR square matrix. */
/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */
/* The bidiagonal matrix has N = NL + NR + 1 rows and */
/* M = N + SQRE >= N columns. */
/* K (output) INTEGER */
/* Contains the dimension of the non-deflated matrix, */
/* This is the order of the related secular equation. 1 <= K <=N. */
/* D (input/output) DOUBLE PRECISION array, dimension(N) */
/* On entry D contains the singular values of the two submatrices */
/* to be combined. On exit D contains the trailing (N-K) updated */
/* singular values (those which were deflated) sorted into */
/* increasing order. */
/* Z (output) DOUBLE PRECISION array, dimension(N) */
/* On exit Z contains the updating row vector in the secular */
/* equation. */
/* ALPHA (input) DOUBLE PRECISION */
/* Contains the diagonal element associated with the added row. */
/* BETA (input) DOUBLE PRECISION */
/* Contains the off-diagonal element associated with the added */
/* row. */
/* U (input/output) DOUBLE PRECISION array, dimension(LDU,N) */
/* On entry U contains the left singular vectors of two */
/* submatrices in the two square blocks with corners at (1,1), */
/* (NL, NL), and (NL+2, NL+2), (N,N). */
/* On exit U contains the trailing (N-K) updated left singular */
/* vectors (those which were deflated) in its last N-K columns. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= N. */
/* VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M) */
/* On entry VT' contains the right singular vectors of two */
/* submatrices in the two square blocks with corners at (1,1), */
/* (NL+1, NL+1), and (NL+2, NL+2), (M,M). */
/* On exit VT' contains the trailing (N-K) updated right singular */
/* vectors (those which were deflated) in its last N-K columns. */
/* In case SQRE =1, the last row of VT spans the right null */
/* space. */
/* LDVT (input) INTEGER */
/* The leading dimension of the array VT. LDVT >= M. */
/* DSIGMA (output) DOUBLE PRECISION array, dimension (N) */
/* Contains a copy of the diagonal elements (K-1 singular values */
/* and one zero) in the secular equation. */
/* U2 (output) DOUBLE PRECISION array, dimension(LDU2,N) */
/* Contains a copy of the first K-1 left singular vectors which */
/* will be used by DLASD3 in a matrix multiply (DGEMM) to solve */
/* for the new left singular vectors. U2 is arranged into four */
/* blocks. The first block contains a column with 1 at NL+1 and */
/* zero everywhere else; the second block contains non-zero */
/* entries only at and above NL; the third contains non-zero */
/* entries only below NL+1; and the fourth is dense. */
/* LDU2 (input) INTEGER */
/* The leading dimension of the array U2. LDU2 >= N. */
/* VT2 (output) DOUBLE PRECISION array, dimension(LDVT2,N) */
/* VT2' contains a copy of the first K right singular vectors */
/* which will be used by DLASD3 in a matrix multiply (DGEMM) to */
/* solve for the new right singular vectors. VT2 is arranged into */
/* three blocks. The first block contains a row that corresponds */
/* to the special 0 diagonal element in SIGMA; the second block */
/* contains non-zeros only at and before NL +1; the third block */
/* contains non-zeros only at and after NL +2. */
/* LDVT2 (input) INTEGER */
/* The leading dimension of the array VT2. LDVT2 >= M. */
/* IDXP (workspace) INTEGER array dimension(N) */
/* This will contain the permutation used to place deflated */
/* values of D at the end of the array. On output IDXP(2:K) */
/* points to the nondeflated D-values and IDXP(K+1:N) */
/* points to the deflated singular values. */
/* IDX (workspace) INTEGER array dimension(N) */
/* This will contain the permutation used to sort the contents of */
/* D into ascending order. */
/* IDXC (output) INTEGER array dimension(N) */
/* This will contain the permutation used to arrange the columns */
/* of the deflated U matrix into three groups: the first group */
/* contains non-zero entries only at and above NL, the second */
/* contains non-zero entries only below NL+2, and the third is */
/* dense. */
/* IDXQ (input/output) INTEGER array dimension(N) */
/* This contains the permutation which separately sorts the two */
/* sub-problems in D into ascending order. Note that entries in */
/* the first hlaf of this permutation must first be moved one */
/* position backward; and entries in the second half */
/* must first have NL+1 added to their values. */
/* COLTYP (workspace/output) INTEGER array dimension(N) */
/* As workspace, this will contain a label which will indicate */
/* which of the following types a column in the U2 matrix or a */
/* row in the VT2 matrix is: */
/* 1 : non-zero in the upper half only */
/* 2 : non-zero in the lower half only */
/* 3 : dense */
/* 4 : deflated */
/* On exit, it is an array of dimension 4, with COLTYP(I) being */
/* the dimension of the I-th type columns. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Huan Ren, Computer Science Division, University of */
/* California at Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--z__;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
--dsigma;
u2_dim1 = *ldu2;
u2_offset = 1 + u2_dim1;
u2 -= u2_offset;
vt2_dim1 = *ldvt2;
vt2_offset = 1 + vt2_dim1;
vt2 -= vt2_offset;
--idxp;
--idx;
--idxc;
--idxq;
--coltyp;
/* Function Body */
*info = 0;
if (*nl < 1) {
*info = -1;
} else if (*nr < 1) {
*info = -2;
} else if (*sqre != 1 && *sqre != 0) {
*info = -3;
}
n = *nl + *nr + 1;
m = n + *sqre;
if (*ldu < n) {
*info = -10;
} else if (*ldvt < m) {
*info = -12;
} else if (*ldu2 < n) {
*info = -15;
} else if (*ldvt2 < m) {
*info = -17;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLASD2", &i__1);
return 0;
}
nlp1 = *nl + 1;
nlp2 = *nl + 2;
/* Generate the first part of the vector Z; and move the singular */
/* values in the first part of D one position backward. */
z1 = *alpha * vt[nlp1 + nlp1 * vt_dim1];
z__[1] = z1;
for (i__ = *nl; i__ >= 1; --i__) {
z__[i__ + 1] = *alpha * vt[i__ + nlp1 * vt_dim1];
d__[i__ + 1] = d__[i__];
idxq[i__ + 1] = idxq[i__] + 1;
/* L10: */
}
/* Generate the second part of the vector Z. */
i__1 = m;
for (i__ = nlp2; i__ <= i__1; ++i__) {
z__[i__] = *beta * vt[i__ + nlp2 * vt_dim1];
/* L20: */
}
/* Initialize some reference arrays. */
i__1 = nlp1;
for (i__ = 2; i__ <= i__1; ++i__) {
coltyp[i__] = 1;
/* L30: */
}
i__1 = n;
for (i__ = nlp2; i__ <= i__1; ++i__) {
coltyp[i__] = 2;
/* L40: */
}
/* Sort the singular values into increasing order */
i__1 = n;
for (i__ = nlp2; i__ <= i__1; ++i__) {
idxq[i__] += nlp1;
/* L50: */
}
/* DSIGMA, IDXC, IDXC, and the first column of U2 */
/* are used as storage space. */
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
dsigma[i__] = d__[idxq[i__]];
u2[i__ + u2_dim1] = z__[idxq[i__]];
idxc[i__] = coltyp[idxq[i__]];
/* L60: */
}
dlamrg_(nl, nr, &dsigma[2], &c__1, &c__1, &idx[2]);
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
idxi = idx[i__] + 1;
d__[i__] = dsigma[idxi];
z__[i__] = u2[idxi + u2_dim1];
coltyp[i__] = idxc[idxi];
/* L70: */
}
/* Calculate the allowable deflation tolerance */
eps = dlamch_("Epsilon");
/* Computing MAX */
d__1 = abs(*alpha), d__2 = abs(*beta);
tol = max(d__1,d__2);
/* Computing MAX */
d__2 = (d__1 = d__[n], abs(d__1));
tol = eps * 8. * max(d__2,tol);
/* There are 2 kinds of deflation -- first a value in the z-vector */
/* is small, second two (or more) singular values are very close */
/* together (their difference is small). */
/* If the value in the z-vector is small, we simply permute the */
/* array so that the corresponding singular value is moved to the */
/* end. */
/* If two values in the D-vector are close, we perform a two-sided */
/* rotation designed to make one of the corresponding z-vector */
/* entries zero, and then permute the array so that the deflated */
/* singular value is moved to the end. */
/* If there are multiple singular values then the problem deflates. */
/* Here the number of equal singular values are found. As each equal */
/* singular value is found, an elementary reflector is computed to */
/* rotate the corresponding singular subspace so that the */
/* corresponding components of Z are zero in this new basis. */
*k = 1;
k2 = n + 1;
i__1 = n;
for (j = 2; j <= i__1; ++j) {
if ((d__1 = z__[j], abs(d__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
idxp[k2] = j;
coltyp[j] = 4;
if (j == n) {
goto L120;
}
} else {
jprev = j;
goto L90;
}
/* L80: */
}
L90:
j = jprev;
L100:
++j;
if (j > n) {
goto L110;
}
if ((d__1 = z__[j], abs(d__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
idxp[k2] = j;
coltyp[j] = 4;
} else {
/* Check if singular values are close enough to allow deflation. */
if ((d__1 = d__[j] - d__[jprev], abs(d__1)) <= tol) {
/* Deflation is possible. */
s = z__[jprev];
c__ = z__[j];
/* Find sqrt(a**2+b**2) without overflow or */
/* destructive underflow. */
tau = dlapy2_(&c__, &s);
c__ /= tau;
s = -s / tau;
z__[j] = tau;
z__[jprev] = 0.;
/* Apply back the Givens rotation to the left and right */
/* singular vector matrices. */
idxjp = idxq[idx[jprev] + 1];
idxj = idxq[idx[j] + 1];
if (idxjp <= nlp1) {
--idxjp;
}
if (idxj <= nlp1) {
--idxj;
}
drot_(&n, &u[idxjp * u_dim1 + 1], &c__1, &u[idxj * u_dim1 + 1], &
c__1, &c__, &s);
drot_(&m, &vt[idxjp + vt_dim1], ldvt, &vt[idxj + vt_dim1], ldvt, &
c__, &s);
if (coltyp[j] != coltyp[jprev]) {
coltyp[j] = 3;
}
coltyp[jprev] = 4;
--k2;
idxp[k2] = jprev;
jprev = j;
} else {
++(*k);
u2[*k + u2_dim1] = z__[jprev];
dsigma[*k] = d__[jprev];
idxp[*k] = jprev;
jprev = j;
}
}
goto L100;
L110:
/* Record the last singular value. */
++(*k);
u2[*k + u2_dim1] = z__[jprev];
dsigma[*k] = d__[jprev];
idxp[*k] = jprev;
L120:
/* Count up the total number of the various types of columns, then */
/* form a permutation which positions the four column types into */
/* four groups of uniform structure (although one or more of these */
/* groups may be empty). */
for (j = 1; j <= 4; ++j) {
ctot[j - 1] = 0;
/* L130: */
}
i__1 = n;
for (j = 2; j <= i__1; ++j) {
ct = coltyp[j];
++ctot[ct - 1];
/* L140: */
}
/* PSM(*) = Position in SubMatrix (of types 1 through 4) */
psm[0] = 2;
psm[1] = ctot[0] + 2;
psm[2] = psm[1] + ctot[1];
psm[3] = psm[2] + ctot[2];
/* Fill out the IDXC array so that the permutation which it induces */
/* will place all type-1 columns first, all type-2 columns next, */
/* then all type-3's, and finally all type-4's, starting from the */
/* second column. This applies similarly to the rows of VT. */
i__1 = n;
for (j = 2; j <= i__1; ++j) {
jp = idxp[j];
ct = coltyp[jp];
idxc[psm[ct - 1]] = j;
++psm[ct - 1];
/* L150: */
}
/* Sort the singular values and corresponding singular vectors into */
/* DSIGMA, U2, and VT2 respectively. The singular values/vectors */
/* which were not deflated go into the first K slots of DSIGMA, U2, */
/* and VT2 respectively, while those which were deflated go into the */
/* last N - K slots, except that the first column/row will be treated */
/* separately. */
i__1 = n;
for (j = 2; j <= i__1; ++j) {
jp = idxp[j];
dsigma[j] = d__[jp];
idxj = idxq[idx[idxp[idxc[j]]] + 1];
if (idxj <= nlp1) {
--idxj;
}
dcopy_(&n, &u[idxj * u_dim1 + 1], &c__1, &u2[j * u2_dim1 + 1], &c__1);
dcopy_(&m, &vt[idxj + vt_dim1], ldvt, &vt2[j + vt2_dim1], ldvt2);
/* L160: */
}
/* Determine DSIGMA(1), DSIGMA(2) and Z(1) */
dsigma[1] = 0.;
hlftol = tol / 2.;
if (abs(dsigma[2]) <= hlftol) {
dsigma[2] = hlftol;
}
if (m > n) {
z__[1] = dlapy2_(&z1, &z__[m]);
if (z__[1] <= tol) {
c__ = 1.;
s = 0.;
z__[1] = tol;
} else {
c__ = z1 / z__[1];
s = z__[m] / z__[1];
}
} else {
if (abs(z1) <= tol) {
z__[1] = tol;
} else {
z__[1] = z1;
}
}
/* Move the rest of the updating row to Z. */
i__1 = *k - 1;
dcopy_(&i__1, &u2[u2_dim1 + 2], &c__1, &z__[2], &c__1);
/* Determine the first column of U2, the first row of VT2 and the */
/* last row of VT. */
dlaset_("A", &n, &c__1, &c_b30, &c_b30, &u2[u2_offset], ldu2);
u2[nlp1 + u2_dim1] = 1.;
if (m > n) {
i__1 = nlp1;
for (i__ = 1; i__ <= i__1; ++i__) {
vt[m + i__ * vt_dim1] = -s * vt[nlp1 + i__ * vt_dim1];
vt2[i__ * vt2_dim1 + 1] = c__ * vt[nlp1 + i__ * vt_dim1];
/* L170: */
}
i__1 = m;
for (i__ = nlp2; i__ <= i__1; ++i__) {
vt2[i__ * vt2_dim1 + 1] = s * vt[m + i__ * vt_dim1];
vt[m + i__ * vt_dim1] = c__ * vt[m + i__ * vt_dim1];
/* L180: */
}
} else {
dcopy_(&m, &vt[nlp1 + vt_dim1], ldvt, &vt2[vt2_dim1 + 1], ldvt2);
}
if (m > n) {
dcopy_(&m, &vt[m + vt_dim1], ldvt, &vt2[m + vt2_dim1], ldvt2);
}
/* The deflated singular values and their corresponding vectors go */
/* into the back of D, U, and V respectively. */
if (n > *k) {
i__1 = n - *k;
dcopy_(&i__1, &dsigma[*k + 1], &c__1, &d__[*k + 1], &c__1);
i__1 = n - *k;
dlacpy_("A", &n, &i__1, &u2[(*k + 1) * u2_dim1 + 1], ldu2, &u[(*k + 1)
* u_dim1 + 1], ldu);
i__1 = n - *k;
dlacpy_("A", &i__1, &m, &vt2[*k + 1 + vt2_dim1], ldvt2, &vt[*k + 1 +
vt_dim1], ldvt);
}
/* Copy CTOT into COLTYP for referencing in DLASD3. */
for (j = 1; j <= 4; ++j) {
coltyp[j] = ctot[j - 1];
/* L190: */
}
return 0;
/* End of DLASD2 */
} /* dlasd2_ */
/* Subroutine */ int dgegs_(char *jobvsl, char *jobvsr, integer *n,
doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
alphar, doublereal *alphai, doublereal *beta, doublereal *vsl,
integer *ldvsl, doublereal *vsr, integer *ldvsr, doublereal *work,
integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
vsr_dim1, vsr_offset, i__1, i__2;
/* Local variables */
integer nb, nb1, nb2, nb3, ihi, ilo;
doublereal eps, anrm, bnrm;
integer itau, lopt;
extern logical lsame_(char *, char *);
integer ileft, iinfo, icols;
logical ilvsl;
integer iwork;
logical ilvsr;
integer irows;
extern /* Subroutine */ int dggbak_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, integer *), dggbal_(char *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dgghrd_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *), dlascl_(char *, integer *, integer *, doublereal
*, doublereal *, integer *, integer *, doublereal *, integer *,
integer *);
logical ilascl, ilbscl;
extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *),
dlacpy_(char *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *);
doublereal safmin;
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
doublereal bignum;
extern /* Subroutine */ int dhgeqz_(char *, char *, char *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *);
integer ijobvl, iright, ijobvr;
extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *);
doublereal anrmto;
integer lwkmin;
doublereal bnrmto;
extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *);
doublereal smlnum;
integer lwkopt;
logical lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* This routine is deprecated and has been replaced by routine DGGES. */
/* DGEGS computes the eigenvalues, real Schur form, and, optionally, */
/* left and or/right Schur vectors of a real matrix pair (A,B). */
/* Given two square matrices A and B, the generalized real Schur */
/* factorization has the form */
/* A = Q*S*Z**T, B = Q*T*Z**T */
/* where Q and Z are orthogonal matrices, T is upper triangular, and S */
/* is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal */
/* blocks, the 2-by-2 blocks corresponding to complex conjugate pairs */
/* of eigenvalues of (A,B). The columns of Q are the left Schur vectors */
/* and the columns of Z are the right Schur vectors. */
/* If only the eigenvalues of (A,B) are needed, the driver routine */
/* DGEGV should be used instead. See DGEGV for a description of the */
/* eigenvalues of the generalized nonsymmetric eigenvalue problem */
/* (GNEP). */
/* Arguments */
/* ========= */
/* JOBVSL (input) CHARACTER*1 */
/* = 'N': do not compute the left Schur vectors; */
/* = 'V': compute the left Schur vectors (returned in VSL). */
/* JOBVSR (input) CHARACTER*1 */
/* = 'N': do not compute the right Schur vectors; */
/* = 'V': compute the right Schur vectors (returned in VSR). */
/* N (input) INTEGER */
/* The order of the matrices A, B, VSL, and VSR. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
/* On entry, the matrix A. */
/* On exit, the upper quasi-triangular matrix S from the */
/* generalized real Schur factorization. */
/* LDA (input) INTEGER */
/* The leading dimension of A. LDA >= max(1,N). */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */
/* On entry, the matrix B. */
/* On exit, the upper triangular matrix T from the generalized */
/* real Schur factorization. */
/* LDB (input) INTEGER */
/* The leading dimension of B. LDB >= max(1,N). */
/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */
/* The real parts of each scalar alpha defining an eigenvalue */
/* of GNEP. */
/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */
/* The imaginary parts of each scalar alpha defining an */
/* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th */
/* eigenvalue is real; if positive, then the j-th and (j+1)-st */
/* eigenvalues are a complex conjugate pair, with */
/* ALPHAI(j+1) = -ALPHAI(j). */
/* BETA (output) DOUBLE PRECISION array, dimension (N) */
/* The scalars beta that define the eigenvalues of GNEP. */
/* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and */
/* beta = BETA(j) represent the j-th eigenvalue of the matrix */
/* pair (A,B), in one of the forms lambda = alpha/beta or */
/* mu = beta/alpha. Since either lambda or mu may overflow, */
/* they should not, in general, be computed. */
/* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N) */
/* If JOBVSL = 'V', the matrix of left Schur vectors Q. */
/* Not referenced if JOBVSL = 'N'. */
/* LDVSL (input) INTEGER */
/* The leading dimension of the matrix VSL. LDVSL >=1, and */
/* if JOBVSL = 'V', LDVSL >= N. */
/* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N) */
/* If JOBVSR = 'V', the matrix of right Schur vectors Z. */
/* Not referenced if JOBVSR = 'N'. */
/* LDVSR (input) INTEGER */
/* The leading dimension of the matrix VSR. LDVSR >= 1, and */
/* if JOBVSR = 'V', LDVSR >= N. */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,4*N). */
/* For good performance, LWORK must generally be larger. */
/* To compute the optimal value of LWORK, call ILAENV to get */
/* blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute: */
/* NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR */
/* The optimal LWORK is 2*N + N*(NB+1). */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* = 1,...,N: */
/* The QZ iteration failed. (A,B) are not in Schur */
/* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should */
/* be correct for j=INFO+1,...,N. */
/* > N: errors that usually indicate LAPACK problems: */
/* =N+1: error return from DGGBAL */
/* =N+2: error return from DGEQRF */
/* =N+3: error return from DORMQR */
/* =N+4: error return from DORGQR */
/* =N+5: error return from DGGHRD */
/* =N+6: error return from DHGEQZ (other than failed */
/* iteration) */
/* =N+7: error return from DGGBAK (computing VSL) */
/* =N+8: error return from DGGBAK (computing VSR) */
/* =N+9: error return from DLASCL (various places) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--alphar;
--alphai;
--beta;
vsl_dim1 = *ldvsl;
vsl_offset = 1 + vsl_dim1;
vsl -= vsl_offset;
vsr_dim1 = *ldvsr;
vsr_offset = 1 + vsr_dim1;
vsr -= vsr_offset;
--work;
/* Function Body */
if (lsame_(jobvsl, "N")) {
ijobvl = 1;
ilvsl = FALSE_;
} else if (lsame_(jobvsl, "V")) {
ijobvl = 2;
ilvsl = TRUE_;
} else {
ijobvl = -1;
ilvsl = FALSE_;
}
if (lsame_(jobvsr, "N")) {
ijobvr = 1;
ilvsr = FALSE_;
} else if (lsame_(jobvsr, "V")) {
ijobvr = 2;
ilvsr = TRUE_;
} else {
ijobvr = -1;
ilvsr = FALSE_;
}
/* Test the input arguments */
/* Computing MAX */
i__1 = *n << 2;
lwkmin = max(i__1,1);
lwkopt = lwkmin;
work[1] = (doublereal) lwkopt;
lquery = *lwork == -1;
*info = 0;
if (ijobvl <= 0) {
*info = -1;
} else if (ijobvr <= 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
} else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
*info = -12;
} else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
*info = -14;
} else if (*lwork < lwkmin && ! lquery) {
*info = -16;
}
if (*info == 0) {
nb1 = ilaenv_(&c__1, "DGEQRF", " ", n, n, &c_n1, &c_n1);
nb2 = ilaenv_(&c__1, "DORMQR", " ", n, n, n, &c_n1);
nb3 = ilaenv_(&c__1, "DORGQR", " ", n, n, n, &c_n1);
/* Computing MAX */
i__1 = max(nb1,nb2);
nb = max(i__1,nb3);
lopt = (*n << 1) + *n * (nb + 1);
work[1] = (doublereal) lopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEGS ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = dlamch_("E") * dlamch_("B");
safmin = dlamch_("S");
smlnum = *n * safmin / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]);
ilascl = FALSE_;
if (anrm > 0. && anrm < smlnum) {
anrmto = smlnum;
ilascl = TRUE_;
} else if (anrm > bignum) {
anrmto = bignum;
ilascl = TRUE_;
}
if (ilascl) {
dlascl_("G", &c_n1, &c_n1, &anrm, &anrmto, n, n, &a[a_offset], lda, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]);
ilbscl = FALSE_;
if (bnrm > 0. && bnrm < smlnum) {
bnrmto = smlnum;
ilbscl = TRUE_;
} else if (bnrm > bignum) {
bnrmto = bignum;
ilbscl = TRUE_;
}
if (ilbscl) {
dlascl_("G", &c_n1, &c_n1, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
/* Permute the matrix to make it more nearly triangular */
/* Workspace layout: (2*N words -- "work..." not actually used) */
/* left_permutation, right_permutation, work... */
ileft = 1;
iright = *n + 1;
iwork = iright + *n;
dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[
ileft], &work[iright], &work[iwork], &iinfo);
if (iinfo != 0) {
*info = *n + 1;
goto L10;
}
/* Reduce B to triangular form, and initialize VSL and/or VSR */
/* Workspace layout: ("work..." must have at least N words) */
/* left_permutation, right_permutation, tau, work... */
irows = ihi + 1 - ilo;
icols = *n + 1 - ilo;
itau = iwork;
iwork = itau + irows;
i__1 = *lwork + 1 - iwork;
dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 2;
goto L10;
}
i__1 = *lwork + 1 - iwork;
dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, &
iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 3;
goto L10;
}
if (ilvsl) {
dlaset_("Full", n, n, &c_b36, &c_b37, &vsl[vsl_offset], ldvsl);
i__1 = irows - 1;
i__2 = irows - 1;
dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[ilo
+ 1 + ilo * vsl_dim1], ldvsl);
i__1 = *lwork + 1 - iwork;
dorgqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, &
work[itau], &work[iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 4;
goto L10;
}
}
if (ilvsr) {
dlaset_("Full", n, n, &c_b36, &c_b37, &vsr[vsr_offset], ldvsr);
}
/* Reduce to generalized Hessenberg form */
dgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &iinfo);
if (iinfo != 0) {
*info = *n + 5;
goto L10;
}
/* Perform QZ algorithm, computing Schur vectors if desired */
/* Workspace layout: ("work..." must have at least 1 word) */
/* left_permutation, right_permutation, work... */
iwork = itau;
i__1 = *lwork + 1 - iwork;
dhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[
b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset]
, ldvsl, &vsr[vsr_offset], ldvsr, &work[iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
if (iinfo > 0 && iinfo <= *n) {
*info = iinfo;
} else if (iinfo > *n && iinfo <= *n << 1) {
*info = iinfo - *n;
} else {
*info = *n + 6;
}
goto L10;
}
/* Apply permutation to VSL and VSR */
if (ilvsl) {
dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[
vsl_offset], ldvsl, &iinfo);
if (iinfo != 0) {
*info = *n + 7;
goto L10;
}
}
if (ilvsr) {
dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[
vsr_offset], ldvsr, &iinfo);
if (iinfo != 0) {
*info = *n + 8;
goto L10;
}
}
/* Undo scaling */
if (ilascl) {
dlascl_("H", &c_n1, &c_n1, &anrmto, &anrm, n, n, &a[a_offset], lda, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
dlascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alphar[1], n, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
dlascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alphai[1], n, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
if (ilbscl) {
dlascl_("U", &c_n1, &c_n1, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
dlascl_("G", &c_n1, &c_n1, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
L10:
work[1] = (doublereal) lwkopt;
return 0;
/* End of DGEGS */
} /* dgegs_ */
/* Subroutine */ int dchkbd_(integer *nsizes, integer *mval, integer *nval,
integer *ntypes, logical *dotype, integer *nrhs, integer *iseed,
doublereal *thresh, doublereal *a, integer *lda, doublereal *bd,
doublereal *be, doublereal *s1, doublereal *s2, doublereal *x,
integer *ldx, doublereal *y, doublereal *z__, doublereal *q, integer *
ldq, doublereal *pt, integer *ldpt, doublereal *u, doublereal *vt,
doublereal *work, integer *lwork, integer *iwork, integer *nout,
integer *info)
{
/* Initialized data */
static integer ktype[16] = { 1,2,4,4,4,4,4,6,6,6,6,6,9,9,9,10 };
static integer kmagn[16] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3,0 };
static integer kmode[16] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0,0 };
/* Format strings */
static char fmt_9998[] = "(\002 DCHKBD: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002M=\002,i6,\002, N=\002,i6,\002, JTYPE=\002,i"
"6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, type "
"\002,i2,\002, seed=\002,4(i4,\002,\002),\002 test(\002,i2,\002)"
"=\002,g11.4)";
/* System generated locals */
integer a_dim1, a_offset, pt_dim1, pt_offset, q_dim1, q_offset, u_dim1,
u_offset, vt_dim1, vt_offset, x_dim1, x_offset, y_dim1, y_offset,
z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double log(doublereal), sqrt(doublereal), exp(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, j, m, n, mq;
doublereal dum[1], ulp, cond;
integer jcol;
char path[3];
integer idum[1], mmax, nmax;
doublereal unfl, ovfl;
char uplo[1];
doublereal temp1, temp2;
extern /* Subroutine */ int dbdt01_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *)
, dbdt02_(integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *);
logical badmm;
extern /* Subroutine */ int dbdt03_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *);
logical badnn;
integer nfail;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
integer imode;
doublereal dumma[1];
integer iinfo;
extern /* Subroutine */ int dort01_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *);
doublereal anorm;
integer mnmin;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
integer mnmax, jsize, itype, jtype, ntest;
extern /* Subroutine */ int dlahd2_(integer *, char *);
integer log2ui;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
logical bidiag;
extern /* Subroutine */ int dbdsdc_(char *, char *, integer *, doublereal
*, doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *), dgebrd_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *);
extern doublereal dlamch_(char *), dlarnd_(integer *, integer *);
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *);
integer ioldsd[4];
extern /* Subroutine */ int dbdsqr_(char *, integer *, integer *, integer
*, integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *), dorgbr_(char *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), xerbla_(char *, integer *), alasum_(
char *, integer *, integer *, integer *, integer *),
dlatmr_(integer *, integer *, char *, integer *, char *,
doublereal *, integer *, doublereal *, doublereal *, char *, char
*, doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, char *, integer *, integer *, integer *,
doublereal *, doublereal *, char *, doublereal *, integer *,
integer *, integer *), dlatms_(integer *, integer *, char *, integer *, char *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *, char *, doublereal *, integer *, doublereal *, integer
*);
doublereal amninv;
integer minwrk;
doublereal rtunfl, rtovfl, ulpinv, result[19];
integer mtypes;
/* Fortran I/O blocks */
static cilist io___39 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___53 = { 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 */
/* ======= */
/* DCHKBD checks the singular value decomposition (SVD) routines. */
/* DGEBRD reduces a real general m by n matrix A to upper or lower */
/* bidiagonal form B by an orthogonal transformation: Q' * A * P = B */
/* (or A = Q * B * P'). The matrix B is upper bidiagonal if m >= n */
/* and lower bidiagonal if m < n. */
/* DORGBR generates the orthogonal matrices Q and P' from DGEBRD. */
/* Note that Q and P are not necessarily square. */
/* DBDSQR computes the singular value decomposition of the bidiagonal */
/* matrix B as B = U S V'. It is called three times to compute */
/* 1) B = U S1 V', where S1 is the diagonal matrix of singular */
/* values and the columns of the matrices U and V are the left */
/* and right singular vectors, respectively, of B. */
/* 2) Same as 1), but the singular values are stored in S2 and the */
/* singular vectors are not computed. */
/* 3) A = (UQ) S (P'V'), the SVD of the original matrix A. */
/* In addition, DBDSQR has an option to apply the left orthogonal matrix */
/* U to a matrix X, useful in least squares applications. */
/* DBDSDC computes the singular value decomposition of the bidiagonal */
/* matrix B as B = U S V' using divide-and-conquer. It is called twice */
/* to compute */
/* 1) B = U S1 V', where S1 is the diagonal matrix of singular */
/* values and the columns of the matrices U and V are the left */
/* and right singular vectors, respectively, of B. */
/* 2) Same as 1), but the singular values are stored in S2 and the */
/* singular vectors are not computed. */
/* For each pair of matrix dimensions (M,N) and each selected matrix */
/* type, an M by N matrix A and an M by NRHS matrix X are generated. */
/* The problem dimensions are as follows */
/* A: M x N */
/* Q: M x min(M,N) (but M x M if NRHS > 0) */
/* P: min(M,N) x N */
/* B: min(M,N) x min(M,N) */
/* U, V: min(M,N) x min(M,N) */
/* S1, S2 diagonal, order min(M,N) */
/* X: M x NRHS */
/* For each generated matrix, 14 tests are performed: */
/* Test DGEBRD and DORGBR */
/* (1) | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P' */
/* (2) | I - Q' Q | / ( M ulp ) */
/* (3) | I - PT PT' | / ( N ulp ) */
/* Test DBDSQR on bidiagonal matrix B */
/* (4) | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V' */
/* (5) | Y - U Z | / ( |Y| max(min(M,N),k) ulp ), where Y = Q' X */
/* and Z = U' Y. */
/* (6) | I - U' U | / ( min(M,N) ulp ) */
/* (7) | I - VT VT' | / ( min(M,N) ulp ) */
/* (8) S1 contains min(M,N) nonnegative values in decreasing order. */
/* (Return 0 if true, 1/ULP if false.) */
/* (9) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without */
/* computing U and V. */
/* (10) 0 if the true singular values of B are within THRESH of */
/* those in S1. 2*THRESH if they are not. (Tested using */
/* DSVDCH) */
/* Test DBDSQR on matrix A */
/* (11) | A - (QU) S (VT PT) | / ( |A| max(M,N) ulp ) */
/* (12) | X - (QU) Z | / ( |X| max(M,k) ulp ) */
/* (13) | I - (QU)'(QU) | / ( M ulp ) */
/* (14) | I - (VT PT) (PT'VT') | / ( N ulp ) */
/* Test DBDSDC on bidiagonal matrix B */
/* (15) | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V' */
/* (16) | I - U' U | / ( min(M,N) ulp ) */
/* (17) | I - VT VT' | / ( min(M,N) ulp ) */
/* (18) S1 contains min(M,N) nonnegative values in decreasing order. */
/* (Return 0 if true, 1/ULP if false.) */
/* (19) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without */
/* computing U and V. */
/* The possible matrix types are */
/* (1) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A diagonal matrix with evenly spaced entries */
/* 1, ..., ULP and random signs. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (4) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random signs. */
/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random signs. */
/* (6) Same as (3), but multiplied by SQRT( overflow threshold ) */
/* (7) Same as (3), but multiplied by SQRT( underflow threshold ) */
/* (8) A matrix of the form U D V, where U and V are orthogonal and */
/* D has evenly spaced entries 1, ..., ULP with random signs */
/* on the diagonal. */
/* (9) A matrix of the form U D V, where U and V are orthogonal and */
/* D has geometrically spaced entries 1, ..., ULP with random */
/* signs on the diagonal. */
/* (10) A matrix of the form U D V, where U and V are orthogonal and */
/* D has "clustered" entries 1, ULP,..., ULP with random */
/* signs on the diagonal. */
/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
/* (13) Rectangular matrix with random entries chosen from (-1,1). */
/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
/* Special case: */
/* (16) A bidiagonal matrix with random entries chosen from a */
/* logarithmic distribution on [ulp^2,ulp^(-2)] (I.e., each */
/* entry is e^x, where x is chosen uniformly on */
/* [ 2 log(ulp), -2 log(ulp) ] .) For *this* type: */
/* (a) DGEBRD is not called to reduce it to bidiagonal form. */
/* (b) the bidiagonal is min(M,N) x min(M,N); if M<N, the */
/* matrix will be lower bidiagonal, otherwise upper. */
/* (c) only tests 5--8 and 14 are performed. */
/* A subset of the full set of matrix types may be selected through */
/* the logical array DOTYPE. */
/* Arguments */
/* ========== */
/* NSIZES (input) INTEGER */
/* The number of values of M and N contained in the vectors */
/* MVAL and NVAL. The matrix sizes are used in pairs (M,N). */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* NVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix column dimension N. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. If it is zero, DCHKBD */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrices are in A and B. */
/* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size (m,n), a matrix */
/* of type j will be generated. If NTYPES is smaller than the */
/* maximum number of types defined (PARAMETER MAXTYP), then */
/* types NTYPES+1 through MAXTYP will not be generated. If */
/* NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through */
/* DOTYPE(NTYPES) will be ignored. */
/* NRHS (input) INTEGER */
/* The number of columns in the "right-hand side" matrices X, Y, */
/* and Z, used in testing DBDSQR. If NRHS = 0, then the */
/* operations on the right-hand side will not be tested. */
/* NRHS must be at least 0. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The values of ISEED are changed on exit, and can be */
/* used in the next call to DCHKBD to continue the same random */
/* number sequence. */
/* 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. Note that the */
/* expected value of the test ratios is O(1), so THRESH should */
/* be a reasonably small multiple of 1, e.g., 10 or 100. */
/* A (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) */
/* where NMAX is the maximum value of N in NVAL. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,MMAX), */
/* where MMAX is the maximum value of M in MVAL. */
/* BD (workspace) DOUBLE PRECISION array, dimension */
/* (max(min(MVAL(j),NVAL(j)))) */
/* BE (workspace) DOUBLE PRECISION array, dimension */
/* (max(min(MVAL(j),NVAL(j)))) */
/* S1 (workspace) DOUBLE PRECISION array, dimension */
/* (max(min(MVAL(j),NVAL(j)))) */
/* S2 (workspace) DOUBLE PRECISION array, dimension */
/* (max(min(MVAL(j),NVAL(j)))) */
/* X (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* LDX (input) INTEGER */
/* The leading dimension of the arrays X, Y, and Z. */
/* LDX >= max(1,MMAX) */
/* Y (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* Z (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* Q (workspace) DOUBLE PRECISION array, dimension (LDQ,MMAX) */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= max(1,MMAX). */
/* PT (workspace) DOUBLE PRECISION array, dimension (LDPT,NMAX) */
/* LDPT (input) INTEGER */
/* The leading dimension of the arrays PT, U, and V. */
/* LDPT >= max(1, max(min(MVAL(j),NVAL(j)))). */
/* U (workspace) DOUBLE PRECISION array, dimension */
/* (LDPT,max(min(MVAL(j),NVAL(j)))) */
/* V (workspace) DOUBLE PRECISION array, dimension */
/* (LDPT,max(min(MVAL(j),NVAL(j)))) */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* 3(M+N) and M(M + max(M,N,k) + 1) + N*min(M,N) for all */
/* pairs (M,N)=(MM(j),NN(j)) */
/* IWORK (workspace) INTEGER array, dimension at least 8*min(M,N) */
/* NOUT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* INFO (output) INTEGER */
/* If 0, then everything ran OK. */
/* -1: NSIZES < 0 */
/* -2: Some MM(j) < 0 */
/* -3: Some NN(j) < 0 */
/* -4: NTYPES < 0 */
/* -6: NRHS < 0 */
/* -8: THRESH < 0 */
/* -11: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ). */
/* -17: LDB < 1 or LDB < MMAX. */
/* -21: LDQ < 1 or LDQ < MMAX. */
/* -23: LDPT< 1 or LDPT< MNMAX. */
/* -27: LWORK too small. */
/* If DLATMR, SLATMS, DGEBRD, DORGBR, or DBDSQR, */
/* returns an error code, the */
/* absolute value of it is returned. */
/* ----------------------------------------------------------------------- */
/* Some Local Variables and Parameters: */
/* ---- ----- --------- --- ---------- */
/* ZERO, ONE Real 0 and 1. */
/* MAXTYP The number of types defined. */
/* NTEST The number of tests performed, or which can */
/* be performed so far, for the current matrix. */
/* MMAX Largest value in NN. */
/* NMAX Largest value in NN. */
/* MNMIN min(MM(j), NN(j)) (the dimension of the bidiagonal */
/* matrix.) */
/* MNMAX The maximum value of MNMIN for j=1,...,NSIZES. */
/* NFAIL The number of tests which have exceeded THRESH */
/* COND, IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* The following four arrays decode JTYPE: */
/* KTYPE(j) The general type (1-10) for type "j". */
/* KMODE(j) The MODE value to be passed to the matrix */
/* generator for type "j". */
/* KMAGN(j) The order of magnitude ( O(1), */
/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
/* ====================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--mval;
--nval;
--dotype;
--iseed;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--bd;
--be;
--s1;
--s2;
z_dim1 = *ldx;
z_offset = 1 + z_dim1;
z__ -= z_offset;
y_dim1 = *ldx;
y_offset = 1 + y_dim1;
y -= y_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
vt_dim1 = *ldpt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
u_dim1 = *ldpt;
u_offset = 1 + u_dim1;
u -= u_offset;
pt_dim1 = *ldpt;
pt_offset = 1 + pt_dim1;
pt -= pt_offset;
--work;
--iwork;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
*info = 0;
badmm = FALSE_;
badnn = FALSE_;
mmax = 1;
nmax = 1;
mnmax = 1;
minwrk = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = mmax, i__3 = mval[j];
mmax = max(i__2,i__3);
if (mval[j] < 0) {
badmm = TRUE_;
}
/* Computing MAX */
i__2 = nmax, i__3 = nval[j];
nmax = max(i__2,i__3);
if (nval[j] < 0) {
badnn = TRUE_;
}
/* Computing MAX */
/* Computing MIN */
i__4 = mval[j], i__5 = nval[j];
i__2 = mnmax, i__3 = min(i__4,i__5);
mnmax = max(i__2,i__3);
/* Computing MAX */
/* Computing MAX */
i__4 = mval[j], i__5 = nval[j], i__4 = max(i__4,i__5);
/* Computing MIN */
i__6 = nval[j], i__7 = mval[j];
i__2 = minwrk, i__3 = (mval[j] + nval[j]) * 3, i__2 = max(i__2,i__3),
i__3 = mval[j] * (mval[j] + max(i__4,*nrhs) + 1) + nval[j] *
min(i__6,i__7);
minwrk = max(i__2,i__3);
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badmm) {
*info = -2;
} else if (badnn) {
*info = -3;
} else if (*ntypes < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -6;
} else if (*lda < mmax) {
*info = -11;
} else if (*ldx < mmax) {
*info = -17;
} else if (*ldq < mmax) {
*info = -21;
} else if (*ldpt < mnmax) {
*info = -23;
} else if (minwrk > *lwork) {
*info = -27;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DCHKBD", &i__1);
return 0;
}
/* Initialize constants */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "BD", (ftnlen)2, (ftnlen)2);
nfail = 0;
ntest = 0;
unfl = dlamch_("Safe minimum");
ovfl = dlamch_("Overflow");
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision");
ulpinv = 1. / ulp;
log2ui = (integer) (log(ulpinv) / log(2.));
rtunfl = sqrt(unfl);
rtovfl = sqrt(ovfl);
infoc_1.infot = 0;
/* Loop over sizes, types */
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
m = mval[jsize];
n = nval[jsize];
mnmin = min(m,n);
/* Computing MAX */
i__2 = max(m,n);
amninv = 1. / max(i__2,1);
if (*nsizes != 1) {
mtypes = min(16,*ntypes);
} else {
mtypes = min(17,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L190;
}
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
for (j = 1; j <= 14; ++j) {
result[j - 1] = -1.;
/* L30: */
}
*(unsigned char *)uplo = ' ';
/* Compute "A" */
/* Control parameters: */
/* KMAGN KMODE KTYPE */
/* =1 O(1) clustered 1 zero */
/* =2 large clustered 2 identity */
/* =3 small exponential (none) */
/* =4 arithmetic diagonal, (w/ eigenvalues) */
/* =5 random symmetric, w/ eigenvalues */
/* =6 nonsymmetric, w/ singular values */
/* =7 random diagonal */
/* =8 random symmetric */
/* =9 random nonsymmetric */
/* =10 random bidiagonal (log. distrib.) */
if (mtypes > 16) {
goto L100;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L40;
case 2: goto L50;
case 3: goto L60;
}
L40:
anorm = 1.;
goto L70;
L50:
anorm = rtovfl * ulp * amninv;
goto L70;
L60:
anorm = rtunfl * max(m,n) * ulpinv;
goto L70;
L70:
dlaset_("Full", lda, &n, &c_b20, &c_b20, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
bidiag = FALSE_;
if (itype == 1) {
/* Zero matrix */
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = mnmin;
for (jcol = 1; jcol <= i__3; ++jcol) {
a[jcol + jcol * a_dim1] = anorm;
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
dlatms_(&mnmin, &mnmin, "S", &iseed[1], "N", &work[1], &imode,
&cond, &anorm, &c__0, &c__0, "N", &a[a_offset], lda,
&work[mnmin + 1], &iinfo);
} else if (itype == 5) {
/* Symmetric, eigenvalues specified */
dlatms_(&mnmin, &mnmin, "S", &iseed[1], "S", &work[1], &imode,
&cond, &anorm, &m, &n, "N", &a[a_offset], lda, &work[
mnmin + 1], &iinfo);
} else if (itype == 6) {
/* Nonsymmetric, singular values specified */
dlatms_(&m, &n, "S", &iseed[1], "N", &work[1], &imode, &cond,
&anorm, &m, &n, "N", &a[a_offset], lda, &work[mnmin +
1], &iinfo);
} else if (itype == 7) {
/* Diagonal, random entries */
dlatmr_(&mnmin, &mnmin, "S", &iseed[1], "N", &work[1], &c__6,
&c_b37, &c_b37, "T", "N", &work[mnmin + 1], &c__1, &
c_b37, &work[(mnmin << 1) + 1], &c__1, &c_b37, "N", &
iwork[1], &c__0, &c__0, &c_b20, &anorm, "NO", &a[
a_offset], lda, &iwork[1], &iinfo);
} else if (itype == 8) {
/* Symmetric, random entries */
dlatmr_(&mnmin, &mnmin, "S", &iseed[1], "S", &work[1], &c__6,
&c_b37, &c_b37, "T", "N", &work[mnmin + 1], &c__1, &
c_b37, &work[m + mnmin + 1], &c__1, &c_b37, "N", &
iwork[1], &m, &n, &c_b20, &anorm, "NO", &a[a_offset],
lda, &iwork[1], &iinfo);
} else if (itype == 9) {
/* Nonsymmetric, random entries */
dlatmr_(&m, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b37,
&c_b37, "T", "N", &work[mnmin + 1], &c__1, &c_b37, &
work[m + mnmin + 1], &c__1, &c_b37, "N", &iwork[1], &
m, &n, &c_b20, &anorm, "NO", &a[a_offset], lda, &
iwork[1], &iinfo);
} else if (itype == 10) {
/* Bidiagonal, random entries */
temp1 = log(ulp) * -2.;
i__3 = mnmin;
for (j = 1; j <= i__3; ++j) {
bd[j] = exp(temp1 * dlarnd_(&c__2, &iseed[1]));
if (j < mnmin) {
be[j] = exp(temp1 * dlarnd_(&c__2, &iseed[1]));
}
/* L90: */
}
iinfo = 0;
bidiag = TRUE_;
if (m >= n) {
*(unsigned char *)uplo = 'U';
} else {
*(unsigned char *)uplo = 'L';
}
} else {
iinfo = 1;
}
if (iinfo == 0) {
/* Generate Right-Hand Side */
if (bidiag) {
dlatmr_(&mnmin, nrhs, "S", &iseed[1], "N", &work[1], &
c__6, &c_b37, &c_b37, "T", "N", &work[mnmin + 1],
&c__1, &c_b37, &work[(mnmin << 1) + 1], &c__1, &
c_b37, "N", &iwork[1], &mnmin, nrhs, &c_b20, &
c_b37, "NO", &y[y_offset], ldx, &iwork[1], &iinfo);
} else {
dlatmr_(&m, nrhs, "S", &iseed[1], "N", &work[1], &c__6, &
c_b37, &c_b37, "T", "N", &work[m + 1], &c__1, &
c_b37, &work[(m << 1) + 1], &c__1, &c_b37, "N", &
iwork[1], &m, nrhs, &c_b20, &c_b37, "NO", &x[
x_offset], ldx, &iwork[1], &iinfo);
}
}
/* Error Exit */
if (iinfo != 0) {
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L100:
/* Call DGEBRD and DORGBR to compute B, Q, and P, do tests. */
if (! bidiag) {
/* Compute transformations to reduce A to bidiagonal form: */
/* B := Q' * A * P. */
dlacpy_(" ", &m, &n, &a[a_offset], lda, &q[q_offset], ldq);
i__3 = *lwork - (mnmin << 1);
dgebrd_(&m, &n, &q[q_offset], ldq, &bd[1], &be[1], &work[1], &
work[mnmin + 1], &work[(mnmin << 1) + 1], &i__3, &
iinfo);
/* Check error code from DGEBRD. */
if (iinfo != 0) {
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, "DGEBRD", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
return 0;
}
dlacpy_(" ", &m, &n, &q[q_offset], ldq, &pt[pt_offset], ldpt);
if (m >= n) {
*(unsigned char *)uplo = 'U';
} else {
*(unsigned char *)uplo = 'L';
}
/* Generate Q */
mq = m;
if (*nrhs <= 0) {
mq = mnmin;
}
i__3 = *lwork - (mnmin << 1);
dorgbr_("Q", &m, &mq, &n, &q[q_offset], ldq, &work[1], &work[(
mnmin << 1) + 1], &i__3, &iinfo);
/* Check error code from DORGBR. */
if (iinfo != 0) {
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, "DORGBR(Q)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
return 0;
}
/* Generate P' */
i__3 = *lwork - (mnmin << 1);
dorgbr_("P", &mnmin, &n, &m, &pt[pt_offset], ldpt, &work[
mnmin + 1], &work[(mnmin << 1) + 1], &i__3, &iinfo);
/* Check error code from DORGBR. */
if (iinfo != 0) {
io___43.ciunit = *nout;
s_wsfe(&io___43);
do_fio(&c__1, "DORGBR(P)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
return 0;
}
/* Apply Q' to an M by NRHS matrix X: Y := Q' * X. */
dgemm_("Transpose", "No transpose", &m, nrhs, &m, &c_b37, &q[
q_offset], ldq, &x[x_offset], ldx, &c_b20, &y[
y_offset], ldx);
/* Test 1: Check the decomposition A := Q * B * PT */
/* 2: Check the orthogonality of Q */
/* 3: Check the orthogonality of PT */
dbdt01_(&m, &n, &c__1, &a[a_offset], lda, &q[q_offset], ldq, &
bd[1], &be[1], &pt[pt_offset], ldpt, &work[1], result)
;
dort01_("Columns", &m, &mq, &q[q_offset], ldq, &work[1],
lwork, &result[1]);
dort01_("Rows", &mnmin, &n, &pt[pt_offset], ldpt, &work[1],
lwork, &result[2]);
}
/* Use DBDSQR to form the SVD of the bidiagonal matrix B: */
/* B := U * S1 * VT, and compute Z = U' * Y. */
dcopy_(&mnmin, &bd[1], &c__1, &s1[1], &c__1);
if (mnmin > 0) {
i__3 = mnmin - 1;
dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
}
dlacpy_(" ", &m, nrhs, &y[y_offset], ldx, &z__[z_offset], ldx);
dlaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &u[u_offset],
ldpt);
dlaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &vt[vt_offset],
ldpt);
dbdsqr_(uplo, &mnmin, &mnmin, &mnmin, nrhs, &s1[1], &work[1], &vt[
vt_offset], ldpt, &u[u_offset], ldpt, &z__[z_offset], ldx,
&work[mnmin + 1], &iinfo);
/* Check error code from DBDSQR. */
if (iinfo != 0) {
io___44.ciunit = *nout;
s_wsfe(&io___44);
do_fio(&c__1, "DBDSQR(vects)", (ftnlen)13);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
return 0;
} else {
result[3] = ulpinv;
goto L170;
}
}
/* Use DBDSQR to compute only the singular values of the */
/* bidiagonal matrix B; U, VT, and Z should not be modified. */
dcopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
if (mnmin > 0) {
i__3 = mnmin - 1;
dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
}
dbdsqr_(uplo, &mnmin, &c__0, &c__0, &c__0, &s2[1], &work[1], &vt[
vt_offset], ldpt, &u[u_offset], ldpt, &z__[z_offset], ldx,
&work[mnmin + 1], &iinfo);
/* Check error code from DBDSQR. */
if (iinfo != 0) {
io___45.ciunit = *nout;
s_wsfe(&io___45);
do_fio(&c__1, "DBDSQR(values)", (ftnlen)14);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
return 0;
} else {
result[8] = ulpinv;
goto L170;
}
}
/* Test 4: Check the decomposition B := U * S1 * VT */
/* 5: Check the computation Z := U' * Y */
/* 6: Check the orthogonality of U */
/* 7: Check the orthogonality of VT */
dbdt03_(uplo, &mnmin, &c__1, &bd[1], &be[1], &u[u_offset], ldpt, &
s1[1], &vt[vt_offset], ldpt, &work[1], &result[3]);
dbdt02_(&mnmin, nrhs, &y[y_offset], ldx, &z__[z_offset], ldx, &u[
u_offset], ldpt, &work[1], &result[4]);
dort01_("Columns", &mnmin, &mnmin, &u[u_offset], ldpt, &work[1],
lwork, &result[5]);
dort01_("Rows", &mnmin, &mnmin, &vt[vt_offset], ldpt, &work[1],
lwork, &result[6]);
/* Test 8: Check that the singular values are sorted in */
/* non-increasing order and are non-negative */
result[7] = 0.;
i__3 = mnmin - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
if (s1[i__] < s1[i__ + 1]) {
result[7] = ulpinv;
}
if (s1[i__] < 0.) {
result[7] = ulpinv;
}
/* L110: */
}
if (mnmin >= 1) {
if (s1[mnmin] < 0.) {
result[7] = ulpinv;
}
}
/* Test 9: Compare DBDSQR with and without singular vectors */
temp2 = 0.;
i__3 = mnmin;
for (j = 1; j <= i__3; ++j) {
/* Computing MAX */
/* Computing MAX */
d__6 = (d__1 = s1[j], abs(d__1)), d__7 = (d__2 = s2[j], abs(
d__2));
d__4 = sqrt(unfl) * max(s1[1],1.), d__5 = ulp * max(d__6,d__7)
;
temp1 = (d__3 = s1[j] - s2[j], abs(d__3)) / max(d__4,d__5);
temp2 = max(temp1,temp2);
/* L120: */
}
result[8] = temp2;
/* Test 10: Sturm sequence test of singular values */
/* Go up by factors of two until it succeeds */
temp1 = *thresh * (.5 - ulp);
i__3 = log2ui;
for (j = 0; j <= i__3; ++j) {
/* CALL DSVDCH( MNMIN, BD, BE, S1, TEMP1, IINFO ) */
if (iinfo == 0) {
goto L140;
}
temp1 *= 2.;
/* L130: */
}
L140:
result[9] = temp1;
/* Use DBDSQR to form the decomposition A := (QU) S (VT PT) */
/* from the bidiagonal form A := Q B PT. */
if (! bidiag) {
dcopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
if (mnmin > 0) {
i__3 = mnmin - 1;
dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
}
dbdsqr_(uplo, &mnmin, &n, &m, nrhs, &s2[1], &work[1], &pt[
pt_offset], ldpt, &q[q_offset], ldq, &y[y_offset],
ldx, &work[mnmin + 1], &iinfo);
/* Test 11: Check the decomposition A := Q*U * S2 * VT*PT */
/* 12: Check the computation Z := U' * Q' * X */
/* 13: Check the orthogonality of Q*U */
/* 14: Check the orthogonality of VT*PT */
dbdt01_(&m, &n, &c__0, &a[a_offset], lda, &q[q_offset], ldq, &
s2[1], dumma, &pt[pt_offset], ldpt, &work[1], &result[
10]);
dbdt02_(&m, nrhs, &x[x_offset], ldx, &y[y_offset], ldx, &q[
q_offset], ldq, &work[1], &result[11]);
dort01_("Columns", &m, &mq, &q[q_offset], ldq, &work[1],
lwork, &result[12]);
dort01_("Rows", &mnmin, &n, &pt[pt_offset], ldpt, &work[1],
lwork, &result[13]);
}
/* Use DBDSDC to form the SVD of the bidiagonal matrix B: */
/* B := U * S1 * VT */
dcopy_(&mnmin, &bd[1], &c__1, &s1[1], &c__1);
if (mnmin > 0) {
i__3 = mnmin - 1;
dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
}
dlaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &u[u_offset],
ldpt);
dlaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &vt[vt_offset],
ldpt);
dbdsdc_(uplo, "I", &mnmin, &s1[1], &work[1], &u[u_offset], ldpt, &
vt[vt_offset], ldpt, dum, idum, &work[mnmin + 1], &iwork[
1], &iinfo);
/* Check error code from DBDSDC. */
if (iinfo != 0) {
io___51.ciunit = *nout;
s_wsfe(&io___51);
do_fio(&c__1, "DBDSDC(vects)", (ftnlen)13);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
return 0;
} else {
result[14] = ulpinv;
goto L170;
}
}
/* Use DBDSDC to compute only the singular values of the */
/* bidiagonal matrix B; U and VT should not be modified. */
dcopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
if (mnmin > 0) {
i__3 = mnmin - 1;
dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
}
dbdsdc_(uplo, "N", &mnmin, &s2[1], &work[1], dum, &c__1, dum, &
c__1, dum, idum, &work[mnmin + 1], &iwork[1], &iinfo);
/* Check error code from DBDSDC. */
if (iinfo != 0) {
io___52.ciunit = *nout;
s_wsfe(&io___52);
do_fio(&c__1, "DBDSDC(values)", (ftnlen)14);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
return 0;
} else {
result[17] = ulpinv;
goto L170;
}
}
/* Test 15: Check the decomposition B := U * S1 * VT */
/* 16: Check the orthogonality of U */
/* 17: Check the orthogonality of VT */
dbdt03_(uplo, &mnmin, &c__1, &bd[1], &be[1], &u[u_offset], ldpt, &
s1[1], &vt[vt_offset], ldpt, &work[1], &result[14]);
dort01_("Columns", &mnmin, &mnmin, &u[u_offset], ldpt, &work[1],
lwork, &result[15]);
dort01_("Rows", &mnmin, &mnmin, &vt[vt_offset], ldpt, &work[1],
lwork, &result[16]);
/* Test 18: Check that the singular values are sorted in */
/* non-increasing order and are non-negative */
result[17] = 0.;
i__3 = mnmin - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
if (s1[i__] < s1[i__ + 1]) {
result[17] = ulpinv;
}
if (s1[i__] < 0.) {
result[17] = ulpinv;
}
/* L150: */
}
if (mnmin >= 1) {
if (s1[mnmin] < 0.) {
result[17] = ulpinv;
}
}
/* Test 19: Compare DBDSQR with and without singular vectors */
temp2 = 0.;
i__3 = mnmin;
for (j = 1; j <= i__3; ++j) {
/* Computing MAX */
/* Computing MAX */
d__4 = abs(s1[1]), d__5 = abs(s2[1]);
d__2 = sqrt(unfl) * max(s1[1],1.), d__3 = ulp * max(d__4,d__5)
;
temp1 = (d__1 = s1[j] - s2[j], abs(d__1)) / max(d__2,d__3);
temp2 = max(temp1,temp2);
/* L160: */
}
result[18] = temp2;
/* End of Loop -- Check for RESULT(j) > THRESH */
L170:
for (j = 1; j <= 19; ++j) {
if (result[j - 1] >= *thresh) {
if (nfail == 0) {
dlahd2_(nout, path);
}
io___53.ciunit = *nout;
s_wsfe(&io___53);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L180: */
}
if (! bidiag) {
ntest += 19;
} else {
ntest += 5;
}
L190:
;
}
/* L200: */
}
/* Summary */
alasum_(path, nout, &nfail, &ntest, &c__0);
return 0;
/* End of DCHKBD */
} /* dchkbd_ */
/* Subroutine */ int dget36_(doublereal *rmax, integer *lmax, integer *ninfo,
integer *knt, integer *nin)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
double d_sign(doublereal *, doublereal *);
/* Local variables */
integer i__, j, n;
doublereal q[100] /* was [10][10] */, t1[100] /* was [10][10] */,
t2[100] /* was [10][10] */;
integer loc;
doublereal eps, res, tmp[100] /* was [10][10] */;
integer ifst, ilst;
doublereal work[200];
integer info1, info2, ifst1, ifst2, ilst1, ilst2;
extern /* Subroutine */ int dhst01_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *), dtrexc_(char *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, integer *);
integer ifstsv;
doublereal result[2];
integer ilstsv;
/* Fortran I/O blocks */
static cilist io___2 = { 0, 0, 0, 0, 0 };
static cilist io___7 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGET36 tests DTREXC, a routine for moving blocks (either 1 by 1 or */
/* 2 by 2) on the diagonal of a matrix in real Schur form. Thus, DLAEXC */
/* computes an orthogonal matrix Q such that */
/* Q' * T1 * Q = T2 */
/* and where one of the diagonal blocks of T1 (the one at row IFST) has */
/* been moved to position ILST. */
/* The test code verifies that the residual Q'*T1*Q-T2 is small, that T2 */
/* is in Schur form, and that the final position of the IFST block is */
/* ILST (within +-1). */
/* The test matrices are read from a file with logical unit number NIN. */
/* Arguments */
/* ========== */
/* RMAX (output) DOUBLE PRECISION */
/* Value of the largest test ratio. */
/* LMAX (output) INTEGER */
/* Example number where largest test ratio achieved. */
/* NINFO (output) INTEGER array, dimension (3) */
/* NINFO(J) is the number of examples where INFO=J. */
/* KNT (output) INTEGER */
/* Total number of examples tested. */
/* NIN (input) INTEGER */
/* Input logical unit number. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--ninfo;
/* Function Body */
eps = dlamch_("P");
*rmax = 0.;
*lmax = 0;
*knt = 0;
ninfo[1] = 0;
ninfo[2] = 0;
ninfo[3] = 0;
/* Read input data until N=0 */
L10:
io___2.ciunit = *nin;
s_rsle(&io___2);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ifst, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ilst, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
return 0;
}
++(*knt);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___7.ciunit = *nin;
s_rsle(&io___7);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&tmp[i__ + j * 10 - 11], (ftnlen)
sizeof(doublereal));
}
e_rsle();
/* L20: */
}
dlacpy_("F", &n, &n, tmp, &c__10, t1, &c__10);
dlacpy_("F", &n, &n, tmp, &c__10, t2, &c__10);
ifstsv = ifst;
ilstsv = ilst;
ifst1 = ifst;
ilst1 = ilst;
ifst2 = ifst;
ilst2 = ilst;
res = 0.;
/* Test without accumulating Q */
dlaset_("Full", &n, &n, &c_b21, &c_b22, q, &c__10);
dtrexc_("N", &n, t1, &c__10, q, &c__10, &ifst1, &ilst1, work, &info1);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
if (i__ == j && q[i__ + j * 10 - 11] != 1.) {
res += 1. / eps;
}
if (i__ != j && q[i__ + j * 10 - 11] != 0.) {
res += 1. / eps;
}
/* L30: */
}
/* L40: */
}
/* Test with accumulating Q */
dlaset_("Full", &n, &n, &c_b21, &c_b22, q, &c__10);
dtrexc_("V", &n, t2, &c__10, q, &c__10, &ifst2, &ilst2, work, &info2);
/* Compare T1 with T2 */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
if (t1[i__ + j * 10 - 11] != t2[i__ + j * 10 - 11]) {
res += 1. / eps;
}
/* L50: */
}
/* L60: */
}
if (ifst1 != ifst2) {
res += 1. / eps;
}
if (ilst1 != ilst2) {
res += 1. / eps;
}
if (info1 != info2) {
res += 1. / eps;
}
/* Test for successful reordering of T2 */
if (info2 != 0) {
++ninfo[info2];
} else {
if ((i__1 = ifst2 - ifstsv, abs(i__1)) > 1) {
res += 1. / eps;
}
if ((i__1 = ilst2 - ilstsv, abs(i__1)) > 1) {
res += 1. / eps;
}
}
/* Test for small residual, and orthogonality of Q */
dhst01_(&n, &c__1, &n, tmp, &c__10, t2, &c__10, q, &c__10, work, &c__200,
result);
res = res + result[0] + result[1];
/* Test for T2 being in Schur form */
loc = 1;
L70:
if (t2[loc + 1 + loc * 10 - 11] != 0.) {
/* 2 by 2 block */
if (t2[loc + (loc + 1) * 10 - 11] == 0. || t2[loc + loc * 10 - 11] !=
t2[loc + 1 + (loc + 1) * 10 - 11] || d_sign(&c_b22, &t2[loc +
(loc + 1) * 10 - 11]) == d_sign(&c_b22, &t2[loc + 1 + loc *
10 - 11])) {
res += 1. / eps;
}
i__1 = n;
for (i__ = loc + 2; i__ <= i__1; ++i__) {
if (t2[i__ + loc * 10 - 11] != 0.) {
res += 1. / res;
}
if (t2[i__ + (loc + 1) * 10 - 11] != 0.) {
res += 1. / res;
}
/* L80: */
}
loc += 2;
} else {
/* 1 by 1 block */
i__1 = n;
for (i__ = loc + 1; i__ <= i__1; ++i__) {
if (t2[i__ + loc * 10 - 11] != 0.) {
res += 1. / res;
}
/* L90: */
}
++loc;
}
if (loc < n) {
goto L70;
}
if (res > *rmax) {
*rmax = res;
*lmax = *knt;
}
goto L10;
/* End of DGET36 */
} /* dget36_ */
/* Subroutine */ int dchkpb_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nns, integer *nsval,
doublereal *thresh, logical *tsterr, integer *nmax, doublereal *a,
doublereal *afac, doublereal *ainv, doublereal *b, doublereal *x,
doublereal *xact, doublereal *work, doublereal *rwork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
"=\002,i5,\002, NB=\002,i4,\002, type \002,i2,\002, test \002,i2"
",\002, ratio= \002,g12.5)";
static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
"=\002,i5,\002, NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i"
"2,\002) = \002,g12.5)";
static char fmt_9997[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
"=\002,i5,\002,\002,10x,\002 type \002,i2,\002, test(\002,i2,\002"
") = \002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6;
/* 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 ldab, ioff, mode, koff, imat, info;
static char path[3], dist[1];
static integer irhs, nrhs;
static char uplo[1], type__[1];
static integer nrun, i__;
extern /* Subroutine */ int alahd_(integer *, char *);
static integer k, n;
extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *);
static integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
extern /* Subroutine */ int dpbt01_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *), dpbt02_(char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *),
dpbt05_(char *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *);
static integer kdval[4];
static doublereal rcond;
static integer nimat;
static doublereal anorm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
static integer iuplo, izero, i1, i2, nerrs;
static logical zerot;
static char xtype[1];
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *);
static integer kd, nb, in, kl;
extern doublereal dlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static integer iw, ku;
extern doublereal dlansb_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dpbcon_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *);
static doublereal rcondc;
static char packit[1];
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlarhs_(char *, char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *), dlaset_(char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *), dpbrfs_(char *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *), dpbtrf_(char *,
integer *, integer *, doublereal *, integer *, integer *),
alasum_(char *, integer *, integer *, integer *, integer *);
static doublereal cndnum;
extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublereal *, integer *, doublereal
*, integer *);
static doublereal ainvnm;
extern /* Subroutine */ int derrpo_(char *, integer *), dpbtrs_(
char *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *), xlaenv_(integer *,
integer *);
static doublereal result[7];
static integer lda, ikd, inb, nkd;
/* Fortran I/O blocks */
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
December 7, 1999
Purpose
=======
DCHKPB tests DPBTRF, -TRS, -RFS, and -CON.
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.
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 dimension N.
NNB (input) INTEGER
The number of values of NB contained in the vector NBVAL.
NBVAL (input) INTEGER array, dimension (NBVAL)
The values of the blocksize NB.
NNS (input) INTEGER
The number of values of NRHS contained in the vector NSVAL.
NSVAL (input) INTEGER array, dimension (NNS)
The values of the number of right hand sides NRHS.
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.
NMAX (input) INTEGER
The maximum value permitted for N, used in dimensioning the
work arrays.
A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
where NSMAX is the largest entry in NSVAL.
X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
WORK (workspace) DOUBLE PRECISION array, dimension
(NMAX*max(3,NSMAX))
RWORK (workspace) DOUBLE PRECISION array, dimension
(max(NMAX,2*NSMAX))
IWORK (workspace) INTEGER array, dimension (NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nbval;
--nval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "PB", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
derrpo_(path, nout);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
kdval[0] = 0;
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
/* Set limits on the number of loop iterations.
Computing MAX */
i__2 = 1, i__3 = min(n,4);
nkd = max(i__2,i__3);
nimat = 8;
if (n == 0) {
nimat = 1;
}
kdval[1] = n + (n + 1) / 4;
kdval[2] = (n * 3 - 1) / 4;
kdval[3] = (n + 1) / 4;
i__2 = nkd;
for (ikd = 1; ikd <= i__2; ++ikd) {
/* Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order
makes it easier to skip redundant values for small values
of N. */
kd = kdval[ikd - 1];
ldab = kd + 1;
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
koff = 1;
if (iuplo == 1) {
*(unsigned char *)uplo = 'U';
/* Computing MAX */
i__3 = 1, i__4 = kd + 2 - n;
koff = max(i__3,i__4);
*(unsigned char *)packit = 'Q';
} else {
*(unsigned char *)uplo = 'L';
*(unsigned char *)packit = 'B';
}
i__3 = nimat;
for (imat = 1; imat <= i__3; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L60;
}
/* Skip types 2, 3, or 4 if the matrix size is too small. */
zerot = imat >= 2 && imat <= 4;
if (zerot && n < imat - 1) {
goto L60;
}
if (! zerot || ! dotype[1]) {
/* Set up parameters with DLATB4 and generate a test
matrix with DLATMS. */
dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm,
&mode, &cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)6, (ftnlen)
6);
dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode,
&cndnum, &anorm, &kd, &kd, packit, &a[koff],
&ldab, &work[1], &info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &
n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
nout);
goto L60;
}
} else if (izero > 0) {
/* Use the same matrix for types 3 and 4 as for type
2 by copying back the zeroed out column, */
iw = (lda << 1) + 1;
if (iuplo == 1) {
ioff = (izero - 1) * ldab + kd + 1;
i__4 = izero - i1;
dcopy_(&i__4, &work[iw], &c__1, &a[ioff - izero +
i1], &c__1);
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
dcopy_(&i__4, &work[iw], &c__1, &a[ioff], &i__5);
} else {
ioff = (i1 - 1) * ldab + 1;
i__4 = izero - i1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
dcopy_(&i__4, &work[iw], &c__1, &a[ioff + izero -
i1], &i__5);
ioff = (izero - 1) * ldab + 1;
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
dcopy_(&i__4, &work[iw], &c__1, &a[ioff], &c__1);
}
}
/* For types 2-4, zero one row and column of the matrix
to test that INFO is returned correctly. */
izero = 0;
if (zerot) {
if (imat == 2) {
izero = 1;
} else if (imat == 3) {
izero = n;
} else {
izero = n / 2 + 1;
}
/* Save the zeroed out row and column in WORK(*,3) */
iw = lda << 1;
/* Computing MIN */
i__5 = (kd << 1) + 1;
i__4 = min(i__5,n);
for (i__ = 1; i__ <= i__4; ++i__) {
work[iw + i__] = 0.;
/* L20: */
}
++iw;
/* Computing MAX */
i__4 = izero - kd;
i1 = max(i__4,1);
/* Computing MIN */
i__4 = izero + kd;
i2 = min(i__4,n);
if (iuplo == 1) {
ioff = (izero - 1) * ldab + kd + 1;
i__4 = izero - i1;
dswap_(&i__4, &a[ioff - izero + i1], &c__1, &work[
iw], &c__1);
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
dswap_(&i__4, &a[ioff], &i__5, &work[iw], &c__1);
} else {
ioff = (i1 - 1) * ldab + 1;
i__4 = izero - i1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
dswap_(&i__4, &a[ioff + izero - i1], &i__5, &work[
iw], &c__1);
ioff = (izero - 1) * ldab + 1;
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
dswap_(&i__4, &a[ioff], &c__1, &work[iw], &c__1);
}
}
/* Do for each value of NB in NBVAL */
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the L*L' or U'*U factorization of the band
matrix. */
i__5 = kd + 1;
dlacpy_("Full", &i__5, &n, &a[1], &ldab, &afac[1], &
ldab);
s_copy(srnamc_1.srnamt, "DPBTRF", (ftnlen)6, (ftnlen)
6);
dpbtrf_(uplo, &n, &kd, &afac[1], &ldab, &info);
/* Check error code from DPBTRF. */
if (info != izero) {
alaerh_(path, "DPBTRF", &info, &izero, uplo, &n, &
n, &kd, &kd, &nb, &imat, &nfail, &nerrs,
nout);
goto L50;
}
/* Skip the tests if INFO is not 0. */
if (info != 0) {
goto L50;
}
/* + TEST 1
Reconstruct matrix from factors and compute
residual. */
i__5 = kd + 1;
dlacpy_("Full", &i__5, &n, &afac[1], &ldab, &ainv[1],
&ldab);
dpbt01_(uplo, &n, &kd, &a[1], &ldab, &ainv[1], &ldab,
&rwork[1], result);
/* Print the test ratio if it is .GE. THRESH. */
if (result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
/* Only do other tests if this is the first blocksize. */
if (inb > 1) {
goto L50;
}
/* Form the inverse of A so we can get a good estimate
of RCONDC = 1/(norm(A) * norm(inv(A))). */
dlaset_("Full", &n, &n, &c_b50, &c_b51, &ainv[1], &
lda);
s_copy(srnamc_1.srnamt, "DPBTRS", (ftnlen)6, (ftnlen)
6);
dpbtrs_(uplo, &n, &kd, &n, &afac[1], &ldab, &ainv[1],
&lda, &info);
/* Compute RCONDC = 1/(norm(A) * norm(inv(A))). */
anorm = dlansb_("1", uplo, &n, &kd, &a[1], &ldab, &
rwork[1]);
ainvnm = dlange_("1", &n, &n, &ainv[1], &lda, &rwork[
1]);
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
i__5 = *nns;
for (irhs = 1; irhs <= i__5; ++irhs) {
nrhs = nsval[irhs];
/* + TEST 2
Solve and compute residual for A * X = B. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)6, (
ftnlen)6);
dlarhs_(path, xtype, uplo, " ", &n, &n, &kd, &kd,
&nrhs, &a[1], &ldab, &xact[1], &lda, &b[1]
, &lda, iseed, &info);
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "DPBTRS", (ftnlen)6, (
ftnlen)6);
dpbtrs_(uplo, &n, &kd, &nrhs, &afac[1], &ldab, &x[
1], &lda, &info);
/* Check error code from DPBTRS. */
if (info != 0) {
alaerh_(path, "DPBTRS", &info, &c__0, uplo, &
n, &n, &kd, &kd, &nrhs, &imat, &nfail,
&nerrs, nout);
}
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1],
&lda);
dpbt02_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &x[1],
&lda, &work[1], &lda, &rwork[1], &result[
1]);
/* + TEST 3
Check solution from generated exact solution. */
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* + TESTS 4, 5, and 6
Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "DPBRFS", (ftnlen)6, (
ftnlen)6);
dpbrfs_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &afac[
1], &ldab, &b[1], &lda, &x[1], &lda, &
rwork[1], &rwork[nrhs + 1], &work[1], &
iwork[1], &info);
/* Check error code from DPBRFS. */
if (info != 0) {
alaerh_(path, "DPBRFS", &info, &c__0, uplo, &
n, &n, &kd, &kd, &nrhs, &imat, &nfail,
&nerrs, nout);
}
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
dpbt05_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &b[1],
&lda, &x[1], &lda, &xact[1], &lda, &
rwork[1], &rwork[nrhs + 1], &result[4]);
/* Print information about the tests that did not
pass the threshold. */
for (k = 2; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&imat, (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;
}
/* L30: */
}
nrun += 5;
/* L40: */
}
/* + TEST 7
Get an estimate of RCOND = 1/CNDNUM. */
s_copy(srnamc_1.srnamt, "DPBCON", (ftnlen)6, (ftnlen)
6);
dpbcon_(uplo, &n, &kd, &afac[1], &ldab, &anorm, &
rcond, &work[1], &iwork[1], &info);
/* Check error code from DPBCON. */
if (info != 0) {
alaerh_(path, "DPBCON", &info, &c__0, uplo, &n, &
n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
nout);
}
result[6] = dget06_(&rcond, &rcondc);
/* Print the test ratio if it is .GE. THRESH. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___48.ciunit = *nout;
s_wsfe(&io___48);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
L50:
;
}
L60:
;
}
/* L70: */
}
/* L80: */
}
/* L90: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKPB */
} /* dchkpb_ */
/* Subroutine */ int ddrvsx_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *niunit,
integer *nounit, doublereal *a, integer *lda, doublereal *h__,
doublereal *ht, doublereal *wr, doublereal *wi, doublereal *wrt,
doublereal *wit, doublereal *wrtmp, doublereal *witmp, doublereal *vs,
integer *ldvs, doublereal *vs1, doublereal *result, doublereal *work,
integer *lwork, integer *iwork, logical *bwork, integer *info)
{
/* Initialized data */
static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
/* Format strings */
static char fmt_9991[] = "(\002 DDRVSX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9999[] = "(/1x,a3,\002 -- Real Schur Form Decomposition "
"Expert \002,\002Driver\002,/\002 Matrix types (see DDRVSX for de"
"tails):\002)";
static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
"rix. \002,\002 \002,\002 5=Diagonal: geom"
"etr. spaced entries.\002,/\002 2=Identity matrix. "
" \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
"/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
" 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
"l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
"ll, evenly spaced.\002)";
static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
" 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
"l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
"d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
"red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
"vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
" 12=Well-cond., random complex \002,\002 \002,\002 17=Il"
"l-cond., large rand. complx \002,/\002 13=Ill-condi\002,\002tion"
"ed, evenly spaced. \002,\002 18=Ill-cond., small rand.\002"
",\002 complx \002)";
static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
" \002,\002 21=Matrix \002,\002with small random entries.\002,"
"/\002 20=Matrix with large ran\002,\002dom entries. \002,/)";
static char fmt_9995[] = "(\002 Tests performed with test threshold ="
"\002,f8.2,/\002 ( A denotes A on input and T denotes A on output)"
"\002,//\002 1 = 0 if T in Schur form (no sort), \002,\002 1/ulp"
" otherwise\002,/\002 2 = | A - VS T transpose(VS) | / ( n |A| ul"
"p ) (no sort)\002,/\002 3 = | I - VS transpose(VS) | / ( n ulp )"
" (no sort) \002,/\002 4 = 0 if WR+sqrt(-1)*WI are eigenvalues of"
" T (no sort),\002,\002 1/ulp otherwise\002,/\002 5 = 0 if T sam"
"e no matter if VS computed (no sort),\002,\002 1/ulp otherwis"
"e\002,/\002 6 = 0 if WR, WI same no matter if VS computed (no so"
"rt)\002,\002, 1/ulp otherwise\002)";
static char fmt_9994[] = "(\002 7 = 0 if T in Schur form (sort), \002"
",\002 1/ulp otherwise\002,/\002 8 = | A - VS T transpose(VS) | "
"/ ( n |A| ulp ) (sort)\002,/\002 9 = | I - VS transpose(VS) | / "
"( n ulp ) (sort) \002,/\002 10 = 0 if WR+sqrt(-1)*WI are eigenva"
"lues of T (sort),\002,\002 1/ulp otherwise\002,/\002 11 = 0 if "
"T same no matter what else computed (sort),\002,\002 1/ulp othe"
"rwise\002,/\002 12 = 0 if WR, WI same no matter what else comput"
"ed \002,\002(sort), 1/ulp otherwise\002,/\002 13 = 0 if sorting "
"succesful, 1/ulp otherwise\002,/\002 14 = 0 if RCONDE same no ma"
"tter what else computed,\002,\002 1/ulp otherwise\002,/\002 15 ="
" 0 if RCONDv same no matter what else computed,\002,\002 1/ulp o"
"therwise\002,/\002 16 = | RCONDE - RCONDE(precomputed) | / cond("
"RCONDE),\002,/\002 17 = | RCONDV - RCONDV(precomputed) | / cond("
"RCONDV),\002)";
static char fmt_9993[] = "(\002 N=\002,i5,\002, IWK=\002,i2,\002, seed"
"=\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)="
"\002,g10.3)";
static char fmt_9992[] = "(\002 N=\002,i5,\002, input example =\002,i3"
",\002, test(\002,i2,\002)=\002,g10.3)";
/* System generated locals */
integer a_dim1, a_offset, h_dim1, h_offset, ht_dim1, ht_offset, vs_dim1,
vs_offset, vs1_dim1, vs1_offset, i__1, i__2, i__3, i__4;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Local variables */
static doublereal cond;
static integer jcol;
static char path[3];
static integer nmax;
static doublereal unfl, ovfl;
static integer i__, j, n;
static logical badnn;
static integer nfail;
extern /* Subroutine */ int dget24_(logical *, integer *, doublereal *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *, doublereal *, doublereal *, integer *,
integer *, logical *, integer *);
static integer imode, iinfo;
static doublereal conds, anorm;
static integer islct[20], nslct, jsize, nerrs, itype, jtype, ntest;
static doublereal rtulp;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *);
static doublereal rcdein;
static char adumma[1*1];
extern /* Subroutine */ int dlatme_(integer *, char *, integer *,
doublereal *, integer *, doublereal *, doublereal *, char *, char
*, char *, char *, doublereal *, integer *, doublereal *, integer
*, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *);
static integer idumma[1], ioldsd[4];
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *), dlatmr_(integer *, integer *,
char *, integer *, char *, doublereal *, integer *, doublereal *,
doublereal *, char *, char *, doublereal *, integer *, doublereal
*, doublereal *, integer *, doublereal *, char *, integer *,
integer *, integer *, doublereal *, doublereal *, char *,
doublereal *, integer *, integer *, integer *), dlatms_(integer *, integer *,
char *, integer *, char *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *, char *, doublereal *, integer
*, doublereal *, integer *);
static doublereal rcdvin;
extern /* Subroutine */ int dlasum_(char *, integer *, integer *, integer
*);
static integer ntestf;
static doublereal ulpinv;
static integer nnwork;
static doublereal rtulpi;
static integer mtypes, ntestt, iwk;
static doublereal ulp;
/* Fortran I/O blocks */
static cilist io___32 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___48 = { 0, 0, 1, 0, 0 };
static cilist io___49 = { 0, 0, 0, 0, 0 };
static cilist io___51 = { 0, 0, 0, 0, 0 };
static cilist io___52 = { 0, 0, 0, 0, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9992, 0 };
#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
=======
DDRVSX checks the nonsymmetric eigenvalue (Schur form) problem
expert driver DGEESX.
DDRVSX uses both test matrices generated randomly depending on
data supplied in the calling sequence, as well as on data
read from an input file and including precomputed condition
numbers to which it compares the ones it computes.
When DDRVSX is called, a number of matrix "sizes" ("n's") and a
number of matrix "types" are specified. For each size ("n")
and each type of matrix, one matrix will be generated and used
to test the nonsymmetric eigenroutines. For each matrix, 15
tests will be performed:
(1) 0 if T is in Schur form, 1/ulp otherwise
(no sorting of eigenvalues)
(2) | A - VS T VS' | / ( n |A| ulp )
Here VS is the matrix of Schur eigenvectors, and T is in Schur
form (no sorting of eigenvalues).
(3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues).
(4) 0 if WR+sqrt(-1)*WI are eigenvalues of T
1/ulp otherwise
(no sorting of eigenvalues)
(5) 0 if T(with VS) = T(without VS),
1/ulp otherwise
(no sorting of eigenvalues)
(6) 0 if eigenvalues(with VS) = eigenvalues(without VS),
1/ulp otherwise
(no sorting of eigenvalues)
(7) 0 if T is in Schur form, 1/ulp otherwise
(with sorting of eigenvalues)
(8) | A - VS T VS' | / ( n |A| ulp )
Here VS is the matrix of Schur eigenvectors, and T is in Schur
form (with sorting of eigenvalues).
(9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues).
(10) 0 if WR+sqrt(-1)*WI are eigenvalues of T
1/ulp otherwise
If workspace sufficient, also compare WR, WI with and
without reciprocal condition numbers
(with sorting of eigenvalues)
(11) 0 if T(with VS) = T(without VS),
1/ulp otherwise
If workspace sufficient, also compare T with and without
reciprocal condition numbers
(with sorting of eigenvalues)
(12) 0 if eigenvalues(with VS) = eigenvalues(without VS),
1/ulp otherwise
If workspace sufficient, also compare VS with and without
reciprocal condition numbers
(with sorting of eigenvalues)
(13) if sorting worked and SDIM is the number of
eigenvalues which were SELECTed
If workspace sufficient, also compare SDIM with and
without reciprocal condition numbers
(14) if RCONDE the same no matter if VS and/or RCONDV computed
(15) if RCONDV the same no matter if VS and/or RCONDE computed
The "sizes" are specified by an array NN(1:NSIZES); the value of
each element NN(j) specifies one size.
The "types" are specified by a logical array DOTYPE( 1:NTYPES );
if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
Currently, the list of possible types is:
(1) The zero matrix.
(2) The identity matrix.
(3) A (transposed) Jordan block, with 1's on the diagonal.
(4) A diagonal matrix with evenly spaced entries
1, ..., ULP and random signs.
(ULP = (first number larger than 1) - 1 )
(5) A diagonal matrix with geometrically spaced entries
1, ..., ULP and random signs.
(6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
and random signs.
(7) Same as (4), but multiplied by a constant near
the overflow threshold
(8) Same as (4), but multiplied by a constant near
the underflow threshold
(9) A matrix of the form U' T U, where U is orthogonal and
T has evenly spaced entries 1, ..., ULP with random signs
on the diagonal and random O(1) entries in the upper
triangle.
(10) A matrix of the form U' T U, where U is orthogonal and
T has geometrically spaced entries 1, ..., ULP with random
signs on the diagonal and random O(1) entries in the upper
triangle.
(11) A matrix of the form U' T U, where U is orthogonal and
T has "clustered" entries 1, ULP,..., ULP with random
signs on the diagonal and random O(1) entries in the upper
triangle.
(12) A matrix of the form U' T U, where U is orthogonal and
T has real or complex conjugate paired eigenvalues randomly
chosen from ( ULP, 1 ) and random O(1) entries in the upper
triangle.
(13) A matrix of the form X' T X, where X has condition
SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
with random signs on the diagonal and random O(1) entries
in the upper triangle.
(14) A matrix of the form X' T X, where X has condition
SQRT( ULP ) and T has geometrically spaced entries
1, ..., ULP with random signs on the diagonal and random
O(1) entries in the upper triangle.
(15) A matrix of the form X' T X, where X has condition
SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
with random signs on the diagonal and random O(1) entries
in the upper triangle.
(16) A matrix of the form X' T X, where X has condition
SQRT( ULP ) and T has real or complex conjugate paired
eigenvalues randomly chosen from ( ULP, 1 ) and random
O(1) entries in the upper triangle.
(17) Same as (16), but multiplied by a constant
near the overflow threshold
(18) Same as (16), but multiplied by a constant
near the underflow threshold
(19) Nonsymmetric matrix with random entries chosen from (-1,1).
If N is at least 4, all entries in first two rows and last
row, and first column and last two columns are zero.
(20) Same as (19), but multiplied by a constant
near the overflow threshold
(21) Same as (19), but multiplied by a constant
near the underflow threshold
In addition, an input file will be read from logical unit number
NIUNIT. The file contains matrices along with precomputed
eigenvalues and reciprocal condition numbers for the eigenvalue
average and right invariant subspace. For these matrices, in
addition to tests (1) to (15) we will compute the following two
tests:
(16) |RCONDE - RCDEIN| / cond(RCONDE)
RCONDE is the reciprocal average eigenvalue condition number
computed by DGEESX and RCDEIN (the precomputed true value)
is supplied as input. cond(RCONDE) is the condition number
of RCONDE, and takes errors in computing RCONDE into account,
so that the resulting quantity should be O(ULP). cond(RCONDE)
is essentially given by norm(A)/RCONDV.
(17) |RCONDV - RCDVIN| / cond(RCONDV)
RCONDV is the reciprocal right invariant subspace condition
number computed by DGEESX and RCDVIN (the precomputed true
value) is supplied as input. cond(RCONDV) is the condition
number of RCONDV, and takes errors in computing RCONDV into
account, so that the resulting quantity should be O(ULP).
cond(RCONDV) is essentially given by norm(A)/RCONDE.
Arguments
=========
NSIZES (input) INTEGER
The number of sizes of matrices to use. NSIZES must be at
least zero. If it is zero, no randomly generated matrices
are tested, but any test matrices read from NIUNIT will be
tested.
NN (input) INTEGER array, dimension (NSIZES)
An array containing the sizes to be used for the matrices.
Zero values will be skipped. The values must be at least
zero.
NTYPES (input) INTEGER
The number of elements in DOTYPE. NTYPES must be at least
zero. If it is zero, no randomly generated test matrices
are tested, but and test matrices read from NIUNIT will be
tested. If it is MAXTYP+1 and NSIZES is 1, then an
additional type, MAXTYP+1 is defined, which is to use
whatever matrix is in A. This is only useful if
DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. .
DOTYPE (input) LOGICAL array, dimension (NTYPES)
If DOTYPE(j) is .TRUE., then for each size in NN a
matrix of that size and of type j will be generated.
If NTYPES is smaller than the maximum number of types
defined (PARAMETER MAXTYP), then types NTYPES+1 through
MAXTYP will not be generated. If NTYPES is larger
than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
will be ignored.
ISEED (input/output) INTEGER array, dimension (4)
On entry ISEED specifies the seed of the random number
generator. The array elements should be between 0 and 4095;
if not they will be reduced mod 4096. Also, ISEED(4) must
be odd. The random number generator uses a linear
congruential sequence limited to small integers, and so
should produce machine independent random numbers. The
values of ISEED are changed on exit, and can be used in the
next call to DDRVSX to continue the same random number
sequence.
THRESH (input) DOUBLE PRECISION
A test will count as "failed" if the "error", computed as
described above, exceeds THRESH. Note that the error
is scaled to be O(1), so THRESH should be a reasonably
small multiple of 1, e.g., 10 or 100. In particular,
it should not depend on the precision (single vs. double)
or the size of the matrix. It must be at least zero.
NIUNIT (input) INTEGER
The FORTRAN unit number for reading in the data file of
problems to solve.
NOUNIT (input) INTEGER
The FORTRAN unit number for printing out error messages
(e.g., if a routine returns INFO not equal to 0.)
A (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
Used to hold the matrix whose eigenvalues are to be
computed. On exit, A contains the last matrix actually used.
LDA (input) INTEGER
The leading dimension of A, and H. LDA must be at
least 1 and at least max( NN ).
H (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
Another copy of the test matrix A, modified by DGEESX.
HT (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
Yet another copy of the test matrix A, modified by DGEESX.
WR (workspace) DOUBLE PRECISION array, dimension (max(NN))
WI (workspace) DOUBLE PRECISION array, dimension (max(NN))
The real and imaginary parts of the eigenvalues of A.
On exit, WR + WI*i are the eigenvalues of the matrix in A.
WRT (workspace) DOUBLE PRECISION array, dimension (max(NN))
WIT (workspace) DOUBLE PRECISION array, dimension (max(NN))
Like WR, WI, these arrays contain the eigenvalues of A,
but those computed when DGEESX only computes a partial
eigendecomposition, i.e. not Schur vectors
WRTMP (workspace) DOUBLE PRECISION array, dimension (max(NN))
WITMP (workspace) DOUBLE PRECISION array, dimension (max(NN))
More temporary storage for eigenvalues.
VS (workspace) DOUBLE PRECISION array, dimension (LDVS, max(NN))
VS holds the computed Schur vectors.
LDVS (input) INTEGER
Leading dimension of VS. Must be at least max(1,max(NN)).
VS1 (workspace) DOUBLE PRECISION array, dimension (LDVS, max(NN))
VS1 holds another copy of the computed Schur vectors.
RESULT (output) DOUBLE PRECISION array, dimension (17)
The values computed by the 17 tests described above.
The values are currently limited to 1/ulp, to avoid overflow.
WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
LWORK (input) INTEGER
The number of entries in WORK. This must be at least
max(3*NN(j),2*NN(j)**2) for all j.
IWORK (workspace) INTEGER array, dimension (max(NN)*max(NN))
INFO (output) INTEGER
If 0, successful exit.
<0, input parameter -INFO is incorrect
>0, DLATMR, SLATMS, SLATME or DGET24 returned an error
code and INFO is its absolute value
-----------------------------------------------------------------------
Some Local Variables and Parameters:
---- ----- --------- --- ----------
ZERO, ONE Real 0 and 1.
MAXTYP The number of types defined.
NMAX Largest value in NN.
NERRS The number of tests which have exceeded THRESH
COND, CONDS,
IMODE Values to be passed to the matrix generators.
ANORM Norm of A; passed to matrix generators.
OVFL, UNFL Overflow and underflow thresholds.
ULP, ULPINV Finest relative precision and its inverse.
RTULP, RTULPI Square roots of the previous 4 values.
The following four arrays decode JTYPE:
KTYPE(j) The general type (1-10) for type "j".
KMODE(j) The MODE value to be passed to the matrix
generator for type "j".
KMAGN(j) The order of magnitude ( O(1),
O(overflow^(1/2) ), O(underflow^(1/2) )
KCONDS(j) Selectw whether CONDS is to be 1 or
1/sqrt(ulp). (0 means irrelevant.)
=====================================================================
Parameter adjustments */
--nn;
--dotype;
--iseed;
ht_dim1 = *lda;
ht_offset = 1 + ht_dim1 * 1;
ht -= ht_offset;
h_dim1 = *lda;
h_offset = 1 + h_dim1 * 1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--wr;
--wi;
--wrt;
--wit;
--wrtmp;
--witmp;
vs1_dim1 = *ldvs;
vs1_offset = 1 + vs1_dim1 * 1;
vs1 -= vs1_offset;
vs_dim1 = *ldvs;
vs_offset = 1 + vs_dim1 * 1;
vs -= vs_offset;
--result;
--work;
--iwork;
--bwork;
/* Function Body */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "SX", (ftnlen)2, (ftnlen)2);
/* Check for errors */
ntestt = 0;
ntestf = 0;
*info = 0;
/* Important constants */
badnn = FALSE_;
/* 12 is the largest dimension in the input file of precomputed
problems */
nmax = 12;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*niunit <= 0) {
*info = -7;
} else if (*nounit <= 0) {
*info = -8;
} else if (*lda < 1 || *lda < nmax) {
*info = -10;
} else if (*ldvs < 1 || *ldvs < nmax) {
*info = -20;
} else /* if(complicated condition) */ {
/* Computing MAX
Computing 2nd power */
i__3 = nmax;
i__1 = nmax * 3, i__2 = i__3 * i__3 << 1;
if (max(i__1,i__2) > *lwork) {
*info = -24;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DDRVSX", &i__1);
return 0;
}
/* If nothing to do check on NIUNIT */
if (*nsizes == 0 || *ntypes == 0) {
goto L150;
}
/* More Important constants */
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision");
ulpinv = 1. / ulp;
rtulp = sqrt(ulp);
rtulpi = 1. / rtulp;
/* Loop over sizes, types */
nerrs = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
if (*nsizes != 1) {
mtypes = min(21,*ntypes);
} else {
mtypes = min(22,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L130;
}
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Compute "A"
Control parameters:
KMAGN KCONDS KMODE KTYPE
=1 O(1) 1 clustered 1 zero
=2 large large clustered 2 identity
=3 small exponential Jordan
=4 arithmetic diagonal, (w/ eigenvalues)
=5 random log symmetric, w/ eigenvalues
=6 random general, w/ eigenvalues
=7 random diagonal
=8 random symmetric
=9 random general
=10 random triangular */
if (mtypes > 21) {
goto L90;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L30;
case 2: goto L40;
case 3: goto L50;
}
L30:
anorm = 1.;
goto L60;
L40:
anorm = ovfl * ulp;
goto L60;
L50:
anorm = unfl * ulpinv;
goto L60;
L60:
dlaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
/* Special Matrices -- Identity & Jordan block
Zero */
if (itype == 1) {
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
a_ref(jcol, jcol) = anorm;
/* L70: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
a_ref(jcol, jcol) = anorm;
if (jcol > 1) {
a_ref(jcol, jcol - 1) = 1.;
}
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
&anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ 1], &iinfo);
} else if (itype == 5) {
/* Symmetric, eigenvalues specified */
dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
&anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
&iinfo);
} else if (itype == 6) {
/* General, eigenvalues specified */
if (kconds[jtype - 1] == 1) {
conds = 1.;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.;
}
*(unsigned char *)&adumma[0] = ' ';
dlatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b32,
adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
&iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &c__0, &
c__0, &c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 8) {
/* Symmetric, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
if (n >= 4) {
dlaset_("Full", &c__2, &n, &c_b18, &c_b18, &a[a_offset],
lda);
i__3 = n - 3;
dlaset_("Full", &i__3, &c__1, &c_b18, &c_b18, &a_ref(3, 1)
, lda);
i__3 = n - 3;
dlaset_("Full", &i__3, &c__2, &c_b18, &c_b18, &a_ref(3, n
- 1), lda);
dlaset_("Full", &c__1, &n, &c_b18, &c_b18, &a_ref(n, 1),
lda);
}
} else if (itype == 10) {
/* Triangular, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &c__0, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___32.ciunit = *nounit;
s_wsfe(&io___32);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L90:
/* Test for minimal and generous workspace */
for (iwk = 1; iwk <= 2; ++iwk) {
if (iwk == 1) {
nnwork = n * 3;
} else {
/* Computing MAX */
i__3 = n * 3, i__4 = (n << 1) * n;
nnwork = max(i__3,i__4);
}
nnwork = max(nnwork,1);
dget24_(&c_false, &jtype, thresh, ioldsd, nounit, &n, &a[
a_offset], lda, &h__[h_offset], &ht[ht_offset], &wr[1]
, &wi[1], &wrt[1], &wit[1], &wrtmp[1], &witmp[1], &vs[
vs_offset], ldvs, &vs1[vs1_offset], &rcdein, &rcdvin,
&nslct, islct, &result[1], &work[1], &nnwork, &iwork[
1], &bwork[1], info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 15; ++j) {
if (result[j] >= 0.) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L100: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___42.ciunit = *nounit;
s_wsfe(&io___42);
e_wsfe();
io___43.ciunit = *nounit;
s_wsfe(&io___43);
e_wsfe();
io___44.ciunit = *nounit;
s_wsfe(&io___44);
e_wsfe();
io___45.ciunit = *nounit;
s_wsfe(&io___45);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(
doublereal));
e_wsfe();
io___46.ciunit = *nounit;
s_wsfe(&io___46);
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 15; ++j) {
if (result[j] >= *thresh) {
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
/* L110: */
}
nerrs += nfail;
ntestt += ntest;
/* L120: */
}
L130:
;
}
/* L140: */
}
L150:
/* Read in data from file to check accuracy of condition estimation
Read input data until N=0 */
jtype = 0;
L160:
io___48.ciunit = *niunit;
i__1 = s_rsle(&io___48);
if (i__1 != 0) {
goto L200;
}
i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L200;
}
i__1 = do_lio(&c__3, &c__1, (char *)&nslct, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L200;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L200;
}
if (n == 0) {
goto L200;
}
++jtype;
iseed[1] = jtype;
if (nslct > 0) {
io___49.ciunit = *niunit;
s_rsle(&io___49);
i__1 = nslct;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&islct[i__ - 1], (ftnlen)sizeof(
integer));
}
e_rsle();
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___51.ciunit = *niunit;
s_rsle(&io___51);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&a_ref(i__, j), (ftnlen)sizeof(
doublereal));
}
e_rsle();
/* L170: */
}
io___52.ciunit = *niunit;
s_rsle(&io___52);
do_lio(&c__5, &c__1, (char *)&rcdein, (ftnlen)sizeof(doublereal));
do_lio(&c__5, &c__1, (char *)&rcdvin, (ftnlen)sizeof(doublereal));
e_rsle();
dget24_(&c_true, &c__22, thresh, &iseed[1], nounit, &n, &a[a_offset], lda,
&h__[h_offset], &ht[ht_offset], &wr[1], &wi[1], &wrt[1], &wit[1],
&wrtmp[1], &witmp[1], &vs[vs_offset], ldvs, &vs1[vs1_offset], &
rcdein, &rcdvin, &nslct, islct, &result[1], &work[1], lwork, &
iwork[1], &bwork[1], info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 17; ++j) {
if (result[j] >= 0.) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L180: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___53.ciunit = *nounit;
s_wsfe(&io___53);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___54.ciunit = *nounit;
s_wsfe(&io___54);
e_wsfe();
io___55.ciunit = *nounit;
s_wsfe(&io___55);
e_wsfe();
io___56.ciunit = *nounit;
s_wsfe(&io___56);
e_wsfe();
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(doublereal));
e_wsfe();
io___58.ciunit = *nounit;
s_wsfe(&io___58);
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 17; ++j) {
if (result[j] >= *thresh) {
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(doublereal));
e_wsfe();
}
/* L190: */
}
nerrs += nfail;
ntestt += ntest;
goto L160;
L200:
/* Summary */
dlasum_(path, nounit, &nerrs, &ntestt);
return 0;
/* End of DDRVSX */
} /* ddrvsx_ */
/* Subroutine */ int ddrges_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
doublereal *a, integer *lda, doublereal *b, doublereal *s, doublereal
*t, doublereal *q, integer *ldq, doublereal *z__, doublereal *alphar,
doublereal *alphai, doublereal *beta, doublereal *work, integer *
lwork, doublereal *result, logical *bwork, integer *info)
{
/* Initialized data */
static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
2,2,2,3 };
static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
2,3,2,1 };
static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
1,1,1,1 };
static integer iasign[26] = { 0,0,0,0,0,0,2,0,2,2,0,0,2,2,2,0,2,0,0,0,2,2,
2,2,2,0 };
static integer ibsign[26] = { 0,0,0,0,0,0,0,2,0,0,2,2,0,0,2,0,2,0,0,0,0,0,
0,0,0,0 };
static integer kz1[6] = { 0,1,2,1,3,3 };
static integer kz2[6] = { 0,0,1,2,1,1 };
static integer kadd[6] = { 0,0,0,0,3,2 };
static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
4,4,4,0 };
static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
8,8,8,8,8,0 };
static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
3,3,3,1 };
static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
4,4,4,1 };
static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
3,3,2,1 };
/* Format strings */
static char fmt_9999[] = "(\002 DDRGES: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,4(i4,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 DDRGES: DGET53 returned INFO=\002,i1,"
"\002 for eigenvalue \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JT"
"YPE=\002,i6,\002, ISEED=(\002,4(i4,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(\002 DDRGES: S not in Schur form at eigenvalu"
"e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, "
"ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9996[] = "(/1x,a3,\002 -- Real Generalized Schur form dr"
"iver\002)";
static char fmt_9995[] = "(\002 Matrix types (see DDRGES for details):"
" \002)";
static char fmt_9994[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
"osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
"onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
"I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
"arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
"(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
"=(D, reversed D)\002)";
static char fmt_9993[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
"atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
" 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
"ha&beta \002,\002 20=arithmetic alpha, beta=0,"
"1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
"=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
"/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
"l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
".\002)";
static char fmt_9992[] = "(/\002 Tests performed: (S is Schur, T is tri"
"angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002l and r "
"are the appropriate left and right\002,/19x,\002eigenvectors, re"
"sp., a is alpha, b is beta, and\002,/19x,a,\002 means \002,a,"
"\002.)\002,/\002 Without ordering: \002,/\002 1 = | A - Q S "
"Z\002,a,\002 | / ( |A| n ulp ) 2 = | B - Q T Z\002,a,\002 |"
" / ( |B| n ulp )\002,/\002 3 = | I - QQ\002,a,\002 | / ( n ulp "
") 4 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 5"
" = A is in Schur form S\002,/\002 6 = difference between (alpha"
",beta)\002,\002 and diagonals of (S,T)\002,/\002 With ordering:"
" \002,/\002 7 = | (A,B) - Q (S,T) Z\002,a,\002 | / ( |(A,B)| n "
"ulp ) \002,/\002 8 = | I - QQ\002,a,\002 | / ( n ulp ) "
" 9 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 10 = A is in"
" Schur form S\002,/\002 11 = difference between (alpha,beta) and"
" diagonals\002,\002 of (S,T)\002,/\002 12 = SDIM is the correct "
"number of \002,\002selected eigenvalues\002,/)";
static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",0p,f8.2)";
static char fmt_9990[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",1p,d10.3)";
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1,
s_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2, i__3,
i__4;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10;
/* Local variables */
integer i__, j, n, i1, n1, jc, nb, in, jr;
doublereal ulp;
integer iadd, sdim, ierr, nmax, rsub;
char sort[1];
doublereal temp1, temp2;
logical badnn;
extern /* Subroutine */ int dget51_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *), dget53_(
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *), dget54_(
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *),
dgges_(char *, char *, char *, L_fp, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, logical *, integer *);
integer iinfo;
doublereal rmagn[4];
integer nmats, jsize, nerrs, jtype, ntest, isort;
extern /* Subroutine */ int dlatm4_(integer *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *, doublereal *, integer *), dorm2r_(char *,
char *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *), dlabad_(doublereal *, doublereal *);
logical ilabad;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *);
extern doublereal dlarnd_(integer *, integer *);
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *);
doublereal safmin;
integer ioldsd[4];
doublereal safmax;
integer knteig;
extern logical dlctes_(doublereal *, doublereal *, doublereal *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *), dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *);
integer minwrk, maxwrk;
doublereal ulpinv;
integer mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___60 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___61 = { 0, 0, 0, fmt_9990, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DDRGES checks the nonsymmetric generalized eigenvalue (Schur form) */
/* problem driver DGGES. */
/* DGGES factors A and B as Q S Z' and Q T Z' , where ' means */
/* transpose, T is upper triangular, S is in generalized Schur form */
/* (block upper triangular, with 1x1 and 2x2 blocks on the diagonal, */
/* the 2x2 blocks corresponding to complex conjugate pairs of */
/* generalized eigenvalues), and Q and Z are orthogonal. It also */
/* computes the generalized eigenvalues (alpha(j),beta(j)), j=1,...,n, */
/* Thus, w(j) = alpha(j)/beta(j) is a root of the characteristic */
/* equation */
/* det( A - w(j) B ) = 0 */
/* Optionally it also reorder the eigenvalues so that a selected */
/* cluster of eigenvalues appears in the leading diagonal block of the */
/* Schur forms. */
/* When DDRGES is called, a number of matrix "sizes" ("N's") and a */
/* number of matrix "TYPES" are specified. For each size ("N") */
/* and each TYPE of matrix, a pair of matrices (A, B) will be generated */
/* and used for testing. For each matrix pair, the following 13 tests */
/* will be performed and compared with the threshhold THRESH except */
/* the tests (5), (11) and (13). */
/* (1) | A - Q S Z' | / ( |A| n ulp ) (no sorting of eigenvalues) */
/* (2) | B - Q T Z' | / ( |B| n ulp ) (no sorting of eigenvalues) */
/* (3) | I - QQ' | / ( n ulp ) (no sorting of eigenvalues) */
/* (4) | I - ZZ' | / ( n ulp ) (no sorting of eigenvalues) */
/* (5) if A is in Schur form (i.e. quasi-triangular form) */
/* (no sorting of eigenvalues) */
/* (6) if eigenvalues = diagonal blocks of the Schur form (S, T), */
/* i.e., test the maximum over j of D(j) where: */
/* if alpha(j) is real: */
/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
/* D(j) = ------------------------ + ----------------------- */
/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
/* if alpha(j) is complex: */
/* | det( s S - w T ) | */
/* D(j) = --------------------------------------------------- */
/* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T ) */
/* and S and T are here the 2 x 2 diagonal blocks of S and T */
/* corresponding to the j-th and j+1-th eigenvalues. */
/* (no sorting of eigenvalues) */
/* (7) | (A,B) - Q (S,T) Z' | / ( | (A,B) | n ulp ) */
/* (with sorting of eigenvalues). */
/* (8) | I - QQ' | / ( n ulp ) (with sorting of eigenvalues). */
/* (9) | I - ZZ' | / ( n ulp ) (with sorting of eigenvalues). */
/* (10) if A is in Schur form (i.e. quasi-triangular form) */
/* (with sorting of eigenvalues). */
/* (11) if eigenvalues = diagonal blocks of the Schur form (S, T), */
/* i.e. test the maximum over j of D(j) where: */
/* if alpha(j) is real: */
/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
/* D(j) = ------------------------ + ----------------------- */
/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
/* if alpha(j) is complex: */
/* | det( s S - w T ) | */
/* D(j) = --------------------------------------------------- */
/* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T ) */
/* and S and T are here the 2 x 2 diagonal blocks of S and T */
/* corresponding to the j-th and j+1-th eigenvalues. */
/* (with sorting of eigenvalues). */
/* (12) if sorting worked and SDIM is the number of eigenvalues */
/* which were SELECTed. */
/* Test Matrices */
/* ============= */
/* The sizes of the test matrices are specified by an array */
/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) ( 0, 0 ) (a pair of zero matrices) */
/* (2) ( I, 0 ) (an identity and a zero matrix) */
/* (3) ( 0, I ) (an identity and a zero matrix) */
/* (4) ( I, I ) (a pair of identity matrices) */
/* t t */
/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
/* t ( I 0 ) */
/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
/* ( 0 I ) ( 0 J ) */
/* and I is a k x k identity and J a (k+1)x(k+1) */
/* Jordan block; k=(N-1)/2 */
/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
/* matrix with those diagonal entries.) */
/* (8) ( I, D ) */
/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
/* (10) ( small*D, big*I ) */
/* (11) ( big*I, small*D ) */
/* (12) ( small*I, big*D ) */
/* (13) ( big*D, big*I ) */
/* (14) ( small*D, small*I ) */
/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
/* t t */
/* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. */
/* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices */
/* with random O(1) entries above the diagonal */
/* and diagonal entries diag(T1) = */
/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
/* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
/* s = machine precision. */
/* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
/* N-5 */
/* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
/* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
/* where r1,..., r(N-4) are random. */
/* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular */
/* matrices. */
/* Arguments */
/* ========= */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. If it is zero, */
/* DDRGES does nothing. NSIZES >= 0. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. NN >= 0. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. If it is zero, DDRGES */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A on input. */
/* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to DDRGES to continue the same random number */
/* sequence. */
/* THRESH (input) DOUBLE PRECISION */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error is */
/* scaled to be O(1), so THRESH should be a reasonably small */
/* multiple of 1, e.g., 10 or 100. In particular, it should */
/* not depend on the precision (single vs. double) or the size */
/* of the matrix. THRESH >= 0. */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* A (input/workspace) DOUBLE PRECISION array, */
/* dimension(LDA, max(NN)) */
/* Used to hold the original A matrix. Used as input only */
/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
/* DOTYPE(MAXTYP+1)=.TRUE. */
/* LDA (input) INTEGER */
/* The leading dimension of A, B, S, and T. */
/* It must be at least 1 and at least max( NN ). */
/* B (input/workspace) DOUBLE PRECISION array, */
/* dimension(LDA, max(NN)) */
/* Used to hold the original B matrix. Used as input only */
/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
/* DOTYPE(MAXTYP+1)=.TRUE. */
/* S (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) */
/* The Schur form matrix computed from A by DGGES. On exit, S */
/* contains the Schur form matrix corresponding to the matrix */
/* in A. */
/* T (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) */
/* The upper triangular matrix computed from B by DGGES. */
/* Q (workspace) DOUBLE PRECISION array, dimension (LDQ, max(NN)) */
/* The (left) orthogonal matrix computed by DGGES. */
/* LDQ (input) INTEGER */
/* The leading dimension of Q and Z. It must */
/* be at least 1 and at least max( NN ). */
/* Z (workspace) DOUBLE PRECISION array, dimension( LDQ, max(NN) ) */
/* The (right) orthogonal matrix computed by DGGES. */
/* ALPHAR (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
/* ALPHAI (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
/* BETA (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
/* The generalized eigenvalues of (A,B) computed by DGGES. */
/* ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th */
/* generalized eigenvalue of A and B. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* LWORK >= MAX( 10*(N+1), 3*N*N ), where N is the largest */
/* matrix dimension. */
/* RESULT (output) DOUBLE PRECISION array, dimension (15) */
/* The values computed by the tests described above. */
/* The values are currently limited to 1/ulp, to avoid overflow. */
/* BWORK (workspace) LOGICAL array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: A routine returned an error code. INFO is the */
/* absolute value of the INFO value returned. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
t_dim1 = *lda;
t_offset = 1 + t_dim1;
t -= t_offset;
s_dim1 = *lda;
s_offset = 1 + s_dim1;
s -= s_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
z_dim1 = *ldq;
z_offset = 1 + z_dim1;
z__ -= z_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--alphar;
--alphai;
--beta;
--work;
--result;
--bwork;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
*info = 0;
badnn = FALSE_;
nmax = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -9;
} else if (*ldq <= 1 || *ldq < nmax) {
*info = -14;
}
/* 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. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV. */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
/* Computing MAX */
i__1 = (nmax + 1) * 10, i__2 = nmax * 3 * nmax;
minwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, "DGEQRF", " ", &nmax, &nmax, &c_n1, &
c_n1), i__1 = max(i__1,i__2), i__2 =
ilaenv_(&c__1, "DORMQR", "LT", &nmax, &nmax, &nmax, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
c__1, "DORGQR", " ", &nmax, &nmax, &nmax, &c_n1);
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = (nmax + 1) * 10, i__2 = (nmax << 1) + nmax * nb, i__1 = max(
i__1,i__2), i__2 = nmax * 3 * nmax;
maxwrk = max(i__1,i__2);
work[1] = (doublereal) maxwrk;
}
if (*lwork < minwrk) {
*info = -20;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DDRGES", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
safmin = dlamch_("Safe minimum");
ulp = dlamch_("Epsilon") * dlamch_("Base");
safmin /= ulp;
safmax = 1. / safmin;
dlabad_(&safmin, &safmax);
ulpinv = 1. / ulp;
/* The values RMAGN(2:3) depend on N, see below. */
rmagn[0] = 0.;
rmagn[1] = 1.;
/* Loop over matrix sizes */
ntestt = 0;
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
n1 = max(1,n);
rmagn[2] = safmax * ulp / (doublereal) n1;
rmagn[3] = safmin * ulpinv * (doublereal) n1;
if (*nsizes != 1) {
mtypes = min(26,*ntypes);
} else {
mtypes = min(27,*ntypes);
}
/* Loop over matrix types */
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L180;
}
++nmats;
ntest = 0;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Initialize RESULT */
for (j = 1; j <= 13; ++j) {
result[j] = 0.;
/* L30: */
}
/* Generate test matrices A and B */
/* Description of control parameters: */
/* KZLASS: =1 means w/o rotation, =2 means w/ rotation, */
/* =3 means random. */
/* KATYPE: the "type" to be passed to DLATM4 for computing A. */
/* KAZERO: the pattern of zeros on the diagonal for A: */
/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
/* non-zero entries.) */
/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
/* =2: large, =3: small. */
/* IASIGN: 1 if the diagonal elements of A are to be */
/* multiplied by a random magnitude 1 number, =2 if */
/* randomly chosen diagonal blocks are to be rotated */
/* to form 2x2 blocks. */
/* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B. */
/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
/* RMAGN: used to implement KAMAGN and KBMAGN. */
if (mtypes > 26) {
goto L110;
}
iinfo = 0;
if (kclass[jtype - 1] < 3) {
/* Generate A (w/o rotation) */
if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
dlaset_("Full", &n, &n, &c_b26, &c_b26, &a[a_offset],
lda);
}
} else {
in = n;
}
dlatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
&kz2[kazero[jtype - 1] - 1], &iasign[jtype - 1], &
rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
a_offset], lda);
iadd = kadd[kazero[jtype - 1] - 1];
if (iadd > 0 && iadd <= n) {
a[iadd + iadd * a_dim1] = 1.;
}
/* Generate B (w/o rotation) */
if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
dlaset_("Full", &n, &n, &c_b26, &c_b26, &b[b_offset],
lda);
}
} else {
in = n;
}
dlatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
&kz2[kbzero[jtype - 1] - 1], &ibsign[jtype - 1], &
rmagn[kbmagn[jtype - 1]], &c_b32, &rmagn[ktrian[jtype
- 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
b_offset], lda);
iadd = kadd[kbzero[jtype - 1] - 1];
if (iadd != 0 && iadd <= n) {
b[iadd + iadd * b_dim1] = 1.;
}
if (kclass[jtype - 1] == 2 && n > 0) {
/* Include rotations */
/* Generate Q, Z as Householder transformations times */
/* a diagonal matrix. */
i__3 = n - 1;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = jc; jr <= i__4; ++jr) {
q[jr + jc * q_dim1] = dlarnd_(&c__3, &iseed[1]);
z__[jr + jc * z_dim1] = dlarnd_(&c__3, &iseed[1]);
/* L40: */
}
i__4 = n + 1 - jc;
dlarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc *
q_dim1], &c__1, &work[jc]);
work[(n << 1) + jc] = d_sign(&c_b32, &q[jc + jc *
q_dim1]);
q[jc + jc * q_dim1] = 1.;
i__4 = n + 1 - jc;
dlarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 +
jc * z_dim1], &c__1, &work[n + jc]);
work[n * 3 + jc] = d_sign(&c_b32, &z__[jc + jc *
z_dim1]);
z__[jc + jc * z_dim1] = 1.;
/* L50: */
}
q[n + n * q_dim1] = 1.;
work[n] = 0.;
d__1 = dlarnd_(&c__2, &iseed[1]);
work[n * 3] = d_sign(&c_b32, &d__1);
z__[n + n * z_dim1] = 1.;
work[n * 2] = 0.;
d__1 = dlarnd_(&c__2, &iseed[1]);
work[n * 4] = d_sign(&c_b32, &d__1);
/* Apply the diagonal matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
a[jr + jc * a_dim1] = work[(n << 1) + jr] * work[
n * 3 + jc] * a[jr + jc * a_dim1];
b[jr + jc * b_dim1] = work[(n << 1) + jr] * work[
n * 3 + jc] * b[jr + jc * b_dim1];
/* L60: */
}
/* L70: */
}
i__3 = n - 1;
dorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &a[a_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
dorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &a[a_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
dorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &b[b_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
dorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &b[b_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
}
} else {
/* Random matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
a[jr + jc * a_dim1] = rmagn[kamagn[jtype - 1]] *
dlarnd_(&c__2, &iseed[1]);
b[jr + jc * b_dim1] = rmagn[kbmagn[jtype - 1]] *
dlarnd_(&c__2, &iseed[1]);
/* L80: */
}
/* L90: */
}
}
L100:
if (iinfo != 0) {
io___40.ciunit = *nounit;
s_wsfe(&io___40);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L110:
for (i__ = 1; i__ <= 13; ++i__) {
result[i__] = -1.;
/* L120: */
}
/* Test with and without sorting of eigenvalues */
for (isort = 0; isort <= 1; ++isort) {
if (isort == 0) {
*(unsigned char *)sort = 'N';
rsub = 0;
} else {
*(unsigned char *)sort = 'S';
rsub = 5;
}
/* Call DGGES to compute H, T, Q, Z, alpha, and beta. */
dlacpy_("Full", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
dlacpy_("Full", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
ntest = rsub + 1 + isort;
result[rsub + 1 + isort] = ulpinv;
dgges_("V", "V", sort, (L_fp)dlctes_, &n, &s[s_offset], lda, &
t[t_offset], lda, &sdim, &alphar[1], &alphai[1], &
beta[1], &q[q_offset], ldq, &z__[z_offset], ldq, &
work[1], lwork, &bwork[1], &iinfo);
if (iinfo != 0 && iinfo != n + 2) {
result[rsub + 1 + isort] = ulpinv;
io___46.ciunit = *nounit;
s_wsfe(&io___46);
do_fio(&c__1, "DGGES", (ftnlen)5);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
goto L160;
}
ntest = rsub + 4;
/* Do tests 1--4 (or tests 7--9 when reordering ) */
if (isort == 0) {
dget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, &
q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
result[1]);
dget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &
q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
result[2]);
} else {
dget54_(&n, &a[a_offset], lda, &b[b_offset], lda, &s[
s_offset], lda, &t[t_offset], lda, &q[q_offset],
ldq, &z__[z_offset], ldq, &work[1], &result[7]);
}
dget51_(&c__3, &n, &a[a_offset], lda, &t[t_offset], lda, &q[
q_offset], ldq, &q[q_offset], ldq, &work[1], &result[
rsub + 3]);
dget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[
z_offset], ldq, &z__[z_offset], ldq, &work[1], &
result[rsub + 4]);
/* Do test 5 and 6 (or Tests 10 and 11 when reordering): */
/* check Schur form of A and compare eigenvalues with */
/* diagonals. */
ntest = rsub + 6;
temp1 = 0.;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
ilabad = FALSE_;
if (alphai[j] == 0.) {
/* Computing MAX */
d__7 = safmin, d__8 = (d__2 = alphar[j], abs(d__2)),
d__7 = max(d__7,d__8), d__8 = (d__3 = s[j + j
* s_dim1], abs(d__3));
/* Computing MAX */
d__9 = safmin, d__10 = (d__5 = beta[j], abs(d__5)),
d__9 = max(d__9,d__10), d__10 = (d__6 = t[j +
j * t_dim1], abs(d__6));
temp2 = ((d__1 = alphar[j] - s[j + j * s_dim1], abs(
d__1)) / max(d__7,d__8) + (d__4 = beta[j] - t[
j + j * t_dim1], abs(d__4)) / max(d__9,d__10))
/ ulp;
if (j < n) {
if (s[j + 1 + j * s_dim1] != 0.) {
ilabad = TRUE_;
result[rsub + 5] = ulpinv;
}
}
if (j > 1) {
if (s[j + (j - 1) * s_dim1] != 0.) {
ilabad = TRUE_;
result[rsub + 5] = ulpinv;
}
}
} else {
if (alphai[j] > 0.) {
i1 = j;
} else {
i1 = j - 1;
}
if (i1 <= 0 || i1 >= n) {
ilabad = TRUE_;
} else if (i1 < n - 1) {
if (s[i1 + 2 + (i1 + 1) * s_dim1] != 0.) {
ilabad = TRUE_;
result[rsub + 5] = ulpinv;
}
} else if (i1 > 1) {
if (s[i1 + (i1 - 1) * s_dim1] != 0.) {
ilabad = TRUE_;
result[rsub + 5] = ulpinv;
}
}
if (! ilabad) {
dget53_(&s[i1 + i1 * s_dim1], lda, &t[i1 + i1 *
t_dim1], lda, &beta[j], &alphar[j], &
alphai[j], &temp2, &ierr);
if (ierr >= 3) {
io___52.ciunit = *nounit;
s_wsfe(&io___52);
do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)
sizeof(integer));
e_wsfe();
*info = abs(ierr);
}
} else {
temp2 = ulpinv;
}
}
temp1 = max(temp1,temp2);
if (ilabad) {
io___53.ciunit = *nounit;
s_wsfe(&io___53);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
e_wsfe();
}
/* L130: */
}
result[rsub + 6] = temp1;
if (isort >= 1) {
/* Do test 12 */
ntest = 12;
result[12] = 0.;
knteig = 0;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
d__1 = -alphai[i__];
if (dlctes_(&alphar[i__], &alphai[i__], &beta[i__]) ||
dlctes_(&alphar[i__], &d__1, &beta[i__])) {
++knteig;
}
if (i__ < n) {
d__1 = -alphai[i__ + 1];
d__2 = -alphai[i__];
if ((dlctes_(&alphar[i__ + 1], &alphai[i__ + 1], &
beta[i__ + 1]) || dlctes_(&alphar[i__ + 1]
, &d__1, &beta[i__ + 1])) && ! (dlctes_(&
alphar[i__], &alphai[i__], &beta[i__]) ||
dlctes_(&alphar[i__], &d__2, &beta[i__]))
&& iinfo != n + 2) {
result[12] = ulpinv;
}
}
/* L140: */
}
if (sdim != knteig) {
result[12] = ulpinv;
}
}
/* L150: */
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L160:
ntestt += ntest;
/* Print out tests which fail. */
i__3 = ntest;
for (jr = 1; jr <= i__3; ++jr) {
if (result[jr] >= *thresh) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___55.ciunit = *nounit;
s_wsfe(&io___55);
do_fio(&c__1, "DGS", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___56.ciunit = *nounit;
s_wsfe(&io___56);
e_wsfe();
io___57.ciunit = *nounit;
s_wsfe(&io___57);
e_wsfe();
io___58.ciunit = *nounit;
s_wsfe(&io___58);
do_fio(&c__1, "Orthogonal", (ftnlen)10);
e_wsfe();
/* Tests performed */
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, "orthogonal", (ftnlen)10);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (j = 1; j <= 8; ++j) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[jr] < 1e4) {
io___60.ciunit = *nounit;
s_wsfe(&io___60);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
} else {
io___61.ciunit = *nounit;
s_wsfe(&io___61);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
}
/* L170: */
}
L180:
;
}
/* L190: */
}
/* Summary */
alasvm_("DGS", nounit, &nerrs, &ntestt, &c__0);
work[1] = (doublereal) maxwrk;
return 0;
/* End of DDRGES */
} /* ddrges_ */
/* Subroutine */ int dhseqr_(char *job, char *compz, integer *n, integer *ilo,
integer *ihi, doublereal *h__, integer *ldh, doublereal *wr,
doublereal *wi, doublereal *z__, integer *ldz, doublereal *work,
integer *lwork, integer *info)
{
/* System generated locals */
address a__1[2];
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2[2], i__3;
doublereal d__1;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__;
#ifdef LAPACK_DISABLE_MEMORY_HOGS
doublereal hl[1] /* was [49][49] */;
/** This function uses too much memory, so we stopped allocating the memory
* above and assert false here. */
assert(0 && "dhseqr_ was called. This function allocates too much"
" memory and has been disabled.");
#else
doublereal hl[2401] /* was [49][49] */;
#endif
integer kbot, nmin;
extern logical lsame_(char *, char *);
logical initz;
doublereal workl[49];
logical wantt, wantz;
extern /* Subroutine */ int dlaqr0_(logical *, logical *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *), dlahqr_(logical *, logical *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *);
logical lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DHSEQR computes the eigenvalues of a Hessenberg matrix H */
/* and, optionally, the matrices T and Z from the Schur decomposition */
/* H = Z T Z**T, where T is an upper quasi-triangular matrix (the */
/* Schur form), and Z is the orthogonal matrix of Schur vectors. */
/* Optionally Z may be postmultiplied into an input orthogonal */
/* matrix Q so that this routine can give the Schur factorization */
/* of a matrix A which has been reduced to the Hessenberg form H */
/* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* = 'E': compute eigenvalues only; */
/* = 'S': compute eigenvalues and the Schur form T. */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': no Schur vectors are computed; */
/* = 'I': Z is initialized to the unit matrix and the matrix Z */
/* of Schur vectors of H is returned; */
/* = 'V': Z must contain an orthogonal matrix Q on entry, and */
/* the product Q*Z is returned. */
/* N (input) INTEGER */
/* The order of the matrix H. N .GE. 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that H is already upper triangular in rows */
/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
/* set by a previous call to DGEBAL, and then passed to DGEHRD */
/* when the matrix output by DGEBAL is reduced to Hessenberg */
/* form. Otherwise ILO and IHI should be set to 1 and N */
/* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */
/* If N = 0, then ILO = 1 and IHI = 0. */
/* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if INFO = 0 and JOB = 'S', then H contains the */
/* upper quasi-triangular matrix T from the Schur decomposition */
/* (the Schur form); 2-by-2 diagonal blocks (corresponding to */
/* complex conjugate pairs of eigenvalues) are returned in */
/* standard form, with H(i,i) = H(i+1,i+1) and */
/* H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the */
/* contents of H are unspecified on exit. (The output value of */
/* H when INFO.GT.0 is given under the description of INFO */
/* below.) */
/* Unlike earlier versions of DHSEQR, this subroutine may */
/* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 */
/* or j = IHI+1, IHI+2, ... N. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH .GE. max(1,N). */
/* WR (output) DOUBLE PRECISION array, dimension (N) */
/* WI (output) DOUBLE PRECISION array, dimension (N) */
/* The real and imaginary parts, respectively, of the computed */
/* eigenvalues. If two eigenvalues are computed as a complex */
/* conjugate pair, they are stored in consecutive elements of */
/* WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and */
/* WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in */
/* the same order as on the diagonal of the Schur form returned */
/* in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 */
/* diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and */
/* WI(i+1) = -WI(i). */
/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
/* If COMPZ = 'N', Z is not referenced. */
/* If COMPZ = 'I', on entry Z need not be set and on exit, */
/* if INFO = 0, Z contains the orthogonal matrix Z of the Schur */
/* vectors of H. If COMPZ = 'V', on entry Z must contain an */
/* N-by-N matrix Q, which is assumed to be equal to the unit */
/* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, */
/* if INFO = 0, Z contains Q*Z. */
/* Normally Q is the orthogonal matrix generated by DORGHR */
/* after the call to DGEHRD which formed the Hessenberg matrix */
/* H. (The output value of Z when INFO.GT.0 is given under */
/* the description of INFO below.) */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. if COMPZ = 'I' or */
/* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns an estimate of */
/* the optimal value for LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK .GE. max(1,N) */
/* is sufficient and delivers very good and sometimes */
/* optimal performance. However, LWORK as large as 11*N */
/* may be required for optimal performance. A workspace */
/* query is recommended to determine the optimal workspace */
/* size. */
/* If LWORK = -1, then DHSEQR does a workspace query. */
/* In this case, DHSEQR checks the input parameters and */
/* estimates the optimal workspace size for the given */
/* values of N, ILO and IHI. The estimate is returned */
/* in WORK(1). No error message related to LWORK is */
/* issued by XERBLA. Neither H nor Z are accessed. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* .LT. 0: if INFO = -i, the i-th argument had an illegal */
/* value */
/* .GT. 0: if INFO = i, DHSEQR failed to compute all of */
/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */
/* and WI contain those eigenvalues which have been */
/* successfully computed. (Failures are rare.) */
/* If INFO .GT. 0 and JOB = 'E', then on exit, the */
/* remaining unconverged eigenvalues are the eigen- */
/* values of the upper Hessenberg matrix rows and */
/* columns ILO through INFO of the final, output */
/* value of H. */
/* If INFO .GT. 0 and JOB = 'S', then on exit */
/* (*) (initial value of H)*U = U*(final value of H) */
/* where U is an orthogonal matrix. The final */
/* value of H is upper Hessenberg and quasi-triangular */
/* in rows and columns INFO+1 through IHI. */
/* If INFO .GT. 0 and COMPZ = 'V', then on exit */
/* (final value of Z) = (initial value of Z)*U */
/* where U is the orthogonal matrix in (*) (regard- */
/* less of the value of JOB.) */
/* If INFO .GT. 0 and COMPZ = 'I', then on exit */
/* (final value of Z) = U */
/* where U is the orthogonal matrix in (*) (regard- */
/* less of the value of JOB.) */
/* If INFO .GT. 0 and COMPZ = 'N', then Z is not */
/* accessed. */
/* ================================================================ */
/* Default values supplied by */
/* ILAENV(ISPEC,'DHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). */
/* It is suggested that these defaults be adjusted in order */
/* to attain best performance in each particular */
/* computational environment. */
/* ISPEC=12: The DLAHQR vs DLAQR0 crossover point. */
/* Default: 75. (Must be at least 11.) */
/* ISPEC=13: Recommended deflation window size. */
/* This depends on ILO, IHI and NS. NS is the */
/* number of simultaneous shifts returned */
/* by ILAENV(ISPEC=15). (See ISPEC=15 below.) */
/* The default for (IHI-ILO+1).LE.500 is NS. */
/* The default for (IHI-ILO+1).GT.500 is 3*NS/2. */
/* ISPEC=14: Nibble crossover point. (See IPARMQ for */
/* details.) Default: 14% of deflation window */
/* size. */
/* ISPEC=15: Number of simultaneous shifts in a multishift */
/* QR iteration. */
/* If IHI-ILO+1 is ... */
/* greater than ...but less ... the */
/* or equal to ... than default is */
/* 1 30 NS = 2(+) */
/* 30 60 NS = 4(+) */
/* 60 150 NS = 10(+) */
/* 150 590 NS = ** */
/* 590 3000 NS = 64 */
/* 3000 6000 NS = 128 */
/* 6000 infinity NS = 256 */
/* (+) By default some or all matrices of this order */
/* are passed to the implicit double shift routine */
/* DLAHQR and this parameter is ignored. See */
/* ISPEC=12 above and comments in IPARMQ for */
/* details. */
/* (**) The asterisks (**) indicate an ad-hoc */
/* function of N increasing from 10 to 64. */
/* ISPEC=16: Select structured matrix multiply. */
/* If the number of simultaneous shifts (specified */
/* by ISPEC=15) is less than 14, then the default */
/* for ISPEC=16 is 0. Otherwise the default for */
/* ISPEC=16 is 2. */
/* ================================================================ */
/* Based on contributions by */
/* Karen Braman and Ralph Byers, Department of Mathematics, */
/* University of Kansas, USA */
/* ================================================================ */
/* References: */
/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */
/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */
/* 929--947, 2002. */
/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */
/* of Matrix Analysis, volume 23, pages 948--973, 2002. */
/* ================================================================ */
/* .. Parameters .. */
/* ==== Matrices of order NTINY or smaller must be processed by */
/* . DLAHQR because of insufficient subdiagonal scratch space. */
/* . (This is a hard limit.) ==== */
/* ==== NL allocates some local workspace to help small matrices */
/* . through a rare DLAHQR failure. NL .GT. NTINY = 11 is */
/* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- */
/* . mended. (The default value of NMIN is 75.) Using NL = 49 */
/* . allows up to six simultaneous shifts and a 16-by-16 */
/* . deflation window. ==== */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* ==== Decode and check the input parameters. ==== */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--wr;
--wi;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
wantt = lsame_(job, "S");
initz = lsame_(compz, "I");
wantz = initz || lsame_(compz, "V");
work[1] = (doublereal) max(1,*n);
lquery = *lwork == -1;
*info = 0;
if (! lsame_(job, "E") && ! wantt) {
*info = -1;
} else if (! lsame_(compz, "N") && ! wantz) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -4;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -5;
} else if (*ldh < max(1,*n)) {
*info = -7;
} else if (*ldz < 1 || wantz && *ldz < max(1,*n)) {
*info = -11;
} else if (*lwork < max(1,*n) && ! lquery) {
*info = -13;
}
if (*info != 0) {
/* ==== Quick return in case of invalid argument. ==== */
i__1 = -(*info);
xerbla_("DHSEQR", &i__1);
return 0;
} else if (*n == 0) {
/* ==== Quick return in case N = 0; nothing to do. ==== */
return 0;
} else if (lquery) {
/* ==== Quick return in case of a workspace query ==== */
dlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[
1], ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, info);
/* ==== Ensure reported workspace size is backward-compatible with */
/* . previous LAPACK versions. ==== */
/* Computing MAX */
d__1 = (doublereal) max(1,*n);
work[1] = max(d__1,work[1]);
return 0;
} else {
/* ==== copy eigenvalues isolated by DGEBAL ==== */
i__1 = *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.;
/* L10: */
}
i__1 = *n;
for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.;
/* L20: */
}
/* ==== Initialize Z, if requested ==== */
if (initz) {
dlaset_("A", n, n, &c_b11, &c_b12, &z__[z_offset], ldz)
;
}
/* ==== Quick return if possible ==== */
if (*ilo == *ihi) {
wr[*ilo] = h__[*ilo + *ilo * h_dim1];
wi[*ilo] = 0.;
return 0;
}
/* ==== DLAHQR/DLAQR0 crossover point ==== */
/* Writing concatenation */
i__2[0] = 1, a__1[0] = job;
i__2[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2);
nmin = ilaenv_(&c__12, "DHSEQR", ch__1, n, ilo, ihi, lwork);
nmin = max(11,nmin);
/* ==== DLAQR0 for big matrices; DLAHQR for small ones ==== */
if (*n > nmin) {
dlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1],
&wi[1], ilo, ihi, &z__[z_offset], ldz, &work[1], lwork,
info);
} else {
/* ==== Small matrix ==== */
dlahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1],
&wi[1], ilo, ihi, &z__[z_offset], ldz, info);
if (*info > 0) {
/* ==== A rare DLAHQR failure! DLAQR0 sometimes succeeds */
/* . when DLAHQR fails. ==== */
kbot = *info;
if (*n >= 49) {
/* ==== Larger matrices have enough subdiagonal scratch */
/* . space to call DLAQR0 directly. ==== */
dlaqr0_(&wantt, &wantz, n, ilo, &kbot, &h__[h_offset],
ldh, &wr[1], &wi[1], ilo, ihi, &z__[z_offset],
ldz, &work[1], lwork, info);
} else {
/* ==== Tiny matrices don't have enough subdiagonal */
/* . scratch space to benefit from DLAQR0. Hence, */
/* . tiny matrices must be copied into a larger */
/* . array before calling DLAQR0. ==== */
dlacpy_("A", n, n, &h__[h_offset], ldh, hl, &c__49);
hl[*n + 1 + *n * 49 - 50] = 0.;
i__1 = 49 - *n;
dlaset_("A", &c__49, &i__1, &c_b11, &c_b11, &hl[(*n + 1) *
49 - 49], &c__49);
dlaqr0_(&wantt, &wantz, &c__49, ilo, &kbot, hl, &c__49, &
wr[1], &wi[1], ilo, ihi, &z__[z_offset], ldz,
workl, &c__49, info);
if (wantt || *info != 0) {
dlacpy_("A", n, n, hl, &c__49, &h__[h_offset], ldh);
}
}
}
}
/* ==== Clear out the trash, if necessary. ==== */
if ((wantt || *info != 0) && *n > 2) {
i__1 = *n - 2;
i__3 = *n - 2;
dlaset_("L", &i__1, &i__3, &c_b11, &c_b11, &h__[h_dim1 + 3], ldh);
}
/* ==== Ensure reported workspace size is backward-compatible with */
/* . previous LAPACK versions. ==== */
/* Computing MAX */
d__1 = (doublereal) max(1,*n);
work[1] = max(d__1,work[1]);
}
/* ==== End of DHSEQR ==== */
return 0;
} /* dhseqr_ */
/* Subroutine */ int dlatme_(integer *n, char *dist, integer *iseed,
doublereal *d__, integer *mode, doublereal *cond, doublereal *dmax__,
char *ei, char *rsign, char *upper, char *sim, doublereal *ds,
integer *modes, doublereal *conds, integer *kl, integer *ku,
doublereal *anorm, doublereal *a, integer *lda, doublereal *work,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1, d__2, d__3;
/* Local variables */
integer i__, j, ic, jc, ir, jr, jcr;
doublereal tau;
logical bads;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
integer isim;
doublereal temp;
logical badei;
doublereal alpha;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
integer iinfo;
doublereal tempa[1];
integer icols;
logical useei;
integer idist;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
integer irows;
extern /* Subroutine */ int dlatm1_(integer *, doublereal *, integer *,
integer *, integer *, doublereal *, integer *, integer *);
extern doublereal dlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dlarge_(integer *, doublereal *, integer *,
integer *, doublereal *, integer *), dlarfg_(integer *,
doublereal *, doublereal *, integer *, doublereal *);
extern doublereal dlaran_(integer *);
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *), dlarnv_(integer *, integer *,
integer *, doublereal *);
integer irsign, iupper;
doublereal xnorms;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLATME generates random non-symmetric square matrices with */
/* specified eigenvalues for testing LAPACK programs. */
/* DLATME operates by applying the following sequence of */
/* operations: */
/* 1. Set the diagonal to D, where D may be input or */
/* computed according to MODE, COND, DMAX, and RSIGN */
/* as described below. */
/* 2. If complex conjugate pairs are desired (MODE=0 and EI(1)='R', */
/* or MODE=5), certain pairs of adjacent elements of D are */
/* interpreted as the real and complex parts of a complex */
/* conjugate pair; A thus becomes block diagonal, with 1x1 */
/* and 2x2 blocks. */
/* 3. If UPPER='T', the upper triangle of A is set to random values */
/* out of distribution DIST. */
/* 4. If SIM='T', A is multiplied on the left by a random matrix */
/* X, whose singular values are specified by DS, MODES, and */
/* CONDS, and on the right by X inverse. */
/* 5. If KL < N-1, the lower bandwidth is reduced to KL using */
/* Householder transformations. If KU < N-1, the upper */
/* bandwidth is reduced to KU. */
/* 6. If ANORM is not negative, the matrix is scaled to have */
/* maximum-element-norm ANORM. */
/* (Note: since the matrix cannot be reduced beyond Hessenberg form, */
/* no packing options are available.) */
/* Arguments */
/* ========= */
/* N - INTEGER */
/* The number of columns (or rows) of A. Not modified. */
/* DIST - CHARACTER*1 */
/* On entry, DIST specifies the type of distribution to be used */
/* to generate the random eigen-/singular values, and for the */
/* upper triangle (see UPPER). */
/* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */
/* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */
/* 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */
/* Not modified. */
/* ISEED - INTEGER array, dimension ( 4 ) */
/* On entry ISEED specifies the seed of the random number */
/* generator. They should lie between 0 and 4095 inclusive, */
/* and ISEED(4) should be odd. The random number generator */
/* uses a linear congruential sequence limited to small */
/* integers, and so should produce machine independent */
/* random numbers. The values of ISEED are changed on */
/* exit, and can be used in the next call to DLATME */
/* to continue the same random number sequence. */
/* Changed on exit. */
/* D - DOUBLE PRECISION array, dimension ( N ) */
/* This array is used to specify the eigenvalues of A. If */
/* MODE=0, then D is assumed to contain the eigenvalues (but */
/* see the description of EI), otherwise they will be */
/* computed according to MODE, COND, DMAX, and RSIGN and */
/* placed in D. */
/* Modified if MODE is nonzero. */
/* MODE - INTEGER */
/* On entry this describes how the eigenvalues are to */
/* be specified: */
/* MODE = 0 means use D (with EI) as input */
/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
/* MODE = 5 sets D to random numbers in the range */
/* ( 1/COND , 1 ) such that their logarithms */
/* are uniformly distributed. Each odd-even pair */
/* of elements will be either used as two real */
/* eigenvalues or as the real and imaginary part */
/* of a complex conjugate pair of eigenvalues; */
/* the choice of which is done is random, with */
/* 50-50 probability, for each pair. */
/* MODE = 6 set D to random numbers from same distribution */
/* as the rest of the matrix. */
/* MODE < 0 has the same meaning as ABS(MODE), except that */
/* the order of the elements of D is reversed. */
/* Thus if MODE is between 1 and 4, D has entries ranging */
/* from 1 to 1/COND, if between -1 and -4, D has entries */
/* ranging from 1/COND to 1, */
/* Not modified. */
/* COND - DOUBLE PRECISION */
/* On entry, this is used as described under MODE above. */
/* If used, it must be >= 1. Not modified. */
/* DMAX - DOUBLE PRECISION */
/* If MODE is neither -6, 0 nor 6, the contents of D, as */
/* computed according to MODE and COND, will be scaled by */
/* DMAX / max(abs(D(i))). Note that DMAX need not be */
/* positive: if DMAX is negative (or zero), D will be */
/* scaled by a negative number (or zero). */
/* Not modified. */
/* EI - CHARACTER*1 array, dimension ( N ) */
/* If MODE is 0, and EI(1) is not ' ' (space character), */
/* this array specifies which elements of D (on input) are */
/* real eigenvalues and which are the real and imaginary parts */
/* of a complex conjugate pair of eigenvalues. The elements */
/* of EI may then only have the values 'R' and 'I'. If */
/* EI(j)='R' and EI(j+1)='I', then the j-th eigenvalue is */
/* CMPLX( D(j) , D(j+1) ), and the (j+1)-th is the complex */
/* conjugate thereof. If EI(j)=EI(j+1)='R', then the j-th */
/* eigenvalue is D(j) (i.e., real). EI(1) may not be 'I', */
/* nor may two adjacent elements of EI both have the value 'I'. */
/* If MODE is not 0, then EI is ignored. If MODE is 0 and */
/* EI(1)=' ', then the eigenvalues will all be real. */
/* Not modified. */
/* RSIGN - CHARACTER*1 */
/* If MODE is not 0, 6, or -6, and RSIGN='T', then the */
/* elements of D, as computed according to MODE and COND, will */
/* be multiplied by a random sign (+1 or -1). If RSIGN='F', */
/* they will not be. RSIGN may only have the values 'T' or */
/* 'F'. */
/* Not modified. */
/* UPPER - CHARACTER*1 */
/* If UPPER='T', then the elements of A above the diagonal */
/* (and above the 2x2 diagonal blocks, if A has complex */
/* eigenvalues) will be set to random numbers out of DIST. */
/* If UPPER='F', they will not. UPPER may only have the */
/* values 'T' or 'F'. */
/* Not modified. */
/* SIM - CHARACTER*1 */
/* If SIM='T', then A will be operated on by a "similarity */
/* transform", i.e., multiplied on the left by a matrix X and */
/* on the right by X inverse. X = U S V, where U and V are */
/* random unitary matrices and S is a (diagonal) matrix of */
/* singular values specified by DS, MODES, and CONDS. If */
/* SIM='F', then A will not be transformed. */
/* Not modified. */
/* DS - DOUBLE PRECISION array, dimension ( N ) */
/* This array is used to specify the singular values of X, */
/* in the same way that D specifies the eigenvalues of A. */
/* If MODE=0, the DS contains the singular values, which */
/* may not be zero. */
/* Modified if MODE is nonzero. */
/* MODES - INTEGER */
/* CONDS - DOUBLE PRECISION */
/* Same as MODE and COND, but for specifying the diagonal */
/* of S. MODES=-6 and +6 are not allowed (since they would */
/* result in randomly ill-conditioned eigenvalues.) */
/* KL - INTEGER */
/* This specifies the lower bandwidth of the matrix. KL=1 */
/* specifies upper Hessenberg form. If KL is at least N-1, */
/* then A will have full lower bandwidth. KL must be at */
/* least 1. */
/* Not modified. */
/* KU - INTEGER */
/* This specifies the upper bandwidth of the matrix. KU=1 */
/* specifies lower Hessenberg form. If KU is at least N-1, */
/* then A will have full upper bandwidth; if KU and KL */
/* are both at least N-1, then A will be dense. Only one of */
/* KU and KL may be less than N-1. KU must be at least 1. */
/* Not modified. */
/* ANORM - DOUBLE PRECISION */
/* If ANORM is not negative, then A will be scaled by a non- */
/* negative real number to make the maximum-element-norm of A */
/* to be ANORM. */
/* Not modified. */
/* A - DOUBLE PRECISION array, dimension ( LDA, N ) */
/* On exit A is the desired test matrix. */
/* Modified. */
/* LDA - INTEGER */
/* LDA specifies the first dimension of A as declared in the */
/* calling program. LDA must be at least N. */
/* Not modified. */
/* WORK - DOUBLE PRECISION array, dimension ( 3*N ) */
/* Workspace. */
/* Modified. */
/* INFO - INTEGER */
/* Error code. On exit, INFO will be set to one of the */
/* following values: */
/* 0 => normal return */
/* -1 => N negative */
/* -2 => DIST illegal string */
/* -5 => MODE not in range -6 to 6 */
/* -6 => COND less than 1.0, and MODE neither -6, 0 nor 6 */
/* -8 => EI(1) is not ' ' or 'R', EI(j) is not 'R' or 'I', or */
/* two adjacent elements of EI are 'I'. */
/* -9 => RSIGN is not 'T' or 'F' */
/* -10 => UPPER is not 'T' or 'F' */
/* -11 => SIM is not 'T' or 'F' */
/* -12 => MODES=0 and DS has a zero singular value. */
/* -13 => MODES is not in the range -5 to 5. */
/* -14 => MODES is nonzero and CONDS is less than 1. */
/* -15 => KL is less than 1. */
/* -16 => KU is less than 1, or KL and KU are both less than */
/* N-1. */
/* -19 => LDA is less than N. */
/* 1 => Error return from DLATM1 (computing D) */
/* 2 => Cannot scale to DMAX (max. eigenvalue is 0) */
/* 3 => Error return from DLATM1 (computing DS) */
/* 4 => Error return from DLARGE */
/* 5 => Zero singular value from DLATM1. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* 1) Decode and Test the input parameters. */
/* Initialize flags & seed. */
/* Parameter adjustments */
--iseed;
--d__;
--ei;
--ds;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Decode DIST */
if (lsame_(dist, "U")) {
idist = 1;
} else if (lsame_(dist, "S")) {
idist = 2;
} else if (lsame_(dist, "N")) {
idist = 3;
} else {
idist = -1;
}
/* Check EI */
useei = TRUE_;
badei = FALSE_;
if (lsame_(ei + 1, " ") || *mode != 0) {
useei = FALSE_;
} else {
if (lsame_(ei + 1, "R")) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
if (lsame_(ei + j, "I")) {
if (lsame_(ei + (j - 1), "I")) {
badei = TRUE_;
}
} else {
if (! lsame_(ei + j, "R")) {
badei = TRUE_;
}
}
/* L10: */
}
} else {
badei = TRUE_;
}
}
/* Decode RSIGN */
if (lsame_(rsign, "T")) {
irsign = 1;
} else if (lsame_(rsign, "F")) {
irsign = 0;
} else {
irsign = -1;
}
/* Decode UPPER */
if (lsame_(upper, "T")) {
iupper = 1;
} else if (lsame_(upper, "F")) {
iupper = 0;
} else {
iupper = -1;
}
/* Decode SIM */
if (lsame_(sim, "T")) {
isim = 1;
} else if (lsame_(sim, "F")) {
isim = 0;
} else {
isim = -1;
}
/* Check DS, if MODES=0 and ISIM=1 */
bads = FALSE_;
if (*modes == 0 && isim == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (ds[j] == 0.) {
bads = TRUE_;
}
/* L20: */
}
}
/* Set INFO if an error */
if (*n < 0) {
*info = -1;
} else if (idist == -1) {
*info = -2;
} else if (abs(*mode) > 6) {
*info = -5;
} else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.) {
*info = -6;
} else if (badei) {
*info = -8;
} else if (irsign == -1) {
*info = -9;
} else if (iupper == -1) {
*info = -10;
} else if (isim == -1) {
*info = -11;
} else if (bads) {
*info = -12;
} else if (isim == 1 && abs(*modes) > 5) {
*info = -13;
} else if (isim == 1 && *modes != 0 && *conds < 1.) {
*info = -14;
} else if (*kl < 1) {
*info = -15;
} else if (*ku < 1 || *ku < *n - 1 && *kl < *n - 1) {
*info = -16;
} else if (*lda < max(1,*n)) {
*info = -19;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLATME", &i__1);
return 0;
}
/* Initialize random number generator */
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
/* L30: */
}
if (iseed[4] % 2 != 1) {
++iseed[4];
}
/* 2) Set up diagonal of A */
/* Compute D according to COND and MODE */
dlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], n, &iinfo);
if (iinfo != 0) {
*info = 1;
return 0;
}
if (*mode != 0 && abs(*mode) != 6) {
/* Scale by DMAX */
temp = abs(d__[1]);
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = d__[i__], abs(d__1));
temp = max(d__2,d__3);
/* L40: */
}
if (temp > 0.) {
alpha = *dmax__ / temp;
} else if (*dmax__ != 0.) {
*info = 2;
return 0;
} else {
alpha = 0.;
}
dscal_(n, &alpha, &d__[1], &c__1);
}
dlaset_("Full", n, n, &c_b23, &c_b23, &a[a_offset], lda);
i__1 = *lda + 1;
dcopy_(n, &d__[1], &c__1, &a[a_offset], &i__1);
/* Set up complex conjugate pairs */
if (*mode == 0) {
if (useei) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
if (lsame_(ei + j, "I")) {
a[j - 1 + j * a_dim1] = a[j + j * a_dim1];
a[j + (j - 1) * a_dim1] = -a[j + j * a_dim1];
a[j + j * a_dim1] = a[j - 1 + (j - 1) * a_dim1];
}
/* L50: */
}
}
} else if (abs(*mode) == 5) {
i__1 = *n;
for (j = 2; j <= i__1; j += 2) {
if (dlaran_(&iseed[1]) > .5) {
a[j - 1 + j * a_dim1] = a[j + j * a_dim1];
a[j + (j - 1) * a_dim1] = -a[j + j * a_dim1];
a[j + j * a_dim1] = a[j - 1 + (j - 1) * a_dim1];
}
/* L60: */
}
}
/* 3) If UPPER='T', set upper triangle of A to random numbers. */
/* (but don't modify the corners of 2x2 blocks.) */
if (iupper != 0) {
i__1 = *n;
for (jc = 2; jc <= i__1; ++jc) {
if (a[jc - 1 + jc * a_dim1] != 0.) {
jr = jc - 2;
} else {
jr = jc - 1;
}
dlarnv_(&idist, &iseed[1], &jr, &a[jc * a_dim1 + 1]);
/* L70: */
}
}
/* 4) If SIM='T', apply similarity transformation. */
/* -1 */
/* Transform is X A X , where X = U S V, thus */
/* it is U S V A V' (1/S) U' */
if (isim != 0) {
/* Compute S (singular values of the eigenvector matrix) */
/* according to CONDS and MODES */
dlatm1_(modes, conds, &c__0, &c__0, &iseed[1], &ds[1], n, &iinfo);
if (iinfo != 0) {
*info = 3;
return 0;
}
/* Multiply by V and V' */
dlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
if (iinfo != 0) {
*info = 4;
return 0;
}
/* Multiply by S and (1/S) */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
dscal_(n, &ds[j], &a[j + a_dim1], lda);
if (ds[j] != 0.) {
d__1 = 1. / ds[j];
dscal_(n, &d__1, &a[j * a_dim1 + 1], &c__1);
} else {
*info = 5;
return 0;
}
/* L80: */
}
/* Multiply by U and U' */
dlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
if (iinfo != 0) {
*info = 4;
return 0;
}
}
/* 5) Reduce the bandwidth. */
if (*kl < *n - 1) {
/* Reduce bandwidth -- kill column */
i__1 = *n - 1;
for (jcr = *kl + 1; jcr <= i__1; ++jcr) {
ic = jcr - *kl;
irows = *n + 1 - jcr;
icols = *n + *kl - jcr;
dcopy_(&irows, &a[jcr + ic * a_dim1], &c__1, &work[1], &c__1);
xnorms = work[1];
dlarfg_(&irows, &xnorms, &work[2], &c__1, &tau);
work[1] = 1.;
dgemv_("T", &irows, &icols, &c_b39, &a[jcr + (ic + 1) * a_dim1],
lda, &work[1], &c__1, &c_b23, &work[irows + 1], &c__1);
d__1 = -tau;
dger_(&irows, &icols, &d__1, &work[1], &c__1, &work[irows + 1], &
c__1, &a[jcr + (ic + 1) * a_dim1], lda);
dgemv_("N", n, &irows, &c_b39, &a[jcr * a_dim1 + 1], lda, &work[1]
, &c__1, &c_b23, &work[irows + 1], &c__1);
d__1 = -tau;
dger_(n, &irows, &d__1, &work[irows + 1], &c__1, &work[1], &c__1,
&a[jcr * a_dim1 + 1], lda);
a[jcr + ic * a_dim1] = xnorms;
i__2 = irows - 1;
dlaset_("Full", &i__2, &c__1, &c_b23, &c_b23, &a[jcr + 1 + ic *
a_dim1], lda);
/* L90: */
}
} else if (*ku < *n - 1) {
/* Reduce upper bandwidth -- kill a row at a time. */
i__1 = *n - 1;
for (jcr = *ku + 1; jcr <= i__1; ++jcr) {
ir = jcr - *ku;
irows = *n + *ku - jcr;
icols = *n + 1 - jcr;
dcopy_(&icols, &a[ir + jcr * a_dim1], lda, &work[1], &c__1);
xnorms = work[1];
dlarfg_(&icols, &xnorms, &work[2], &c__1, &tau);
work[1] = 1.;
dgemv_("N", &irows, &icols, &c_b39, &a[ir + 1 + jcr * a_dim1],
lda, &work[1], &c__1, &c_b23, &work[icols + 1], &c__1);
d__1 = -tau;
dger_(&irows, &icols, &d__1, &work[icols + 1], &c__1, &work[1], &
c__1, &a[ir + 1 + jcr * a_dim1], lda);
dgemv_("C", &icols, n, &c_b39, &a[jcr + a_dim1], lda, &work[1], &
c__1, &c_b23, &work[icols + 1], &c__1);
d__1 = -tau;
dger_(&icols, n, &d__1, &work[1], &c__1, &work[icols + 1], &c__1,
&a[jcr + a_dim1], lda);
a[ir + jcr * a_dim1] = xnorms;
i__2 = icols - 1;
dlaset_("Full", &c__1, &i__2, &c_b23, &c_b23, &a[ir + (jcr + 1) *
a_dim1], lda);
/* L100: */
}
}
/* Scale the matrix to have norm ANORM */
if (*anorm >= 0.) {
temp = dlange_("M", n, n, &a[a_offset], lda, tempa);
if (temp > 0.) {
alpha = *anorm / temp;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
dscal_(n, &alpha, &a[j * a_dim1 + 1], &c__1);
/* L110: */
}
}
}
return 0;
/* End of DLATME */
} /* dlatme_ */
doublereal dqrt12_(integer *m, integer *n, doublereal *a, integer *lda,
doublereal *s, doublereal *work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal ret_val;
/* Local variables */
integer i__, j, mn, iscl, info;
doublereal anrm;
extern doublereal dnrm2_(integer *, doublereal *, integer *), dasum_(
integer *, doublereal *, integer *);
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *), dgebd2_(integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *
, doublereal *, doublereal *, integer *);
doublereal dummy[1];
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
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 *), dbdsqr_(char *, integer *,
integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *);
doublereal bignum, smlnum, nrmsvl;
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DQRT12 computes the singular values `svlues' of the upper trapezoid */
/* of A(1:M,1:N) and returns the ratio */
/* || s - svlues||/(||svlues||*eps*max(M,N)) */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The M-by-N matrix A. Only the upper trapezoid is referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* S (input) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The singular values of the matrix A. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= max(M*N + 4*min(M,N) + */
/* max(M,N), M*N+2*MIN( M, N )+4*N). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--s;
--work;
/* Function Body */
ret_val = 0.;
/* Test that enough workspace is supplied */
/* Computing MAX */
i__1 = *m * *n + (min(*m,*n) << 2) + max(*m,*n), i__2 = *m * *n + (min(*m,
*n) << 1) + (*n << 2);
if (*lwork < max(i__1,i__2)) {
xerbla_("DQRT12", &c__7);
return ret_val;
}
/* Quick return if possible */
mn = min(*m,*n);
if ((doublereal) mn <= 0.) {
return ret_val;
}
nrmsvl = dnrm2_(&mn, &s[1], &c__1);
/* Copy upper triangle of A into work */
dlaset_("Full", m, n, &c_b6, &c_b6, &work[1], m);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = min(j,*m);
for (i__ = 1; i__ <= i__2; ++i__) {
work[(j - 1) * *m + i__] = a[i__ + j * a_dim1];
/* L10: */
}
/* L20: */
}
/* Get machine parameters */
smlnum = dlamch_("S") / dlamch_("P");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
/* Scale work if max entry outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", m, n, &work[1], m, dummy);
iscl = 0;
if (anrm > 0. && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &work[1], m, &info);
iscl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM */
dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &work[1], m, &info);
iscl = 1;
}
if (anrm != 0.) {
/* Compute SVD of work */
dgebd2_(m, n, &work[1], m, &work[*m * *n + 1], &work[*m * *n + mn + 1]
, &work[*m * *n + (mn << 1) + 1], &work[*m * *n + mn * 3 + 1],
&work[*m * *n + (mn << 2) + 1], &info);
dbdsqr_("Upper", &mn, &c__0, &c__0, &c__0, &work[*m * *n + 1], &work[*
m * *n + mn + 1], dummy, &mn, dummy, &c__1, dummy, &mn, &work[
*m * *n + (mn << 1) + 1], &info);
if (iscl == 1) {
if (anrm > bignum) {
dlascl_("G", &c__0, &c__0, &bignum, &anrm, &mn, &c__1, &work[*
m * *n + 1], &mn, &info);
}
if (anrm < smlnum) {
dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &mn, &c__1, &work[*
m * *n + 1], &mn, &info);
}
}
} else {
i__1 = mn;
for (i__ = 1; i__ <= i__1; ++i__) {
work[*m * *n + i__] = 0.;
/* L30: */
}
}
/* Compare s and singular values of work */
daxpy_(&mn, &c_b33, &s[1], &c__1, &work[*m * *n + 1], &c__1);
ret_val = dasum_(&mn, &work[*m * *n + 1], &c__1) / (dlamch_("Epsilon") * (doublereal) max(*m,*n));
if (nrmsvl != 0.) {
ret_val /= nrmsvl;
}
return ret_val;
/* End of DQRT12 */
} /* dqrt12_ */
/* Subroutine */ int dtgsja_(char *jobu, char *jobv, char *jobq, integer *m,
integer *p, integer *n, integer *k, integer *l, doublereal *a,
integer *lda, doublereal *b, integer *ldb, doublereal *tola,
doublereal *tolb, doublereal *alpha, doublereal *beta, doublereal *u,
integer *ldu, doublereal *v, integer *ldv, doublereal *q, integer *
ldq, doublereal *work, integer *ncycle, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1,
u_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4;
doublereal d__1;
/* Local variables */
integer i__, j;
doublereal a1, a2, a3, b1, b2, b3, csq, csu, csv, snq, rwk, snu, snv;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
doublereal gamma;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
logical initq, initu, initv, wantq, upper;
doublereal error, ssmin;
logical wantu, wantv;
extern /* Subroutine */ int dlags2_(logical *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *), dlapll_(integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *);
integer kcycle;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *), dlaset_(char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *), xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DTGSJA computes the generalized singular value decomposition (GSVD) */
/* of two real upper triangular (or trapezoidal) matrices A and B. */
/* On entry, it is assumed that matrices A and B have the following */
/* forms, which may be obtained by the preprocessing subroutine DGGSVP */
/* from a general M-by-N matrix A and P-by-N matrix B: */
/* N-K-L K L */
/* A = K ( 0 A12 A13 ) if M-K-L >= 0; */
/* L ( 0 0 A23 ) */
/* M-K-L ( 0 0 0 ) */
/* N-K-L K L */
/* A = K ( 0 A12 A13 ) if M-K-L < 0; */
/* M-K ( 0 0 A23 ) */
/* N-K-L K L */
/* B = L ( 0 0 B13 ) */
/* P-L ( 0 0 0 ) */
/* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */
/* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */
/* otherwise A23 is (M-K)-by-L upper trapezoidal. */
/* On exit, */
/* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ), */
/* where U, V and Q are orthogonal matrices, Z' denotes the transpose */
/* of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are */
/* ``diagonal'' matrices, which are of the following structures: */
/* If M-K-L >= 0, */
/* K L */
/* D1 = K ( I 0 ) */
/* L ( 0 C ) */
/* M-K-L ( 0 0 ) */
/* K L */
/* D2 = L ( 0 S ) */
/* P-L ( 0 0 ) */
/* N-K-L K L */
/* ( 0 R ) = K ( 0 R11 R12 ) K */
/* L ( 0 0 R22 ) L */
/* where */
/* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */
/* S = diag( BETA(K+1), ... , BETA(K+L) ), */
/* C**2 + S**2 = I. */
/* R is stored in A(1:K+L,N-K-L+1:N) on exit. */
/* If M-K-L < 0, */
/* K M-K K+L-M */
/* D1 = K ( I 0 0 ) */
/* M-K ( 0 C 0 ) */
/* K M-K K+L-M */
/* D2 = M-K ( 0 S 0 ) */
/* K+L-M ( 0 0 I ) */
/* P-L ( 0 0 0 ) */
/* N-K-L K M-K K+L-M */
/* ( 0 R ) = K ( 0 R11 R12 R13 ) */
/* M-K ( 0 0 R22 R23 ) */
/* K+L-M ( 0 0 0 R33 ) */
/* where */
/* C = diag( ALPHA(K+1), ... , ALPHA(M) ), */
/* S = diag( BETA(K+1), ... , BETA(M) ), */
/* C**2 + S**2 = I. */
/* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored */
/* ( 0 R22 R23 ) */
/* in B(M-K+1:L,N+M-K-L+1:N) on exit. */
/* The computation of the orthogonal transformation matrices U, V or Q */
/* is optional. These matrices may either be formed explicitly, or they */
/* may be postmultiplied into input matrices U1, V1, or Q1. */
/* Arguments */
/* ========= */
/* JOBU (input) CHARACTER*1 */
/* = 'U': U must contain an orthogonal matrix U1 on entry, and */
/* the product U1*U is returned; */
/* = 'I': U is initialized to the unit matrix, and the */
/* orthogonal matrix U is returned; */
/* = 'N': U is not computed. */
/* JOBV (input) CHARACTER*1 */
/* = 'V': V must contain an orthogonal matrix V1 on entry, and */
/* the product V1*V is returned; */
/* = 'I': V is initialized to the unit matrix, and the */
/* orthogonal matrix V is returned; */
/* = 'N': V is not computed. */
/* JOBQ (input) CHARACTER*1 */
/* = 'Q': Q must contain an orthogonal matrix Q1 on entry, and */
/* the product Q1*Q is returned; */
/* = 'I': Q is initialized to the unit matrix, and the */
/* orthogonal matrix Q is returned; */
/* = 'N': Q is not computed. */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* P (input) INTEGER */
/* The number of rows of the matrix B. P >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrices A and B. N >= 0. */
/* K (input) INTEGER */
/* L (input) INTEGER */
/* K and L specify the subblocks in the input matrices A and B: */
/* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N) */
/* of A and B, whose GSVD is going to be computed by DTGSJA. */
/* See Further details. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular */
/* matrix R or part of R. See Purpose for details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */
/* On entry, the P-by-N matrix B. */
/* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains */
/* a part of R. See Purpose for details. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,P). */
/* TOLA (input) DOUBLE PRECISION */
/* TOLB (input) DOUBLE PRECISION */
/* TOLA and TOLB are the convergence criteria for the Jacobi- */
/* Kogbetliantz iteration procedure. Generally, they are the */
/* same as used in the preprocessing step, say */
/* TOLA = max(M,N)*norm(A)*MAZHEPS, */
/* TOLB = max(P,N)*norm(B)*MAZHEPS. */
/* ALPHA (output) DOUBLE PRECISION array, dimension (N) */
/* BETA (output) DOUBLE PRECISION array, dimension (N) */
/* On exit, ALPHA and BETA contain the generalized singular */
/* value pairs of A and B; */
/* ALPHA(1:K) = 1, */
/* BETA(1:K) = 0, */
/* and if M-K-L >= 0, */
/* ALPHA(K+1:K+L) = diag(C), */
/* BETA(K+1:K+L) = diag(S), */
/* or if M-K-L < 0, */
/* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0 */
/* BETA(K+1:M) = S, BETA(M+1:K+L) = 1. */
/* Furthermore, if K+L < N, */
/* ALPHA(K+L+1:N) = 0 and */
/* BETA(K+L+1:N) = 0. */
/* U (input/output) DOUBLE PRECISION array, dimension (LDU,M) */
/* On entry, if JOBU = 'U', U must contain a matrix U1 (usually */
/* the orthogonal matrix returned by DGGSVP). */
/* On exit, */
/* if JOBU = 'I', U contains the orthogonal matrix U; */
/* if JOBU = 'U', U contains the product U1*U. */
/* If JOBU = 'N', U is not referenced. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= max(1,M) if */
/* JOBU = 'U'; LDU >= 1 otherwise. */
/* V (input/output) DOUBLE PRECISION array, dimension (LDV,P) */
/* On entry, if JOBV = 'V', V must contain a matrix V1 (usually */
/* the orthogonal matrix returned by DGGSVP). */
/* On exit, */
/* if JOBV = 'I', V contains the orthogonal matrix V; */
/* if JOBV = 'V', V contains the product V1*V. */
/* If JOBV = 'N', V is not referenced. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. LDV >= max(1,P) if */
/* JOBV = 'V'; LDV >= 1 otherwise. */
/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */
/* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually */
/* the orthogonal matrix returned by DGGSVP). */
/* On exit, */
/* if JOBQ = 'I', Q contains the orthogonal matrix Q; */
/* if JOBQ = 'Q', Q contains the product Q1*Q. */
/* If JOBQ = 'N', Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= max(1,N) if */
/* JOBQ = 'Q'; LDQ >= 1 otherwise. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
/* NCYCLE (output) INTEGER */
/* The number of cycles required for convergence. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* = 1: the procedure does not converge after MAXIT cycles. */
/* Internal Parameters */
/* =================== */
/* MAXIT INTEGER */
/* MAXIT specifies the total loops that the iterative procedure */
/* may take. If after MAXIT cycles, the routine fails to */
/* converge, we return INFO = 1. */
/* Further Details */
/* =============== */
/* DTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce */
/* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L */
/* matrix B13 to the form: */
/* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1, */
/* where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose */
/* of Z. C1 and S1 are diagonal matrices satisfying */
/* C1**2 + S1**2 = I, */
/* and R1 is an L-by-L nonsingular upper triangular matrix. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--alpha;
--beta;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--work;
/* Function Body */
initu = lsame_(jobu, "I");
wantu = initu || lsame_(jobu, "U");
initv = lsame_(jobv, "I");
wantv = initv || lsame_(jobv, "V");
initq = lsame_(jobq, "I");
wantq = initq || lsame_(jobq, "Q");
*info = 0;
if (! (initu || wantu || lsame_(jobu, "N"))) {
*info = -1;
} else if (! (initv || wantv || lsame_(jobv, "N")))
{
*info = -2;
} else if (! (initq || wantq || lsame_(jobq, "N")))
{
*info = -3;
} else if (*m < 0) {
*info = -4;
} else if (*p < 0) {
*info = -5;
} else if (*n < 0) {
*info = -6;
} else if (*lda < max(1,*m)) {
*info = -10;
} else if (*ldb < max(1,*p)) {
*info = -12;
} else if (*ldu < 1 || wantu && *ldu < *m) {
*info = -18;
} else if (*ldv < 1 || wantv && *ldv < *p) {
*info = -20;
} else if (*ldq < 1 || wantq && *ldq < *n) {
*info = -22;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DTGSJA", &i__1);
return 0;
}
/* Initialize U, V and Q, if necessary */
if (initu) {
dlaset_("Full", m, m, &c_b13, &c_b14, &u[u_offset], ldu);
}
if (initv) {
dlaset_("Full", p, p, &c_b13, &c_b14, &v[v_offset], ldv);
}
if (initq) {
dlaset_("Full", n, n, &c_b13, &c_b14, &q[q_offset], ldq);
}
/* Loop until convergence */
upper = FALSE_;
for (kcycle = 1; kcycle <= 40; ++kcycle) {
upper = ! upper;
i__1 = *l - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *l;
for (j = i__ + 1; j <= i__2; ++j) {
a1 = 0.;
a2 = 0.;
a3 = 0.;
if (*k + i__ <= *m) {
a1 = a[*k + i__ + (*n - *l + i__) * a_dim1];
}
if (*k + j <= *m) {
a3 = a[*k + j + (*n - *l + j) * a_dim1];
}
b1 = b[i__ + (*n - *l + i__) * b_dim1];
b3 = b[j + (*n - *l + j) * b_dim1];
if (upper) {
if (*k + i__ <= *m) {
a2 = a[*k + i__ + (*n - *l + j) * a_dim1];
}
b2 = b[i__ + (*n - *l + j) * b_dim1];
} else {
if (*k + j <= *m) {
a2 = a[*k + j + (*n - *l + i__) * a_dim1];
}
b2 = b[j + (*n - *l + i__) * b_dim1];
}
dlags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &
csv, &snv, &csq, &snq);
/* Update (K+I)-th and (K+J)-th rows of matrix A: U'*A */
if (*k + j <= *m) {
drot_(l, &a[*k + j + (*n - *l + 1) * a_dim1], lda, &a[*k
+ i__ + (*n - *l + 1) * a_dim1], lda, &csu, &snu);
}
/* Update I-th and J-th rows of matrix B: V'*B */
drot_(l, &b[j + (*n - *l + 1) * b_dim1], ldb, &b[i__ + (*n - *
l + 1) * b_dim1], ldb, &csv, &snv);
/* Update (N-L+I)-th and (N-L+J)-th columns of matrices */
/* A and B: A*Q and B*Q */
/* Computing MIN */
i__4 = *k + *l;
i__3 = min(i__4,*m);
drot_(&i__3, &a[(*n - *l + j) * a_dim1 + 1], &c__1, &a[(*n - *
l + i__) * a_dim1 + 1], &c__1, &csq, &snq);
drot_(l, &b[(*n - *l + j) * b_dim1 + 1], &c__1, &b[(*n - *l +
i__) * b_dim1 + 1], &c__1, &csq, &snq);
if (upper) {
if (*k + i__ <= *m) {
a[*k + i__ + (*n - *l + j) * a_dim1] = 0.;
}
b[i__ + (*n - *l + j) * b_dim1] = 0.;
} else {
if (*k + j <= *m) {
a[*k + j + (*n - *l + i__) * a_dim1] = 0.;
}
b[j + (*n - *l + i__) * b_dim1] = 0.;
}
/* Update orthogonal matrices U, V, Q, if desired. */
if (wantu && *k + j <= *m) {
drot_(m, &u[(*k + j) * u_dim1 + 1], &c__1, &u[(*k + i__) *
u_dim1 + 1], &c__1, &csu, &snu);
}
if (wantv) {
drot_(p, &v[j * v_dim1 + 1], &c__1, &v[i__ * v_dim1 + 1],
&c__1, &csv, &snv);
}
if (wantq) {
drot_(n, &q[(*n - *l + j) * q_dim1 + 1], &c__1, &q[(*n - *
l + i__) * q_dim1 + 1], &c__1, &csq, &snq);
}
/* L10: */
}
/* L20: */
}
if (! upper) {
/* The matrices A13 and B13 were lower triangular at the start */
/* of the cycle, and are now upper triangular. */
/* Convergence test: test the parallelism of the corresponding */
/* rows of A and B. */
error = 0.;
/* Computing MIN */
i__2 = *l, i__3 = *m - *k;
i__1 = min(i__2,i__3);
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *l - i__ + 1;
dcopy_(&i__2, &a[*k + i__ + (*n - *l + i__) * a_dim1], lda, &
work[1], &c__1);
i__2 = *l - i__ + 1;
dcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &work[*
l + 1], &c__1);
i__2 = *l - i__ + 1;
dlapll_(&i__2, &work[1], &c__1, &work[*l + 1], &c__1, &ssmin);
error = max(error,ssmin);
/* L30: */
}
if (abs(error) <= min(*tola,*tolb)) {
goto L50;
}
}
/* End of cycle loop */
/* L40: */
}
/* The algorithm has not converged after MAXIT cycles. */
*info = 1;
goto L100;
L50:
/* If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged. */
/* Compute the generalized singular value pairs (ALPHA, BETA), and */
/* set the triangular matrix R to array A. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
alpha[i__] = 1.;
beta[i__] = 0.;
/* L60: */
}
/* Computing MIN */
i__2 = *l, i__3 = *m - *k;
i__1 = min(i__2,i__3);
for (i__ = 1; i__ <= i__1; ++i__) {
a1 = a[*k + i__ + (*n - *l + i__) * a_dim1];
b1 = b[i__ + (*n - *l + i__) * b_dim1];
if (a1 != 0.) {
gamma = b1 / a1;
/* change sign if necessary */
if (gamma < 0.) {
i__2 = *l - i__ + 1;
dscal_(&i__2, &c_b43, &b[i__ + (*n - *l + i__) * b_dim1], ldb)
;
if (wantv) {
dscal_(p, &c_b43, &v[i__ * v_dim1 + 1], &c__1);
}
}
d__1 = abs(gamma);
dlartg_(&d__1, &c_b14, &beta[*k + i__], &alpha[*k + i__], &rwk);
if (alpha[*k + i__] >= beta[*k + i__]) {
i__2 = *l - i__ + 1;
d__1 = 1. / alpha[*k + i__];
dscal_(&i__2, &d__1, &a[*k + i__ + (*n - *l + i__) * a_dim1],
lda);
} else {
i__2 = *l - i__ + 1;
d__1 = 1. / beta[*k + i__];
dscal_(&i__2, &d__1, &b[i__ + (*n - *l + i__) * b_dim1], ldb);
i__2 = *l - i__ + 1;
dcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k
+ i__ + (*n - *l + i__) * a_dim1], lda);
}
} else {
alpha[*k + i__] = 0.;
beta[*k + i__] = 1.;
i__2 = *l - i__ + 1;
dcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k +
i__ + (*n - *l + i__) * a_dim1], lda);
}
/* L70: */
}
/* Post-assignment */
i__1 = *k + *l;
for (i__ = *m + 1; i__ <= i__1; ++i__) {
alpha[i__] = 0.;
beta[i__] = 1.;
/* L80: */
}
if (*k + *l < *n) {
i__1 = *n;
for (i__ = *k + *l + 1; i__ <= i__1; ++i__) {
alpha[i__] = 0.;
beta[i__] = 0.;
/* L90: */
}
}
L100:
*ncycle = kcycle;
return 0;
/* End of DTGSJA */
} /* dtgsja_ */
/* 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 dgelsd_(integer *m, integer *n, integer *nrhs,
doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork,
integer *iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
/* Builtin functions */
double log(doublereal);
/* Local variables */
static doublereal anrm, bnrm;
static integer itau, nlvl, iascl, ibscl;
static doublereal sfmin;
static integer minmn, maxmn, itaup, itauq, mnthr, nwork;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
static integer ie, il;
extern /* Subroutine */ int dgebrd_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *);
extern doublereal dlamch_(char *);
static integer mm;
extern doublereal dlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *),
dlalsd_(char *, integer *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *), dlascl_(char *,
integer *, integer *, doublereal *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *), dgeqrf_(
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *), dlacpy_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *), dlaset_(char *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *), xerbla_(char *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static doublereal bignum;
extern /* Subroutine */ int dormbr_(char *, char *, char *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *);
static integer wlalsd;
extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *);
static integer ldwork;
extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *);
static integer minwrk, maxwrk;
static doublereal smlnum;
static logical lquery;
static integer smlsiz;
static doublereal eps;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
/* -- LAPACK driver routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1999
Purpose
=======
DGELSD computes the minimum-norm solution to a real 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 problem is solved in three steps:
(1) Reduce the coefficient matrix A to bidiagonal form with
Householder transformations, reducing the original problem
into a "bidiagonal least squares problem" (BLS)
(2) Solve the BLS using a divide and conquer approach.
(3) Apply back all the Householder tranformations to solve
the original least squares problem.
The effective rank of A is determined by treating as zero those
singular values which are less than RCOND times the largest singular
value.
The divide and conquer algorithm makes very mild assumptions about
floating point arithmetic. It will work on machines with a guard
digit in add/subtract, or on those binary machines without guard
digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
Cray-2. It could conceivably fail on hexadecimal or decimal machines
without guard digits, but we know of none.
Arguments
=========
M (input) INTEGER
The number of rows of A. M >= 0.
N (input) INTEGER
The number of columns of 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) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, A has been destroyed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (input/output) DOUBLE PRECISION 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,max(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) DOUBLE PRECISION array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK must be at least 1.
The exact minimum amount of workspace needed depends on M,
N and NRHS. As long as LWORK is at least
12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2,
if M is greater than or equal to N or
12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2,
if M is less than N, the code will execute correctly.
SMLSIZ is returned by ILAENV and is equal to the maximum
size of the subproblems at the bottom of the computation
tree (usually about 25), and
NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
For good performance, LWORK should generally be larger.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
IWORK (workspace) INTEGER array, dimension (LIWORK)
LIWORK >= 3 * MINMN * NLVL + 11 * MINMN,
where MINMN = MIN( M,N ).
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.
Further Details
===============
Based on contributions by
Ming Gu and Ren-Cang Li, Computer Science Division, University of
California at Berkeley, USA
Osni Marques, LBNL/NERSC, USA
=====================================================================
Test the input arguments.
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;
--work;
--iwork;
/* Function Body */
*info = 0;
minmn = min(*m,*n);
maxmn = max(*m,*n);
mnthr = ilaenv_(&c__6, "DGELSD", " ", m, n, nrhs, &c_n1, (ftnlen)6, (
ftnlen)1);
lquery = *lwork == -1;
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;
}
smlsiz = ilaenv_(&c__9, "DGELSD", " ", &c__0, &c__0, &c__0, &c__0, (
ftnlen)6, (ftnlen)1);
/* 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.
NB refers to the optimal block size for the immediately
following subroutine, as returned by ILAENV.) */
minwrk = 1;
minmn = max(1,minmn);
/* Computing MAX */
i__1 = (integer) (log((doublereal) minmn / (doublereal) (smlsiz + 1)) /
log(2.)) + 1;
nlvl = max(i__1,0);
if (*info == 0) {
maxwrk = 0;
mm = *m;
if (*m >= *n && *m >= mnthr) {
/* Path 1a - overdetermined, with many more rows than columns. */
mm = *n;
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m,
n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "DORMQR", "LT",
m, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)2);
maxwrk = max(i__1,i__2);
}
if (*m >= *n) {
/* Path 1 - overdetermined or exactly determined.
Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + (mm + *n) * ilaenv_(&c__1, "DGEBRD"
, " ", &mm, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, "DORMBR",
"QLT", &mm, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + (*n - 1) * ilaenv_(&c__1, "DORMBR",
"PLN", n, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3);
maxwrk = max(i__1,i__2);
/* Computing 2nd power */
i__1 = smlsiz + 1;
wlalsd = *n * 9 + (*n << 1) * smlsiz + (*n << 3) * nlvl + *n * *
nrhs + i__1 * i__1;
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + wlalsd;
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = max(i__1,i__2),
i__2 = *n * 3 + wlalsd;
minwrk = max(i__1,i__2);
}
if (*n > *m) {
/* Computing 2nd power */
i__1 = smlsiz + 1;
wlalsd = *m * 9 + (*m << 1) * smlsiz + (*m << 3) * nlvl + *m * *
nrhs + i__1 * i__1;
if (*n >= mnthr) {
/* Path 2a - underdetermined, with many more columns
than rows. */
maxwrk = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1,
&c_n1, (ftnlen)6, (ftnlen)1);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) *
ilaenv_(&c__1, "DGEBRD", " ", m, m, &c_n1, &c_n1, (
ftnlen)6, (ftnlen)1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs * ilaenv_(&
c__1, "DORMBR", "QLT", m, nrhs, m, &c_n1, (ftnlen)6, (
ftnlen)3);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) *
ilaenv_(&c__1, "DORMBR", "PLN", m, nrhs, m, &c_n1, (
ftnlen)6, (ftnlen)3);
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, "DORMLQ",
"LT", n, nrhs, m, &c_n1, (ftnlen)6, (ftnlen)2);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + wlalsd;
maxwrk = max(i__1,i__2);
} else {
/* Path 2 - remaining underdetermined cases. */
maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, "DGEBRD", " ", m,
n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1, "DORMBR"
, "QLT", m, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR",
"PLN", n, nrhs, m, &c_n1, (ftnlen)6, (ftnlen)3);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + wlalsd;
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *m, i__1 = max(i__1,i__2),
i__2 = *m * 3 + wlalsd;
minwrk = max(i__1,i__2);
}
minwrk = min(minwrk,maxwrk);
work[1] = (doublereal) maxwrk;
if (*lwork < minwrk && ! lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGELSD", &i__1);
return 0;
} else if (lquery) {
goto L10;
}
/* 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 entry outside range [SMLNUM,BIGNUM]. */
anrm = dlange_("M", m, n, &a[a_offset], lda, &work[1]);
iascl = 0;
if (anrm > 0. && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM. */
dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
info);
iascl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM. */
dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
info);
iascl = 2;
} else if (anrm == 0.) {
/* Matrix all zero. Return zero solution. */
i__1 = max(*m,*n);
dlaset_("F", &i__1, nrhs, &c_b82, &c_b82, &b[b_offset], ldb);
dlaset_("F", &minmn, &c__1, &c_b82, &c_b82, &s[1], &c__1);
*rank = 0;
goto L10;
}
/* Scale B if max entry outside range [SMLNUM,BIGNUM]. */
bnrm = dlange_("M", m, nrhs, &b[b_offset], ldb, &work[1]);
ibscl = 0;
if (bnrm > 0. && bnrm < smlnum) {
/* Scale matrix norm up to SMLNUM. */
dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
info);
ibscl = 1;
} else if (bnrm > bignum) {
/* Scale matrix norm down to BIGNUM. */
dlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
info);
ibscl = 2;
}
/* If M < N make sure certain entries of B are zero. */
if (*m < *n) {
i__1 = *n - *m;
dlaset_("F", &i__1, nrhs, &c_b82, &c_b82, &b_ref(*m + 1, 1), ldb);
}
/* Overdetermined case. */
if (*m >= *n) {
/* Path 1 - overdetermined or exactly determined. */
mm = *m;
if (*m >= mnthr) {
/* Path 1a - overdetermined, with many more rows than columns. */
mm = *n;
itau = 1;
nwork = itau + *n;
/* Compute A=Q*R.
(Workspace: need 2*N, prefer N+N*NB) */
i__1 = *lwork - nwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1,
info);
/* Multiply B by transpose(Q).
(Workspace: need N+NRHS, prefer N+NRHS*NB) */
i__1 = *lwork - nwork + 1;
dormqr_("L", "T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[
b_offset], ldb, &work[nwork], &i__1, info);
/* Zero out below R. */
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
dlaset_("L", &i__1, &i__2, &c_b82, &c_b82, &a_ref(2, 1), lda);
}
}
ie = 1;
itauq = ie + *n;
itaup = itauq + *n;
nwork = itaup + *n;
/* Bidiagonalize R in A.
(Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) */
i__1 = *lwork - nwork + 1;
dgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
work[itaup], &work[nwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors of R.
(Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) */
i__1 = *lwork - nwork + 1;
dormbr_("Q", "L", "T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq],
&b[b_offset], ldb, &work[nwork], &i__1, info);
/* Solve the bidiagonal least squares problem. */
dlalsd_("U", &smlsiz, n, nrhs, &s[1], &work[ie], &b[b_offset], ldb,
rcond, rank, &work[nwork], &iwork[1], info);
if (*info != 0) {
goto L10;
}
/* Multiply B by right bidiagonalizing vectors of R. */
i__1 = *lwork - nwork + 1;
dormbr_("P", "L", "N", n, nrhs, n, &a[a_offset], lda, &work[itaup], &
b[b_offset], ldb, &work[nwork], &i__1, info);
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = *m, i__2 = (*m << 1) - 4, i__1 = max(i__1,i__2), i__1 = max(
i__1,*nrhs), i__2 = *n - *m * 3;
if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__1,i__2)) {
/* Path 2a - underdetermined, with many more columns than rows
and sufficient workspace for an efficient algorithm. */
ldwork = *m;
/* Computing MAX
Computing MAX */
i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 =
max(i__3,*nrhs), i__4 = *n - *m * 3;
i__1 = (*m << 2) + *m * *lda + max(i__3,i__4), i__2 = *m * *lda +
*m + *m * *nrhs;
if (*lwork >= max(i__1,i__2)) {
ldwork = *lda;
}
itau = 1;
nwork = *m + 1;
/* Compute A=L*Q.
(Workspace: need 2*M, prefer M+M*NB) */
i__1 = *lwork - nwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1,
info);
il = nwork;
/* Copy L to WORK(IL), zeroing out above its diagonal. */
dlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork);
i__1 = *m - 1;
i__2 = *m - 1;
dlaset_("U", &i__1, &i__2, &c_b82, &c_b82, &work[il + ldwork], &
ldwork);
ie = il + ldwork * *m;
itauq = ie + *m;
itaup = itauq + *m;
nwork = itaup + *m;
/* Bidiagonalize L in WORK(IL).
(Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) */
i__1 = *lwork - nwork + 1;
dgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq],
&work[itaup], &work[nwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors of L.
(Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */
i__1 = *lwork - nwork + 1;
dormbr_("Q", "L", "T", m, nrhs, m, &work[il], &ldwork, &work[
itauq], &b[b_offset], ldb, &work[nwork], &i__1, info);
/* Solve the bidiagonal least squares problem. */
dlalsd_("U", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset],
ldb, rcond, rank, &work[nwork], &iwork[1], info);
if (*info != 0) {
goto L10;
}
/* Multiply B by right bidiagonalizing vectors of L. */
i__1 = *lwork - nwork + 1;
dormbr_("P", "L", "N", m, nrhs, m, &work[il], &ldwork, &work[
itaup], &b[b_offset], ldb, &work[nwork], &i__1, info);
/* Zero out below first M rows of B. */
i__1 = *n - *m;
dlaset_("F", &i__1, nrhs, &c_b82, &c_b82, &b_ref(*m + 1, 1), ldb);
nwork = itau + *m;
/* Multiply transpose(Q) by B.
(Workspace: need M+NRHS, prefer M+NRHS*NB) */
i__1 = *lwork - nwork + 1;
dormlq_("L", "T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[
b_offset], ldb, &work[nwork], &i__1, info);
} else {
/* Path 2 - remaining underdetermined cases. */
ie = 1;
itauq = ie + *m;
itaup = itauq + *m;
nwork = itaup + *m;
/* Bidiagonalize A.
(Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */
i__1 = *lwork - nwork + 1;
dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
work[itaup], &work[nwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors.
(Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) */
i__1 = *lwork - nwork + 1;
dormbr_("Q", "L", "T", m, nrhs, n, &a[a_offset], lda, &work[itauq]
, &b[b_offset], ldb, &work[nwork], &i__1, info);
/* Solve the bidiagonal least squares problem. */
dlalsd_("L", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset],
ldb, rcond, rank, &work[nwork], &iwork[1], info);
if (*info != 0) {
goto L10;
}
/* Multiply B by right bidiagonalizing vectors of A. */
i__1 = *lwork - nwork + 1;
dormbr_("P", "L", "N", n, nrhs, m, &a[a_offset], lda, &work[itaup]
, &b[b_offset], ldb, &work[nwork], &i__1, info);
}
}
/* Undo scaling. */
if (iascl == 1) {
dlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
info);
dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
minmn, info);
} else if (iascl == 2) {
dlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
info);
dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
minmn, info);
}
if (ibscl == 1) {
dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
info);
} else if (ibscl == 2) {
dlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
info);
}
L10:
work[1] = (doublereal) maxwrk;
return 0;
/* End of DGELSD */
} /* dgelsd_ */
/* Subroutine */ int dlalsd_(char *uplo, integer *smlsiz, integer *n, integer
*nrhs, doublereal *d__, doublereal *e, doublereal *b, integer *ldb,
doublereal *rcond, integer *rank, doublereal *work, integer *iwork,
integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double log(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
integer c__, i__, j, k;
doublereal r__;
integer s, u, z__;
doublereal cs;
integer bx;
doublereal sn;
integer st, vt, nm1, st1;
doublereal eps;
integer iwk;
doublereal tol;
integer difl, difr;
doublereal rcnd;
integer perm, nsub;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
integer nlvl, sqre, bxst;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *),
dcopy_(integer *, doublereal *, integer *, doublereal *, integer
*);
integer poles, sizei, nsize, nwork, icmpq1, icmpq2;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlasda_(integer *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *), dlalsa_(integer *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *, integer *), dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer
*, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *), dlacpy_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *), dlartg_(doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *), dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *);
integer givcol;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *);
doublereal orgnrm;
integer givnum, givptr, smlszp;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLALSD uses the singular value decomposition of A to solve the least */
/* squares problem of finding X to minimize the Euclidean norm of each */
/* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B */
/* are N-by-NRHS. The solution X overwrites B. */
/* The singular values of A smaller than RCOND times the largest */
/* singular value are treated as zero in solving the least squares */
/* problem; in this case a minimum norm solution is returned. */
/* The actual singular values are returned in D in ascending order. */
/* This code makes very mild assumptions about floating point */
/* arithmetic. It will work on machines with a guard digit in */
/* add/subtract, or on those binary machines without guard digits */
/* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. */
/* It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': D and E define an upper bidiagonal matrix. */
/* = 'L': D and E define a lower bidiagonal matrix. */
/* SMLSIZ (input) INTEGER */
/* The maximum size of the subproblems at the bottom of the */
/* computation tree. */
/* N (input) INTEGER */
/* The dimension of the bidiagonal matrix. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of columns of B. NRHS must be at least 1. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry D contains the main diagonal of the bidiagonal */
/* matrix. On exit, if INFO = 0, D contains its singular values. */
/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
/* Contains the super-diagonal entries of the bidiagonal matrix. */
/* On exit, E has been destroyed. */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* On input, B contains the right hand sides of the least */
/* squares problem. On output, B contains the solution X. */
/* LDB (input) INTEGER */
/* The leading dimension of B in the calling subprogram. */
/* LDB must be at least max(1,N). */
/* RCOND (input) DOUBLE PRECISION */
/* The singular values of A less than or equal to RCOND times */
/* the largest singular value are treated as zero in solving */
/* the least squares problem. If RCOND is negative, */
/* machine precision is used instead. */
/* For example, if diag(S)*X=B were the least squares problem, */
/* where diag(S) is a diagonal matrix of singular values, the */
/* solution would be X(i) = B(i) / S(i) if S(i) is greater than */
/* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to */
/* RCOND*max(S). */
/* RANK (output) INTEGER */
/* The number of singular values of A greater than RCOND times */
/* the largest singular value. */
/* WORK (workspace) DOUBLE PRECISION array, dimension at least */
/* (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2), */
/* where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1). */
/* IWORK (workspace) INTEGER array, dimension at least */
/* (3*N*NLVL + 11*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: The algorithm failed to compute an singular value while */
/* working on the submatrix lying in rows and columns */
/* INFO/(N+1) through MOD(INFO,N+1). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */
/* California at Berkeley, USA */
/* Osni Marques, LBNL/NERSC, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -3;
} else if (*nrhs < 1) {
*info = -4;
} else if (*ldb < 1 || *ldb < *n) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLALSD", &i__1);
return 0;
}
eps = dlamch_("Epsilon");
/* Set up the tolerance. */
if (*rcond <= 0. || *rcond >= 1.) {
rcnd = eps;
} else {
rcnd = *rcond;
}
*rank = 0;
/* Quick return if possible. */
if (*n == 0) {
return 0;
} else if (*n == 1) {
if (d__[1] == 0.) {
dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[b_offset], ldb);
} else {
*rank = 1;
dlascl_("G", &c__0, &c__0, &d__[1], &c_b11, &c__1, nrhs, &b[
b_offset], ldb, info);
d__[1] = abs(d__[1]);
}
return 0;
}
/* Rotate the matrix if it is lower bidiagonal. */
if (*(unsigned char *)uplo == 'L') {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
if (*nrhs == 1) {
drot_(&c__1, &b[i__ + b_dim1], &c__1, &b[i__ + 1 + b_dim1], &
c__1, &cs, &sn);
} else {
work[(i__ << 1) - 1] = cs;
work[i__ * 2] = sn;
}
/* L10: */
}
if (*nrhs > 1) {
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n - 1;
for (j = 1; j <= i__2; ++j) {
cs = work[(j << 1) - 1];
sn = work[j * 2];
drot_(&c__1, &b[j + i__ * b_dim1], &c__1, &b[j + 1 + i__ *
b_dim1], &c__1, &cs, &sn);
/* L20: */
}
/* L30: */
}
}
}
/* Scale. */
nm1 = *n - 1;
orgnrm = dlanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.) {
dlaset_("A", n, nrhs, &c_b6, &c_b6, &b[b_offset], ldb);
return 0;
}
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, &c__1, &d__[1], n, info);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, &nm1, &c__1, &e[1], &nm1,
info);
/* If N is smaller than the minimum divide size SMLSIZ, then solve */
/* the problem with another solver. */
if (*n <= *smlsiz) {
nwork = *n * *n + 1;
dlaset_("A", n, n, &c_b6, &c_b11, &work[1], n);
dlasdq_("U", &c__0, n, n, &c__0, nrhs, &d__[1], &e[1], &work[1], n, &
work[1], n, &b[b_offset], ldb, &work[nwork], info);
if (*info != 0) {
return 0;
}
tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1));
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] <= tol) {
dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[i__ + b_dim1], ldb);
} else {
dlascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &b[
i__ + b_dim1], ldb, info);
++(*rank);
}
/* L40: */
}
dgemm_("T", "N", n, nrhs, n, &c_b11, &work[1], n, &b[b_offset], ldb, &
c_b6, &work[nwork], n);
dlacpy_("A", n, nrhs, &work[nwork], n, &b[b_offset], ldb);
/* Unscale. */
dlascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n,
info);
dlasrt_("D", n, &d__[1], info);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset],
ldb, info);
return 0;
}
/* Book-keeping and setting up some constants. */
nlvl = (integer) (log((doublereal) (*n) / (doublereal) (*smlsiz + 1)) /
log(2.)) + 1;
smlszp = *smlsiz + 1;
u = 1;
vt = *smlsiz * *n + 1;
difl = vt + smlszp * *n;
difr = difl + nlvl * *n;
z__ = difr + (nlvl * *n << 1);
c__ = z__ + nlvl * *n;
s = c__ + *n;
poles = s + *n;
givnum = poles + (nlvl << 1) * *n;
bx = givnum + (nlvl << 1) * *n;
nwork = bx + *n * *nrhs;
sizei = *n + 1;
k = sizei + *n;
givptr = k + *n;
perm = givptr + *n;
givcol = perm + nlvl * *n;
iwk = givcol + (nlvl * *n << 1);
st = 1;
sqre = 0;
icmpq1 = 1;
icmpq2 = 0;
nsub = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = d__[i__], abs(d__1)) < eps) {
d__[i__] = d_sign(&eps, &d__[i__]);
}
/* L50: */
}
i__1 = nm1;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) {
++nsub;
iwork[nsub] = st;
/* Subproblem found. First determine its size and then */
/* apply divide and conquer on it. */
if (i__ < nm1) {
/* A subproblem with E(I) small for I < NM1. */
nsize = i__ - st + 1;
iwork[sizei + nsub - 1] = nsize;
} else if ((d__1 = e[i__], abs(d__1)) >= eps) {
/* A subproblem with E(NM1) not too small but I = NM1. */
nsize = *n - st + 1;
iwork[sizei + nsub - 1] = nsize;
} else {
/* A subproblem with E(NM1) small. This implies an */
/* 1-by-1 subproblem at D(N), which is not solved */
/* explicitly. */
nsize = i__ - st + 1;
iwork[sizei + nsub - 1] = nsize;
++nsub;
iwork[nsub] = *n;
iwork[sizei + nsub - 1] = 1;
dcopy_(nrhs, &b[*n + b_dim1], ldb, &work[bx + nm1], n);
}
st1 = st - 1;
if (nsize == 1) {
/* This is a 1-by-1 subproblem and is not solved */
/* explicitly. */
dcopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n);
} else if (nsize <= *smlsiz) {
/* This is a small subproblem and is solved by DLASDQ. */
dlaset_("A", &nsize, &nsize, &c_b6, &c_b11, &work[vt + st1],
n);
dlasdq_("U", &c__0, &nsize, &nsize, &c__0, nrhs, &d__[st], &e[
st], &work[vt + st1], n, &work[nwork], n, &b[st +
b_dim1], ldb, &work[nwork], info);
if (*info != 0) {
return 0;
}
dlacpy_("A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx +
st1], n);
} else {
/* A large problem. Solve it using divide and conquer. */
dlasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], &
work[u + st1], n, &work[vt + st1], &iwork[k + st1], &
work[difl + st1], &work[difr + st1], &work[z__ + st1],
&work[poles + st1], &iwork[givptr + st1], &iwork[
givcol + st1], n, &iwork[perm + st1], &work[givnum +
st1], &work[c__ + st1], &work[s + st1], &work[nwork],
&iwork[iwk], info);
if (*info != 0) {
return 0;
}
bxst = bx + st1;
dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b[st + b_dim1], ldb, &
work[bxst], n, &work[u + st1], n, &work[vt + st1], &
iwork[k + st1], &work[difl + st1], &work[difr + st1],
&work[z__ + st1], &work[poles + st1], &iwork[givptr +
st1], &iwork[givcol + st1], n, &iwork[perm + st1], &
work[givnum + st1], &work[c__ + st1], &work[s + st1],
&work[nwork], &iwork[iwk], info);
if (*info != 0) {
return 0;
}
}
st = i__ + 1;
}
/* L60: */
}
/* Apply the singular values and treat the tiny ones as zero. */
tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1));
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Some of the elements in D can be negative because 1-by-1 */
/* subproblems were not solved explicitly. */
if ((d__1 = d__[i__], abs(d__1)) <= tol) {
dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &work[bx + i__ - 1], n);
} else {
++(*rank);
dlascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &work[
bx + i__ - 1], n, info);
}
d__[i__] = (d__1 = d__[i__], abs(d__1));
/* L70: */
}
/* Now apply back the right singular vectors. */
icmpq2 = 1;
i__1 = nsub;
for (i__ = 1; i__ <= i__1; ++i__) {
st = iwork[i__];
st1 = st - 1;
nsize = iwork[sizei + i__ - 1];
bxst = bx + st1;
if (nsize == 1) {
dcopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb);
} else if (nsize <= *smlsiz) {
dgemm_("T", "N", &nsize, nrhs, &nsize, &c_b11, &work[vt + st1], n,
&work[bxst], n, &c_b6, &b[st + b_dim1], ldb);
} else {
dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b[st +
b_dim1], ldb, &work[u + st1], n, &work[vt + st1], &iwork[
k + st1], &work[difl + st1], &work[difr + st1], &work[z__
+ st1], &work[poles + st1], &iwork[givptr + st1], &iwork[
givcol + st1], n, &iwork[perm + st1], &work[givnum + st1],
&work[c__ + st1], &work[s + st1], &work[nwork], &iwork[
iwk], info);
if (*info != 0) {
return 0;
}
}
/* L80: */
}
/* Unscale and sort the singular values. */
dlascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info);
dlasrt_("D", n, &d__[1], info);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb,
info);
return 0;
/* End of DLALSD */
} /* dlalsd_ */
/* Subroutine */ int dggevx_(char *balanc, char *jobvl, char *jobvr, char *
sense, integer *n, doublereal *a, integer *lda, doublereal *b,
integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *
beta, doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr,
integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale,
doublereal *abnrm, doublereal *bbnrm, doublereal *rconde, doublereal *
rcondv, doublereal *work, integer *lwork, integer *iwork, logical *
bwork, integer *info)
{
/* -- LAPACK driver 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
=======
DGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)
the generalized eigenvalues, and optionally, the left and/or right
generalized eigenvectors.
Optionally also, it computes a balancing transformation to improve
the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
the eigenvalues (RCONDE), and reciprocal condition numbers for the
right eigenvectors (RCONDV).
A generalized eigenvalue for a pair of matrices (A,B) is a scalar
lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
singular. It is usually represented as the pair (alpha,beta), as
there is a reasonable interpretation for beta=0, and even for both
being zero.
The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
of (A,B) satisfies
A * v(j) = lambda(j) * B * v(j) .
The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
of (A,B) satisfies
u(j)**H * A = lambda(j) * u(j)**H * B.
where u(j)**H is the conjugate-transpose of u(j).
Arguments
=========
BALANC (input) CHARACTER*1
Specifies the balance option to be performed.
= 'N': do not diagonally scale or permute;
= 'P': permute only;
= 'S': scale only;
= 'B': both permute and scale.
Computed reciprocal condition numbers will be for the
matrices after permuting and/or balancing. Permuting does
not change condition numbers (in exact arithmetic), but
balancing does.
JOBVL (input) CHARACTER*1
= 'N': do not compute the left generalized eigenvectors;
= 'V': compute the left generalized eigenvectors.
JOBVR (input) CHARACTER*1
= 'N': do not compute the right generalized eigenvectors;
= 'V': compute the right generalized eigenvectors.
SENSE (input) CHARACTER*1
Determines which reciprocal condition numbers are computed.
= 'N': none are computed;
= 'E': computed for eigenvalues only;
= 'V': computed for eigenvectors only;
= 'B': computed for eigenvalues and eigenvectors.
N (input) INTEGER
The order of the matrices A, B, VL, and VR. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
On entry, the matrix A in the pair (A,B).
On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'
or both, then A contains the first part of the real Schur
form of the "balanced" versions of the input A and B.
LDA (input) INTEGER
The leading dimension of A. LDA >= max(1,N).
B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
On entry, the matrix B in the pair (A,B).
On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'
or both, then B contains the second part of the real Schur
form of the "balanced" versions of the input A and B.
LDB (input) INTEGER
The leading dimension of B. LDB >= max(1,N).
ALPHAR (output) DOUBLE PRECISION array, dimension (N)
ALPHAI (output) DOUBLE PRECISION array, dimension (N)
BETA (output) DOUBLE PRECISION array, dimension (N)
On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
be the generalized eigenvalues. If ALPHAI(j) is zero, then
the j-th eigenvalue is real; if positive, then the j-th and
(j+1)-st eigenvalues are a complex conjugate pair, with
ALPHAI(j+1) negative.
Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
may easily over- or underflow, and BETA(j) may even be zero.
Thus, the user should avoid naively computing the ratio
ALPHA/BETA. However, ALPHAR and ALPHAI will be always less
than and usually comparable with norm(A) in magnitude, and
BETA always less than and usually comparable with norm(B).
VL (output) DOUBLE PRECISION array, dimension (LDVL,N)
If JOBVL = 'V', the left eigenvectors u(j) are stored one
after another in the columns of VL, in the same order as
their eigenvalues. If the j-th eigenvalue is real, then
u(j) = VL(:,j), the j-th column of VL. If the j-th and
(j+1)-th eigenvalues form a complex conjugate pair, then
u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).
Each eigenvector will be scaled so the largest component have
abs(real part) + abs(imag. part) = 1.
Not referenced if JOBVL = 'N'.
LDVL (input) INTEGER
The leading dimension of the matrix VL. LDVL >= 1, and
if JOBVL = 'V', LDVL >= N.
VR (output) DOUBLE PRECISION array, dimension (LDVR,N)
If JOBVR = 'V', the right eigenvectors v(j) are stored one
after another in the columns of VR, in the same order as
their eigenvalues. If the j-th eigenvalue is real, then
v(j) = VR(:,j), the j-th column of VR. If the j-th and
(j+1)-th eigenvalues form a complex conjugate pair, then
v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).
Each eigenvector will be scaled so the largest component have
abs(real part) + abs(imag. part) = 1.
Not referenced if JOBVR = 'N'.
LDVR (input) INTEGER
The leading dimension of the matrix VR. LDVR >= 1, and
if JOBVR = 'V', LDVR >= N.
ILO,IHI (output) INTEGER
ILO and IHI are integer values such that on exit
A(i,j) = 0 and B(i,j) = 0 if i > j and
j = 1,...,ILO-1 or i = IHI+1,...,N.
If BALANC = 'N' or 'S', ILO = 1 and IHI = N.
LSCALE (output) DOUBLE PRECISION array, dimension (N)
Details of the permutations and scaling factors applied
to the left side of A and B. If PL(j) is the index of the
row interchanged with row j, and DL(j) is the scaling
factor applied to row j, then
LSCALE(j) = PL(j) for j = 1,...,ILO-1
= DL(j) for j = ILO,...,IHI
= PL(j) for j = IHI+1,...,N.
The order in which the interchanges are made is N to IHI+1,
then 1 to ILO-1.
RSCALE (output) DOUBLE PRECISION array, dimension (N)
Details of the permutations and scaling factors applied
to the right side of A and B. If PR(j) is the index of the
column interchanged with column j, and DR(j) is the scaling
factor applied to column j, then
RSCALE(j) = PR(j) for j = 1,...,ILO-1
= DR(j) for j = ILO,...,IHI
= PR(j) for j = IHI+1,...,N
The order in which the interchanges are made is N to IHI+1,
then 1 to ILO-1.
ABNRM (output) DOUBLE PRECISION
The one-norm of the balanced matrix A.
BBNRM (output) DOUBLE PRECISION
The one-norm of the balanced matrix B.
RCONDE (output) DOUBLE PRECISION array, dimension (N)
If SENSE = 'E' or 'B', the reciprocal condition numbers of
the selected eigenvalues, stored in consecutive elements of
the array. For a complex conjugate pair of eigenvalues two
consecutive elements of RCONDE are set to the same value.
Thus RCONDE(j), RCONDV(j), and the j-th columns of VL and VR
all correspond to the same eigenpair (but not in general the
j-th eigenpair, unless all eigenpairs are selected).
If SENSE = 'V', RCONDE is not referenced.
RCONDV (output) DOUBLE PRECISION array, dimension (N)
If SENSE = 'V' or 'B', the estimated reciprocal condition
numbers of the selected eigenvectors, stored in consecutive
elements of the array. For a complex eigenvector two
consecutive elements of RCONDV are set to the same value. If
the eigenvalues cannot be reordered to compute RCONDV(j),
RCONDV(j) is set to 0; this can only occur when the true
value would be very small anyway.
If SENSE = 'E', RCONDV is not referenced.
WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,6*N).
If SENSE = 'E', LWORK >= 12*N.
If SENSE = 'V' or 'B', LWORK >= 2*N*N+12*N+16.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
IWORK (workspace) INTEGER array, dimension (N+6)
If SENSE = 'E', IWORK is not referenced.
BWORK (workspace) LOGICAL array, dimension (N)
If SENSE = 'N', BWORK is not referenced.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
= 1,...,N:
The QZ iteration failed. No eigenvectors have been
calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
should be correct for j=INFO+1,...,N.
> N: =N+1: other than QZ iteration failed in DHGEQZ.
=N+2: error return from DTGEVC.
Further Details
===============
Balancing a matrix pair (A,B) includes, first, permuting rows and
columns to isolate eigenvalues, second, applying diagonal similarity
transformation to the rows and columns to make the rows and columns
as close in norm as possible. The computed reciprocal condition
numbers correspond to the balanced matrix. Permuting rows and columns
will not change the condition numbers (in exact arithmetic) but
diagonal scaling will. For further explanation of balancing, see
section 4.11.1.2 of LAPACK Users' Guide.
An approximate error bound on the chordal distance between the i-th
computed generalized eigenvalue w and the corresponding exact
eigenvalue lambda is
chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)
An approximate error bound for the angle between the i-th computed
eigenvector VL(i) or VR(i) is given by
EPS * norm(ABNRM, BBNRM) / DIF(i).
For further explanation of the reciprocal condition numbers RCONDE
and RCONDV, see section 4.11 of LAPACK User's Guide.
=====================================================================
Decode the input arguments
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c__0 = 0;
static doublereal c_b47 = 0.;
static doublereal c_b48 = 1.;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
vr_offset, i__1, i__2;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static logical pair;
static doublereal anrm, bnrm;
static integer ierr, itau;
static doublereal temp;
static logical ilvl, ilvr;
static integer iwrk, iwrk1, i__, j, m;
extern logical lsame_(char *, char *);
static integer icols, irows;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
static integer jc;
extern /* Subroutine */ int dggbak_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, integer *), dggbal_(char *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *);
static integer in;
extern doublereal dlamch_(char *);
static integer mm;
extern doublereal dlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
static integer jr;
extern /* Subroutine */ int dgghrd_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *), dlascl_(char *, integer *, integer *, doublereal
*, doublereal *, integer *, integer *, doublereal *, integer *,
integer *);
static logical ilascl, ilbscl;
extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *),
dlacpy_(char *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *);
static logical ldumma[1];
static char chtemp[1];
static doublereal bignum;
extern /* Subroutine */ int dhgeqz_(char *, char *, char *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *), dlaset_(char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *);
static integer ijobvl;
extern /* Subroutine */ int dtgevc_(char *, char *, logical *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, integer *,
doublereal *, integer *), dtgsna_(char *, char *,
logical *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, integer *), xerbla_(char *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer ijobvr;
static logical wantsb;
extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *);
static doublereal anrmto;
static logical wantse;
static doublereal bnrmto;
extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *);
static integer minwrk, maxwrk;
static logical wantsn;
static doublereal smlnum;
static logical lquery, wantsv;
static doublereal eps;
static logical ilv;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define vl_ref(a_1,a_2) vl[(a_2)*vl_dim1 + a_1]
#define vr_ref(a_1,a_2) vr[(a_2)*vr_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--alphar;
--alphai;
--beta;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1 * 1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1 * 1;
vr -= vr_offset;
--lscale;
--rscale;
--rconde;
--rcondv;
--work;
--iwork;
--bwork;
/* Function Body */
if (lsame_(jobvl, "N")) {
ijobvl = 1;
ilvl = FALSE_;
} else if (lsame_(jobvl, "V")) {
ijobvl = 2;
ilvl = TRUE_;
} else {
ijobvl = -1;
ilvl = FALSE_;
}
if (lsame_(jobvr, "N")) {
ijobvr = 1;
ilvr = FALSE_;
} else if (lsame_(jobvr, "V")) {
ijobvr = 2;
ilvr = TRUE_;
} else {
ijobvr = -1;
ilvr = FALSE_;
}
ilv = ilvl || ilvr;
wantsn = lsame_(sense, "N");
wantse = lsame_(sense, "E");
wantsv = lsame_(sense, "V");
wantsb = lsame_(sense, "B");
/* Test the input arguments */
*info = 0;
lquery = *lwork == -1;
if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P")
|| lsame_(balanc, "B"))) {
*info = -1;
} else if (ijobvl <= 0) {
*info = -2;
} else if (ijobvr <= 0) {
*info = -3;
} else if (! (wantsn || wantse || wantsb || wantsv)) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldvl < 1 || ilvl && *ldvl < *n) {
*info = -14;
} else if (*ldvr < 1 || ilvr && *ldvr < *n) {
*info = -16;
}
/* 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.
NB refers to the optimal block size for the immediately
following subroutine, as returned by ILAENV. The workspace is
computed assuming ILO = 1 and IHI = N, the worst case.) */
minwrk = 1;
if (*info == 0 && (*lwork >= 1 || lquery)) {
maxwrk = *n * 5 + *n * ilaenv_(&c__1, "DGEQRF", " ", n, &c__1, n, &
c__0, (ftnlen)6, (ftnlen)1);
/* Computing MAX */
i__1 = 1, i__2 = *n * 6;
minwrk = max(i__1,i__2);
if (wantse) {
/* Computing MAX */
i__1 = 1, i__2 = *n * 12;
minwrk = max(i__1,i__2);
} else if (wantsv || wantsb) {
minwrk = (*n << 1) * *n + *n * 12 + 16;
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) * *n + *n * 12 + 16;
maxwrk = max(i__1,i__2);
}
work[1] = (doublereal) maxwrk;
}
if (*lwork < minwrk && ! lquery) {
*info = -26;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGGEVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]);
ilascl = FALSE_;
if (anrm > 0. && anrm < smlnum) {
anrmto = smlnum;
ilascl = TRUE_;
} else if (anrm > bignum) {
anrmto = bignum;
ilascl = TRUE_;
}
if (ilascl) {
dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
ierr);
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]);
ilbscl = FALSE_;
if (bnrm > 0. && bnrm < smlnum) {
bnrmto = smlnum;
ilbscl = TRUE_;
} else if (bnrm > bignum) {
bnrmto = bignum;
ilbscl = TRUE_;
}
if (ilbscl) {
dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
ierr);
}
/* Permute and/or balance the matrix pair (A,B)
(Workspace: need 6*N) */
dggbal_(balanc, n, &a[a_offset], lda, &b[b_offset], ldb, ilo, ihi, &
lscale[1], &rscale[1], &work[1], &ierr);
/* Compute ABNRM and BBNRM */
*abnrm = dlange_("1", n, n, &a[a_offset], lda, &work[1]);
if (ilascl) {
work[1] = *abnrm;
dlascl_("G", &c__0, &c__0, &anrmto, &anrm, &c__1, &c__1, &work[1], &
c__1, &ierr);
*abnrm = work[1];
}
*bbnrm = dlange_("1", n, n, &b[b_offset], ldb, &work[1]);
if (ilbscl) {
work[1] = *bbnrm;
dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, &c__1, &c__1, &work[1], &
c__1, &ierr);
*bbnrm = work[1];
}
/* Reduce B to triangular form (QR decomposition of B)
(Workspace: need N, prefer N*NB ) */
irows = *ihi + 1 - *ilo;
if (ilv || ! wantsn) {
icols = *n + 1 - *ilo;
} else {
icols = irows;
}
itau = 1;
iwrk = itau + irows;
i__1 = *lwork + 1 - iwrk;
dgeqrf_(&irows, &icols, &b_ref(*ilo, *ilo), ldb, &work[itau], &work[iwrk],
&i__1, &ierr);
/* Apply the orthogonal transformation to A
(Workspace: need N, prefer N*NB) */
i__1 = *lwork + 1 - iwrk;
dormqr_("L", "T", &irows, &icols, &irows, &b_ref(*ilo, *ilo), ldb, &work[
itau], &a_ref(*ilo, *ilo), lda, &work[iwrk], &i__1, &ierr);
/* Initialize VL and/or VR
(Workspace: need N, prefer N*NB) */
if (ilvl) {
dlaset_("Full", n, n, &c_b47, &c_b48, &vl[vl_offset], ldvl)
;
i__1 = irows - 1;
i__2 = irows - 1;
dlacpy_("L", &i__1, &i__2, &b_ref(*ilo + 1, *ilo), ldb, &vl_ref(*ilo
+ 1, *ilo), ldvl);
i__1 = *lwork + 1 - iwrk;
dorgqr_(&irows, &irows, &irows, &vl_ref(*ilo, *ilo), ldvl, &work[itau]
, &work[iwrk], &i__1, &ierr);
}
if (ilvr) {
dlaset_("Full", n, n, &c_b47, &c_b48, &vr[vr_offset], ldvr)
;
}
/* Reduce to generalized Hessenberg form
(Workspace: none needed) */
if (ilv || ! wantsn) {
/* Eigenvectors requested -- work on whole matrix. */
dgghrd_(jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset],
ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr);
} else {
dgghrd_("N", "N", &irows, &c__1, &irows, &a_ref(*ilo, *ilo), lda, &
b_ref(*ilo, *ilo), ldb, &vl[vl_offset], ldvl, &vr[vr_offset],
ldvr, &ierr);
}
/* Perform QZ algorithm (Compute eigenvalues, and optionally, the
Schur forms and Schur vectors)
(Workspace: need N) */
if (ilv || ! wantsn) {
*(unsigned char *)chtemp = 'S';
} else {
*(unsigned char *)chtemp = 'E';
}
dhgeqz_(chtemp, jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset]
, ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset], ldvl, &
vr[vr_offset], ldvr, &work[1], lwork, &ierr);
if (ierr != 0) {
if (ierr > 0 && ierr <= *n) {
*info = ierr;
} else if (ierr > *n && ierr <= *n << 1) {
*info = ierr - *n;
} else {
*info = *n + 1;
}
goto L130;
}
/* Compute Eigenvectors and estimate condition numbers if desired
(Workspace: DTGEVC: need 6*N
DTGSNA: need 2*N*(N+2)+16 if SENSE = 'V' or 'B',
need N otherwise ) */
if (ilv || ! wantsn) {
if (ilv) {
if (ilvl) {
if (ilvr) {
*(unsigned char *)chtemp = 'B';
} else {
*(unsigned char *)chtemp = 'L';
}
} else {
*(unsigned char *)chtemp = 'R';
}
dtgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset],
ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &
work[1], &ierr);
if (ierr != 0) {
*info = *n + 2;
goto L130;
}
}
if (! wantsn) {
/* compute eigenvectors (DTGEVC) and estimate condition
numbers (DTGSNA). Note that the definition of the condition
number is not invariant under transformation (u,v) to
(Q*u, Z*v), where (u,v) are eigenvectors of the generalized
Schur form (S,T), Q and Z are orthogonal matrices. In order
to avoid using extra 2*N*N workspace, we have to recalculate
eigenvectors and estimate one condition numbers at a time. */
pair = FALSE_;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (pair) {
pair = FALSE_;
goto L20;
}
mm = 1;
if (i__ < *n) {
if (a_ref(i__ + 1, i__) != 0.) {
pair = TRUE_;
mm = 2;
}
}
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
bwork[j] = FALSE_;
/* L10: */
}
if (mm == 1) {
bwork[i__] = TRUE_;
} else if (mm == 2) {
bwork[i__] = TRUE_;
bwork[i__ + 1] = TRUE_;
}
iwrk = mm * *n + 1;
iwrk1 = iwrk + mm * *n;
/* Compute a pair of left and right eigenvectors.
(compute workspace: need up to 4*N + 6*N) */
if (wantse || wantsb) {
dtgevc_("B", "S", &bwork[1], n, &a[a_offset], lda, &b[
b_offset], ldb, &work[1], n, &work[iwrk], n, &mm,
&m, &work[iwrk1], &ierr);
if (ierr != 0) {
*info = *n + 2;
goto L130;
}
}
i__2 = *lwork - iwrk1 + 1;
dtgsna_(sense, "S", &bwork[1], n, &a[a_offset], lda, &b[
b_offset], ldb, &work[1], n, &work[iwrk], n, &rconde[
i__], &rcondv[i__], &mm, &m, &work[iwrk1], &i__2, &
iwork[1], &ierr);
L20:
;
}
}
}
/* Undo balancing on VL and VR and normalization
(Workspace: none needed) */
if (ilvl) {
dggbak_(balanc, "L", n, ilo, ihi, &lscale[1], &rscale[1], n, &vl[
vl_offset], ldvl, &ierr);
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
if (alphai[jc] < 0.) {
goto L70;
}
temp = 0.;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = vl_ref(jr, jc), abs(d__1));
temp = max(d__2,d__3);
/* L30: */
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__3 = temp, d__4 = (d__1 = vl_ref(jr, jc), abs(d__1)) + (
d__2 = vl_ref(jr, jc + 1), abs(d__2));
temp = max(d__3,d__4);
/* L40: */
}
}
if (temp < smlnum) {
goto L70;
}
temp = 1. / temp;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vl_ref(jr, jc) = vl_ref(jr, jc) * temp;
/* L50: */
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vl_ref(jr, jc) = vl_ref(jr, jc) * temp;
vl_ref(jr, jc + 1) = vl_ref(jr, jc + 1) * temp;
/* L60: */
}
}
L70:
;
}
}
if (ilvr) {
dggbak_(balanc, "R", n, ilo, ihi, &lscale[1], &rscale[1], n, &vr[
vr_offset], ldvr, &ierr);
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
if (alphai[jc] < 0.) {
goto L120;
}
temp = 0.;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = vr_ref(jr, jc), abs(d__1));
temp = max(d__2,d__3);
/* L80: */
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
d__3 = temp, d__4 = (d__1 = vr_ref(jr, jc), abs(d__1)) + (
d__2 = vr_ref(jr, jc + 1), abs(d__2));
temp = max(d__3,d__4);
/* L90: */
}
}
if (temp < smlnum) {
goto L120;
}
temp = 1. / temp;
if (alphai[jc] == 0.) {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vr_ref(jr, jc) = vr_ref(jr, jc) * temp;
/* L100: */
}
} else {
i__2 = *n;
for (jr = 1; jr <= i__2; ++jr) {
vr_ref(jr, jc) = vr_ref(jr, jc) * temp;
vr_ref(jr, jc + 1) = vr_ref(jr, jc + 1) * temp;
/* L110: */
}
}
L120:
;
}
}
/* Undo scaling if necessary */
if (ilascl) {
dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, &
ierr);
dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, &
ierr);
}
if (ilbscl) {
dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
ierr);
}
L130:
work[1] = (doublereal) maxwrk;
return 0;
/* End of DGGEVX */
} /* dggevx_ */
/* Subroutine */ int dqlt01_(integer *m, integer *n, doublereal *a,
doublereal *af, doublereal *q, doublereal *l, integer *lda,
doublereal *tau, doublereal *work, integer *lwork, doublereal *rwork,
doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
q_offset, i__1, i__2;
/* Local variables */
doublereal eps;
integer info;
doublereal resid, anorm;
integer minmn;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DQLT01 tests DGEQLF, which computes the QL factorization of an m-by-n */
/* matrix A, and partially tests DORGQL which forms the m-by-m */
/* orthogonal matrix Q. */
/* DQLT01 compares L with Q'*A, and checks that Q is orthogonal. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The m-by-n matrix A. */
/* AF (output) DOUBLE PRECISION array, dimension (LDA,N) */
/* Details of the QL factorization of A, as returned by DGEQLF. */
/* See DGEQLF for further details. */
/* Q (output) DOUBLE PRECISION array, dimension (LDA,M) */
/* The m-by-m orthogonal matrix Q. */
/* L (workspace) DOUBLE PRECISION array, dimension (LDA,max(M,N)) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, Q and R. */
/* LDA >= max(M,N). */
/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors, as returned */
/* by DGEQLF. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
/* The test ratios: */
/* RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS ) */
/* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
l_dim1 = *lda;
l_offset = 1 + l_dim1;
l -= l_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
minmn = min(*m,*n);
eps = dlamch_("Epsilon");
/* Copy the matrix A to the array AF. */
dlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
/* Factorize the matrix A in the array AF. */
s_copy(srnamc_1.srnamt, "DGEQLF", (ftnlen)32, (ftnlen)6);
dgeqlf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy details of Q */
dlaset_("Full", m, m, &c_b6, &c_b6, &q[q_offset], lda);
if (*m >= *n) {
if (*n < *m && *n > 0) {
i__1 = *m - *n;
dlacpy_("Full", &i__1, n, &af[af_offset], lda, &q[(*m - *n + 1) *
q_dim1 + 1], lda);
}
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
dlacpy_("Upper", &i__1, &i__2, &af[*m - *n + 1 + (af_dim1 << 1)],
lda, &q[*m - *n + 1 + (*m - *n + 2) * q_dim1], lda);
}
} else {
if (*m > 1) {
i__1 = *m - 1;
i__2 = *m - 1;
dlacpy_("Upper", &i__1, &i__2, &af[(*n - *m + 2) * af_dim1 + 1],
lda, &q[(q_dim1 << 1) + 1], lda);
}
}
/* Generate the m-by-m matrix Q */
s_copy(srnamc_1.srnamt, "DORGQL", (ftnlen)32, (ftnlen)6);
dorgql_(m, m, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy L */
dlaset_("Full", m, n, &c_b13, &c_b13, &l[l_offset], lda);
if (*m >= *n) {
if (*n > 0) {
dlacpy_("Lower", n, n, &af[*m - *n + 1 + af_dim1], lda, &l[*m - *
n + 1 + l_dim1], lda);
}
} else {
if (*n > *m && *m > 0) {
i__1 = *n - *m;
dlacpy_("Full", m, &i__1, &af[af_offset], lda, &l[l_offset], lda);
}
if (*m > 0) {
dlacpy_("Lower", m, m, &af[(*n - *m + 1) * af_dim1 + 1], lda, &l[(
*n - *m + 1) * l_dim1 + 1], lda);
}
}
/* Compute L - Q'*A */
dgemm_("Transpose", "No transpose", m, n, m, &c_b20, &q[q_offset], lda, &
a[a_offset], lda, &c_b21, &l[l_offset], lda);
/* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */
anorm = dlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
resid = dlange_("1", m, n, &l[l_offset], lda, &rwork[1]);
if (anorm > 0.) {
result[1] = resid / (doublereal) max(1,*m) / anorm / eps;
} else {
result[1] = 0.;
}
/* Compute I - Q'*Q */
dlaset_("Full", m, m, &c_b13, &c_b21, &l[l_offset], lda);
dsyrk_("Upper", "Transpose", m, m, &c_b20, &q[q_offset], lda, &c_b21, &l[
l_offset], lda);
/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
resid = dlansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (doublereal) max(1,*m) / eps;
return 0;
/* End of DQLT01 */
} /* dqlt01_ */
/* Subroutine */ int dgels_(char *trans, integer *m, integer *n, integer *
nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb,
doublereal *work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
/* Local variables */
integer i__, j, nb, mn;
doublereal anrm, bnrm;
integer brow;
logical tpsd;
integer iascl, ibscl;
extern logical lsame_(char *, char *);
integer wsize;
doublereal rwork[1];
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *),
dlascl_(char *, integer *, integer *, doublereal *, doublereal *,
integer *, integer *, doublereal *, integer *, integer *),
dgeqrf_(integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *), dlaset_(char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
integer scllen;
doublereal bignum;
extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *),
dormqr_(char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *);
doublereal smlnum;
logical lquery;
extern /* Subroutine */ int dtrtrs_(char *, char *, char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *);
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGELS solves overdetermined or underdetermined real linear systems */
/* involving an M-by-N matrix A, or its transpose, using a QR or LQ */
/* factorization of A. It is assumed that A has full rank. */
/* The following options are provided: */
/* 1. If TRANS = 'N' and m >= n: find the least squares solution of */
/* an overdetermined system, i.e., solve the least squares problem */
/* minimize || B - A*X ||. */
/* 2. If TRANS = 'N' and m < n: find the minimum norm solution of */
/* an underdetermined system A * X = B. */
/* 3. If TRANS = 'T' and m >= n: find the minimum norm solution of */
/* an undetermined system A**T * X = B. */
/* 4. If TRANS = 'T' and m < n: find the least squares solution of */
/* an overdetermined system, i.e., solve the least squares problem */
/* minimize || B - A**T * X ||. */
/* 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. */
/* Arguments */
/* ========= */
/* TRANS (input) CHARACTER*1 */
/* = 'N': the linear system involves A; */
/* = 'T': the linear system involves A**T. */
/* 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) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, */
/* if M >= N, A is overwritten by details of its QR */
/* factorization as returned by DGEQRF; */
/* if M < N, A is overwritten by details of its LQ */
/* factorization as returned by DGELQF. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* On entry, the matrix B of right hand side vectors, stored */
/* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS */
/* if TRANS = 'T'. */
/* On exit, if INFO = 0, B is overwritten by the solution */
/* vectors, stored columnwise: */
/* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least */
/* squares solution vectors; the residual sum of squares for the */
/* solution in each column is given by the sum of squares of */
/* elements N+1 to M in that column; */
/* if TRANS = 'N' and m < n, rows 1 to N of B contain the */
/* minimum norm solution vectors; */
/* if TRANS = 'T' and m >= n, rows 1 to M of B contain the */
/* minimum norm solution vectors; */
/* if TRANS = 'T' and m < n, rows 1 to M of B contain the */
/* least squares solution vectors; the residual sum of squares */
/* for the solution in each column is given by the sum of */
/* squares of elements M+1 to N in that column. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= MAX(1,M,N). */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* LWORK >= max( 1, MN + max( MN, NRHS ) ). */
/* For optimal performance, */
/* LWORK >= max( 1, MN + max( MN, NRHS )*NB ). */
/* where MN = min(M,N) and NB is the optimum block size. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the i-th diagonal element of the */
/* triangular factor of A is zero, so that A does not have */
/* full rank; the least squares solution could not be */
/* computed. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
/* Function Body */
*info = 0;
mn = min(*m,*n);
lquery = *lwork == -1;
if (! (lsame_(trans, "N") || lsame_(trans, "T"))) {
*info = -1;
} else if (*m < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*lda < max(1,*m)) {
*info = -6;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = max(1,*m);
if (*ldb < max(i__1,*n)) {
*info = -8;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = mn + max(mn,*nrhs);
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -10;
}
}
}
/* Figure out optimal block size */
if (*info == 0 || *info == -10) {
tpsd = TRUE_;
if (lsame_(trans, "N")) {
tpsd = FALSE_;
}
if (*m >= *n) {
nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1);
if (tpsd) {
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "DORMQR", "LN", m, nrhs, n, &
c_n1);
nb = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "DORMQR", "LT", m, nrhs, n, &
c_n1);
nb = max(i__1,i__2);
}
} else {
nb = ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, &c_n1);
if (tpsd) {
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "DORMLQ", "LT", n, nrhs, m, &
c_n1);
nb = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "DORMLQ", "LN", n, nrhs, m, &
c_n1);
nb = max(i__1,i__2);
}
}
/* Computing MAX */
i__1 = 1, i__2 = mn + max(mn,*nrhs) * nb;
wsize = max(i__1,i__2);
work[1] = (doublereal) wsize;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGELS ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
/* Computing MIN */
i__1 = min(*m,*n);
if (min(i__1,*nrhs) == 0) {
i__1 = max(*m,*n);
dlaset_("Full", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb);
return 0;
}
/* Get machine parameters */
smlnum = dlamch_("S") / dlamch_("P");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
/* Scale A, B if max element outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", m, n, &a[a_offset], lda, rwork);
iascl = 0;
if (anrm > 0. && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
info);
iascl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM */
dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
info);
iascl = 2;
} else if (anrm == 0.) {
/* Matrix all zero. Return zero solution. */
i__1 = max(*m,*n);
dlaset_("F", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb);
goto L50;
}
brow = *m;
if (tpsd) {
brow = *n;
}
bnrm = dlange_("M", &brow, nrhs, &b[b_offset], ldb, rwork);
ibscl = 0;
if (bnrm > 0. && bnrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, &brow, nrhs, &b[b_offset],
ldb, info);
ibscl = 1;
} else if (bnrm > bignum) {
/* Scale matrix norm down to BIGNUM */
dlascl_("G", &c__0, &c__0, &bnrm, &bignum, &brow, nrhs, &b[b_offset],
ldb, info);
ibscl = 2;
}
if (*m >= *n) {
/* compute QR factorization of A */
i__1 = *lwork - mn;
dgeqrf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
;
/* workspace at least N, optimally N*NB */
if (! tpsd) {
/* Least-Squares Problem min || A * X - B || */
/* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */
i__1 = *lwork - mn;
dormqr_("Left", "Transpose", m, nrhs, n, &a[a_offset], lda, &work[
1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
/* workspace at least NRHS, optimally NRHS*NB */
/* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) */
dtrtrs_("Upper", "No transpose", "Non-unit", n, nrhs, &a[a_offset]
, lda, &b[b_offset], ldb, info);
if (*info > 0) {
return 0;
}
scllen = *n;
} else {
/* Overdetermined system of equations A' * X = B */
/* B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS) */
dtrtrs_("Upper", "Transpose", "Non-unit", n, nrhs, &a[a_offset],
lda, &b[b_offset], ldb, info);
if (*info > 0) {
return 0;
}
/* B(N+1:M,1:NRHS) = ZERO */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = *n + 1; i__ <= i__2; ++i__) {
b[i__ + j * b_dim1] = 0.;
/* L10: */
}
/* L20: */
}
/* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) */
i__1 = *lwork - mn;
dormqr_("Left", "No transpose", m, nrhs, n, &a[a_offset], lda, &
work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
/* workspace at least NRHS, optimally NRHS*NB */
scllen = *m;
}
} else {
/* Compute LQ factorization of A */
i__1 = *lwork - mn;
dgelqf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
;
/* workspace at least M, optimally M*NB. */
if (! tpsd) {
/* underdetermined system of equations A * X = B */
/* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) */
dtrtrs_("Lower", "No transpose", "Non-unit", m, nrhs, &a[a_offset]
, lda, &b[b_offset], ldb, info);
if (*info > 0) {
return 0;
}
/* B(M+1:N,1:NRHS) = 0 */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = *m + 1; i__ <= i__2; ++i__) {
b[i__ + j * b_dim1] = 0.;
/* L30: */
}
/* L40: */
}
/* B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS) */
i__1 = *lwork - mn;
dormlq_("Left", "Transpose", n, nrhs, m, &a[a_offset], lda, &work[
1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
/* workspace at least NRHS, optimally NRHS*NB */
scllen = *n;
} else {
/* overdetermined system min || A' * X - B || */
/* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) */
i__1 = *lwork - mn;
dormlq_("Left", "No transpose", n, nrhs, m, &a[a_offset], lda, &
work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
/* workspace at least NRHS, optimally NRHS*NB */
/* B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS) */
dtrtrs_("Lower", "Transpose", "Non-unit", m, nrhs, &a[a_offset],
lda, &b[b_offset], ldb, info);
if (*info > 0) {
return 0;
}
scllen = *m;
}
}
/* Undo scaling */
if (iascl == 1) {
dlascl_("G", &c__0, &c__0, &anrm, &smlnum, &scllen, nrhs, &b[b_offset]
, ldb, info);
} else if (iascl == 2) {
dlascl_("G", &c__0, &c__0, &anrm, &bignum, &scllen, nrhs, &b[b_offset]
, ldb, info);
}
if (ibscl == 1) {
dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, &scllen, nrhs, &b[b_offset]
, ldb, info);
} else if (ibscl == 2) {
dlascl_("G", &c__0, &c__0, &bignum, &bnrm, &scllen, nrhs, &b[b_offset]
, ldb, info);
}
L50:
work[1] = (doublereal) wsize;
return 0;
/* End of DGELS */
} /* dgels_ */
/* Subroutine */ int dlaror_(char *side, char *init, integer *m, integer *n,
doublereal *a, integer *lda, integer *iseed, doublereal *x, integer *
info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double d_sign(doublereal *, doublereal *);
/* Local variables */
static integer kbeg;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer jcol, irow;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static integer j;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
static integer ixfrm, itype, nxfrm;
static doublereal xnorm;
extern doublereal dlarnd_(integer *, integer *);
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *);
static doublereal factor, xnorms;
/* -- LAPACK auxiliary test 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
=======
DLAROR pre- or post-multiplies an M by N matrix A by a random
orthogonal matrix U, overwriting A. A may optionally be initialized
to the identity matrix before multiplying by U. U is generated using
the method of G.W. Stewart (SIAM J. Numer. Anal. 17, 1980, 403-409).
Arguments
=========
SIDE (input) CHARACTER*1
Specifies whether A is multiplied on the left or right by U.
= 'L': Multiply A on the left (premultiply) by U
= 'R': Multiply A on the right (postmultiply) by U'
= 'C' or 'T': Multiply A on the left by U and the right
by U' (Here, U' means U-transpose.)
INIT (input) CHARACTER*1
Specifies whether or not A should be initialized to the
identity matrix.
= 'I': Initialize A to (a section of) the identity matrix
before applying U.
= 'N': No initialization. Apply U to the input matrix A.
INIT = 'I' may be used to generate square or rectangular
orthogonal matrices:
For M = N and SIDE = 'L' or 'R', the rows will be orthogonal
to each other, as will the columns.
If M < N, SIDE = 'R' produces a dense matrix whose rows are
orthogonal and whose columns are not, while SIDE = 'L'
produces a matrix whose rows are orthogonal, and whose first
M columns are orthogonal, and whose remaining columns are
zero.
If M > N, SIDE = 'L' produces a dense matrix whose columns
are orthogonal and whose rows are not, while SIDE = 'R'
produces a matrix whose columns are orthogonal, and whose
first M rows are orthogonal, and whose remaining rows are
zero.
M (input) INTEGER
The number of rows of A.
N (input) INTEGER
The number of columns of A.
A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
On entry, the array A.
On exit, overwritten by U A ( if SIDE = 'L' ),
or by A U ( if SIDE = 'R' ),
or by U A U' ( if SIDE = 'C' or 'T').
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
ISEED (input/output) INTEGER array, dimension (4)
On entry ISEED specifies the seed of the random number
generator. The array elements should be between 0 and 4095;
if not they will be reduced mod 4096. Also, ISEED(4) must
be odd. The random number generator uses a linear
congruential sequence limited to small integers, and so
should produce machine independent random numbers. The
values of ISEED are changed on exit, and can be used in the
next call to DLAROR to continue the same random number
sequence.
X (workspace) DOUBLE PRECISION array, dimension (3*MAX( M, N ))
Workspace of length
2*M + N if SIDE = 'L',
2*N + M if SIDE = 'R',
3*N if SIDE = 'C' or 'T'.
INFO (output) INTEGER
An error flag. It is set to:
= 0: normal return
< 0: if INFO = -k, the k-th argument had an illegal value
= 1: if the random numbers generated by DLARND are bad.
=====================================================================
Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--iseed;
--x;
/* Function Body */
if (*n == 0 || *m == 0) {
return 0;
}
itype = 0;
if (lsame_(side, "L")) {
itype = 1;
} else if (lsame_(side, "R")) {
itype = 2;
} else if (lsame_(side, "C") || lsame_(side, "T")) {
itype = 3;
}
/* Check for argument errors. */
*info = 0;
if (itype == 0) {
*info = -1;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0 || itype == 3 && *n != *m) {
*info = -4;
} else if (*lda < *m) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLAROR", &i__1);
return 0;
}
if (itype == 1) {
nxfrm = *m;
} else {
nxfrm = *n;
}
/* Initialize A to the identity matrix if desired */
if (lsame_(init, "I")) {
dlaset_("Full", m, n, &c_b9, &c_b10, &a[a_offset], lda);
}
/* If no rotation possible, multiply by random +/-1
Compute rotation by computing Householder transformations
H(2), H(3), ..., H(nhouse) */
i__1 = nxfrm;
for (j = 1; j <= i__1; ++j) {
x[j] = 0.;
/* L10: */
}
i__1 = nxfrm;
for (ixfrm = 2; ixfrm <= i__1; ++ixfrm) {
kbeg = nxfrm - ixfrm + 1;
/* Generate independent normal( 0, 1 ) random numbers */
i__2 = nxfrm;
for (j = kbeg; j <= i__2; ++j) {
x[j] = dlarnd_(&c__3, &iseed[1]);
/* L20: */
}
/* Generate a Householder transformation from the random vector
X */
xnorm = dnrm2_(&ixfrm, &x[kbeg], &c__1);
xnorms = d_sign(&xnorm, &x[kbeg]);
d__1 = -x[kbeg];
x[kbeg + nxfrm] = d_sign(&c_b10, &d__1);
factor = xnorms * (xnorms + x[kbeg]);
if (abs(factor) < 1e-20) {
*info = 1;
xerbla_("DLAROR", info);
return 0;
} else {
factor = 1. / factor;
}
x[kbeg] += xnorms;
/* Apply Householder transformation to A */
if (itype == 1 || itype == 3) {
/* Apply H(k) from the left. */
dgemv_("T", &ixfrm, n, &c_b10, &a[kbeg + a_dim1], lda, &x[kbeg], &
c__1, &c_b9, &x[(nxfrm << 1) + 1], &c__1);
d__1 = -factor;
dger_(&ixfrm, n, &d__1, &x[kbeg], &c__1, &x[(nxfrm << 1) + 1], &
c__1, &a[kbeg + a_dim1], lda);
}
if (itype == 2 || itype == 3) {
/* Apply H(k) from the right. */
dgemv_("N", m, &ixfrm, &c_b10, &a[kbeg * a_dim1 + 1], lda, &x[
kbeg], &c__1, &c_b9, &x[(nxfrm << 1) + 1], &c__1);
d__1 = -factor;
dger_(m, &ixfrm, &d__1, &x[(nxfrm << 1) + 1], &c__1, &x[kbeg], &
c__1, &a[kbeg * a_dim1 + 1], lda);
}
/* L30: */
}
d__1 = dlarnd_(&c__3, &iseed[1]);
x[nxfrm * 2] = d_sign(&c_b10, &d__1);
/* Scale the matrix A by D. */
if (itype == 1 || itype == 3) {
i__1 = *m;
for (irow = 1; irow <= i__1; ++irow) {
dscal_(n, &x[nxfrm + irow], &a[irow + a_dim1], lda);
/* L40: */
}
}
if (itype == 2 || itype == 3) {
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
dscal_(m, &x[nxfrm + jcol], &a[jcol * a_dim1 + 1], &c__1);
/* L50: */
}
}
return 0;
/* End of DLAROR */
} /* dlaror_ */
/* Subroutine */ int dlarrv_(integer *n, doublereal *vl, doublereal *vu,
doublereal *d__, doublereal *l, doublereal *pivmin, integer *isplit,
integer *m, integer *dol, integer *dou, doublereal *minrgp,
doublereal *rtol1, doublereal *rtol2, doublereal *w, doublereal *werr,
doublereal *wgap, integer *iblock, integer *indexw, doublereal *gers,
doublereal *z__, integer *ldz, integer *isuppz, doublereal *work,
integer *iwork, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2;
logical L__1;
/* Builtin functions */
double log(doublereal);
/* Local variables */
integer minwsize, i__, j, k, p, q, miniwsize, ii;
doublereal gl;
integer im, in;
doublereal gu, gap, eps, tau, tol, tmp;
integer zto;
doublereal ztz;
integer iend, jblk;
doublereal lgap;
integer done;
doublereal rgap, left;
integer wend, iter;
doublereal bstw;
integer itmp1;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
integer indld;
doublereal fudge;
integer idone;
doublereal sigma;
integer iinfo, iindr;
doublereal resid;
logical eskip;
doublereal right;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
integer nclus, zfrom;
doublereal rqtol;
integer iindc1, iindc2;
extern /* Subroutine */ int dlar1v_(integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, logical *,
integer *, doublereal *, doublereal *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *);
logical stp2ii;
doublereal lambda;
extern doublereal dlamch_(char *);
integer ibegin, indeig;
logical needbs;
integer indlld;
doublereal sgndef, mingma;
extern /* Subroutine */ int dlarrb_(integer *, doublereal *, doublereal *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *);
integer oldien, oldncl, wbegin;
doublereal spdiam;
integer negcnt;
extern /* Subroutine */ int dlarrf_(integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *);
integer oldcls;
doublereal savgap;
integer ndepth;
doublereal ssigma;
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
logical usedbs;
integer iindwk, offset;
doublereal gaptol;
integer newcls, oldfst, indwrk, windex, oldlst;
logical usedrq;
integer newfst, newftt, parity, windmn, windpl, isupmn, newlst, zusedl;
doublereal bstres;
integer newsiz, zusedu, zusedw;
doublereal nrminv, rqcorr;
logical tryrqc;
integer isupmx;
/* -- LAPACK auxiliary routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLARRV computes the eigenvectors of the tridiagonal matrix */
/* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T. */
/* The input eigenvalues should have been computed by DLARRE. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* VL (input) DOUBLE PRECISION */
/* VU (input) DOUBLE PRECISION */
/* Lower and upper bounds of the interval that contains the desired */
/* eigenvalues. VL < VU. Needed to compute gaps on the left or right */
/* end of the extremal eigenvalues in the desired RANGE. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the N diagonal elements of the diagonal matrix D. */
/* On exit, D may be overwritten. */
/* L (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the (N-1) subdiagonal elements of the unit */
/* bidiagonal matrix L are in elements 1 to N-1 of L */
/* (if the matrix is not splitted.) At the end of each block */
/* is stored the corresponding shift as given by DLARRE. */
/* On exit, L is overwritten. */
/* PIVMIN (in) DOUBLE PRECISION */
/* The minimum pivot allowed in the Sturm sequence. */
/* ISPLIT (input) INTEGER array, dimension (N) */
/* The splitting points, at which T breaks up into blocks. */
/* The first block consists of rows/columns 1 to */
/* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 */
/* through ISPLIT( 2 ), etc. */
/* M (input) INTEGER */
/* The total number of input eigenvalues. 0 <= M <= N. */
/* DOL (input) INTEGER */
/* DOU (input) INTEGER */
/* If the user wants to compute only selected eigenvectors from all */
/* the eigenvalues supplied, he can specify an index range DOL:DOU. */
/* Or else the setting DOL=1, DOU=M should be applied. */
/* Note that DOL and DOU refer to the order in which the eigenvalues */
/* are stored in W. */
/* If the user wants to compute only selected eigenpairs, then */
/* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the */
/* computed eigenvectors. All other columns of Z are set to zero. */
/* MINRGP (input) DOUBLE PRECISION */
/* RTOL1 (input) DOUBLE PRECISION */
/* RTOL2 (input) DOUBLE PRECISION */
/* Parameters for bisection. */
/* An interval [LEFT,RIGHT] has converged if */
/* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */
/* W (input/output) DOUBLE PRECISION array, dimension (N) */
/* The first M elements of W contain the APPROXIMATE eigenvalues for */
/* which eigenvectors are to be computed. The eigenvalues */
/* should be grouped by split-off block and ordered from */
/* smallest to largest within the block ( The output array */
/* W from DLARRE is expected here ). Furthermore, they are with */
/* respect to the shift of the corresponding root representation */
/* for their block. On exit, W holds the eigenvalues of the */
/* UNshifted matrix. */
/* WERR (input/output) DOUBLE PRECISION array, dimension (N) */
/* The first M elements contain the semiwidth of the uncertainty */
/* interval of the corresponding eigenvalue in W */
/* WGAP (input/output) DOUBLE PRECISION array, dimension (N) */
/* The separation from the right neighbor eigenvalue in W. */
/* IBLOCK (input) INTEGER array, dimension (N) */
/* The indices of the blocks (submatrices) associated with the */
/* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue */
/* W(i) belongs to the first block from the top, =2 if W(i) */
/* belongs to the second block, etc. */
/* INDEXW (input) INTEGER array, dimension (N) */
/* The indices of the eigenvalues within each block (submatrix); */
/* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the */
/* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block. */
/* GERS (input) DOUBLE PRECISION array, dimension (2*N) */
/* The N Gerschgorin intervals (the i-th Gerschgorin interval */
/* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should */
/* be computed from the original UNshifted matrix. */
/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) */
/* If INFO = 0, the first M columns of Z contain the */
/* orthonormal eigenvectors of the matrix T */
/* corresponding to the input eigenvalues, with the i-th */
/* column of Z holding the eigenvector associated with W(i). */
/* Note: the user must ensure that at least max(1,M) columns are */
/* supplied in the array Z. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= max(1,N). */
/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */
/* The support of the eigenvectors in Z, i.e., the indices */
/* indicating the nonzero elements in Z. The I-th eigenvector */
/* is nonzero only in elements ISUPPZ( 2*I-1 ) through */
/* ISUPPZ( 2*I ). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (12*N) */
/* IWORK (workspace) INTEGER array, dimension (7*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* > 0: A problem occured in DLARRV. */
/* < 0: One of the called subroutines signaled an internal problem. */
/* Needs inspection of the corresponding parameter IINFO */
/* for further information. */
/* =-1: Problem in DLARRB when refining a child's eigenvalues. */
/* =-2: Problem in DLARRF when computing the RRR of a child. */
/* When a child is inside a tight cluster, it can be difficult */
/* to find an RRR. A partial remedy from the user's point of */
/* view is to make the parameter MINRGP smaller and recompile. */
/* However, as the orthogonality of the computed vectors is */
/* proportional to 1/MINRGP, the user should be aware that */
/* he might be trading in precision when he decreases MINRGP. */
/* =-3: Problem in DLARRB when refining a single eigenvalue */
/* after the Rayleigh correction was rejected. */
/* = 5: The Rayleigh Quotient Iteration failed to converge to */
/* full accuracy in MAXITR steps. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Beresford Parlett, University of California, Berkeley, USA */
/* Jim Demmel, University of California, Berkeley, USA */
/* Inderjit Dhillon, University of Texas, Austin, USA */
/* Osni Marques, LBNL/NERSC, USA */
/* Christof Voemel, University of California, Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* .. */
/* The first N entries of WORK are reserved for the eigenvalues */
/* Parameter adjustments */
--d__;
--l;
--isplit;
--w;
--werr;
--wgap;
--iblock;
--indexw;
--gers;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--isuppz;
--work;
--iwork;
/* Function Body */
indld = *n + 1;
indlld = (*n << 1) + 1;
indwrk = *n * 3 + 1;
minwsize = *n * 12;
i__1 = minwsize;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L5: */
}
/* IWORK(IINDR+1:IINDR+N) hold the twist indices R for the */
/* factorization used to compute the FP vector */
iindr = 0;
/* IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current */
/* layer and the one above. */
iindc1 = *n;
iindc2 = *n << 1;
iindwk = *n * 3 + 1;
miniwsize = *n * 7;
i__1 = miniwsize;
for (i__ = 1; i__ <= i__1; ++i__) {
iwork[i__] = 0;
/* L10: */
}
zusedl = 1;
if (*dol > 1) {
/* Set lower bound for use of Z */
zusedl = *dol - 1;
}
zusedu = *m;
if (*dou < *m) {
/* Set lower bound for use of Z */
zusedu = *dou + 1;
}
/* The width of the part of Z that is used */
zusedw = zusedu - zusedl + 1;
dlaset_("Full", n, &zusedw, &c_b5, &c_b5, &z__[zusedl * z_dim1 + 1], ldz);
eps = dlamch_("Precision");
rqtol = eps * 2.;
/* Set expert flags for standard code. */
tryrqc = TRUE_;
if (*dol == 1 && *dou == *m) {
} else {
/* Only selected eigenpairs are computed. Since the other evalues */
/* are not refined by RQ iteration, bisection has to compute to full */
/* accuracy. */
*rtol1 = eps * 4.;
*rtol2 = eps * 4.;
}
/* The entries WBEGIN:WEND in W, WERR, WGAP correspond to the */
/* desired eigenvalues. The support of the nonzero eigenvector */
/* entries is contained in the interval IBEGIN:IEND. */
/* Remark that if k eigenpairs are desired, then the eigenvectors */
/* are stored in k contiguous columns of Z. */
/* DONE is the number of eigenvectors already computed */
done = 0;
ibegin = 1;
wbegin = 1;
i__1 = iblock[*m];
for (jblk = 1; jblk <= i__1; ++jblk) {
iend = isplit[jblk];
sigma = l[iend];
/* Find the eigenvectors of the submatrix indexed IBEGIN */
/* through IEND. */
wend = wbegin - 1;
L15:
if (wend < *m) {
if (iblock[wend + 1] == jblk) {
++wend;
goto L15;
}
}
if (wend < wbegin) {
ibegin = iend + 1;
goto L170;
} else if (wend < *dol || wbegin > *dou) {
ibegin = iend + 1;
wbegin = wend + 1;
goto L170;
}
/* Find local spectral diameter of the block */
gl = gers[(ibegin << 1) - 1];
gu = gers[ibegin * 2];
i__2 = iend;
for (i__ = ibegin + 1; i__ <= i__2; ++i__) {
/* Computing MIN */
d__1 = gers[(i__ << 1) - 1];
gl = min(d__1,gl);
/* Computing MAX */
d__1 = gers[i__ * 2];
gu = max(d__1,gu);
/* L20: */
}
spdiam = gu - gl;
/* OLDIEN is the last index of the previous block */
oldien = ibegin - 1;
/* Calculate the size of the current block */
in = iend - ibegin + 1;
/* The number of eigenvalues in the current block */
im = wend - wbegin + 1;
/* This is for a 1x1 block */
if (ibegin == iend) {
++done;
z__[ibegin + wbegin * z_dim1] = 1.;
isuppz[(wbegin << 1) - 1] = ibegin;
isuppz[wbegin * 2] = ibegin;
w[wbegin] += sigma;
work[wbegin] = w[wbegin];
ibegin = iend + 1;
++wbegin;
goto L170;
}
/* The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND) */
/* Note that these can be approximations, in this case, the corresp. */
/* entries of WERR give the size of the uncertainty interval. */
/* The eigenvalue approximations will be refined when necessary as */
/* high relative accuracy is required for the computation of the */
/* corresponding eigenvectors. */
dcopy_(&im, &w[wbegin], &c__1, &work[wbegin], &c__1);
/* We store in W the eigenvalue approximations w.r.t. the original */
/* matrix T. */
i__2 = im;
for (i__ = 1; i__ <= i__2; ++i__) {
w[wbegin + i__ - 1] += sigma;
/* L30: */
}
/* NDEPTH is the current depth of the representation tree */
ndepth = 0;
/* PARITY is either 1 or 0 */
parity = 1;
/* NCLUS is the number of clusters for the next level of the */
/* representation tree, we start with NCLUS = 1 for the root */
nclus = 1;
iwork[iindc1 + 1] = 1;
iwork[iindc1 + 2] = im;
/* IDONE is the number of eigenvectors already computed in the current */
/* block */
idone = 0;
/* loop while( IDONE.LT.IM ) */
/* generate the representation tree for the current block and */
/* compute the eigenvectors */
L40:
if (idone < im) {
/* This is a crude protection against infinitely deep trees */
if (ndepth > *m) {
*info = -2;
return 0;
}
/* breadth first processing of the current level of the representation */
/* tree: OLDNCL = number of clusters on current level */
oldncl = nclus;
/* reset NCLUS to count the number of child clusters */
nclus = 0;
parity = 1 - parity;
if (parity == 0) {
oldcls = iindc1;
newcls = iindc2;
} else {
oldcls = iindc2;
newcls = iindc1;
}
/* Process the clusters on the current level */
i__2 = oldncl;
for (i__ = 1; i__ <= i__2; ++i__) {
j = oldcls + (i__ << 1);
/* OLDFST, OLDLST = first, last index of current cluster. */
/* cluster indices start with 1 and are relative */
/* to WBEGIN when accessing W, WGAP, WERR, Z */
oldfst = iwork[j - 1];
oldlst = iwork[j];
if (ndepth > 0) {
/* Retrieve relatively robust representation (RRR) of cluster */
/* that has been computed at the previous level */
/* The RRR is stored in Z and overwritten once the eigenvectors */
/* have been computed or when the cluster is refined */
if (*dol == 1 && *dou == *m) {
/* Get representation from location of the leftmost evalue */
/* of the cluster */
j = wbegin + oldfst - 1;
} else {
if (wbegin + oldfst - 1 < *dol) {
/* Get representation from the left end of Z array */
j = *dol - 1;
} else if (wbegin + oldfst - 1 > *dou) {
/* Get representation from the right end of Z array */
j = *dou;
} else {
j = wbegin + oldfst - 1;
}
}
dcopy_(&in, &z__[ibegin + j * z_dim1], &c__1, &d__[ibegin]
, &c__1);
i__3 = in - 1;
dcopy_(&i__3, &z__[ibegin + (j + 1) * z_dim1], &c__1, &l[
ibegin], &c__1);
sigma = z__[iend + (j + 1) * z_dim1];
/* Set the corresponding entries in Z to zero */
dlaset_("Full", &in, &c__2, &c_b5, &c_b5, &z__[ibegin + j
* z_dim1], ldz);
}
/* Compute DL and DLL of current RRR */
i__3 = iend - 1;
for (j = ibegin; j <= i__3; ++j) {
tmp = d__[j] * l[j];
work[indld - 1 + j] = tmp;
work[indlld - 1 + j] = tmp * l[j];
/* L50: */
}
if (ndepth > 0) {
/* P and Q are index of the first and last eigenvalue to compute */
/* within the current block */
p = indexw[wbegin - 1 + oldfst];
q = indexw[wbegin - 1 + oldlst];
/* Offset for the arrays WORK, WGAP and WERR, i.e., th P-OFFSET */
/* thru' Q-OFFSET elements of these arrays are to be used. */
/* OFFSET = P-OLDFST */
offset = indexw[wbegin] - 1;
/* perform limited bisection (if necessary) to get approximate */
/* eigenvalues to the precision needed. */
dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin - 1], &p,
&q, rtol1, rtol2, &offset, &work[wbegin], &wgap[
wbegin], &werr[wbegin], &work[indwrk], &iwork[
iindwk], pivmin, &spdiam, &in, &iinfo);
if (iinfo != 0) {
*info = -1;
return 0;
}
/* We also recompute the extremal gaps. W holds all eigenvalues */
/* of the unshifted matrix and must be used for computation */
/* of WGAP, the entries of WORK might stem from RRRs with */
/* different shifts. The gaps from WBEGIN-1+OLDFST to */
/* WBEGIN-1+OLDLST are correctly computed in DLARRB. */
/* However, we only allow the gaps to become greater since */
/* this is what should happen when we decrease WERR */
if (oldfst > 1) {
/* Computing MAX */
d__1 = wgap[wbegin + oldfst - 2], d__2 = w[wbegin +
oldfst - 1] - werr[wbegin + oldfst - 1] - w[
wbegin + oldfst - 2] - werr[wbegin + oldfst -
2];
wgap[wbegin + oldfst - 2] = max(d__1,d__2);
}
if (wbegin + oldlst - 1 < wend) {
/* Computing MAX */
d__1 = wgap[wbegin + oldlst - 1], d__2 = w[wbegin +
oldlst] - werr[wbegin + oldlst] - w[wbegin +
oldlst - 1] - werr[wbegin + oldlst - 1];
wgap[wbegin + oldlst - 1] = max(d__1,d__2);
}
/* Each time the eigenvalues in WORK get refined, we store */
/* the newly found approximation with all shifts applied in W */
i__3 = oldlst;
for (j = oldfst; j <= i__3; ++j) {
w[wbegin + j - 1] = work[wbegin + j - 1] + sigma;
/* L53: */
}
}
/* Process the current node. */
newfst = oldfst;
i__3 = oldlst;
for (j = oldfst; j <= i__3; ++j) {
if (j == oldlst) {
/* we are at the right end of the cluster, this is also the */
/* boundary of the child cluster */
newlst = j;
} else if (wgap[wbegin + j - 1] >= *minrgp * (d__1 = work[
wbegin + j - 1], abs(d__1))) {
/* the right relative gap is big enough, the child cluster */
/* (NEWFST,..,NEWLST) is well separated from the following */
newlst = j;
} else {
/* inside a child cluster, the relative gap is not */
/* big enough. */
goto L140;
}
/* Compute size of child cluster found */
newsiz = newlst - newfst + 1;
/* NEWFTT is the place in Z where the new RRR or the computed */
/* eigenvector is to be stored */
if (*dol == 1 && *dou == *m) {
/* Store representation at location of the leftmost evalue */
/* of the cluster */
newftt = wbegin + newfst - 1;
} else {
if (wbegin + newfst - 1 < *dol) {
/* Store representation at the left end of Z array */
newftt = *dol - 1;
} else if (wbegin + newfst - 1 > *dou) {
/* Store representation at the right end of Z array */
newftt = *dou;
} else {
newftt = wbegin + newfst - 1;
}
}
if (newsiz > 1) {
/* Current child is not a singleton but a cluster. */
/* Compute and store new representation of child. */
/* Compute left and right cluster gap. */
/* LGAP and RGAP are not computed from WORK because */
/* the eigenvalue approximations may stem from RRRs */
/* different shifts. However, W hold all eigenvalues */
/* of the unshifted matrix. Still, the entries in WGAP */
/* have to be computed from WORK since the entries */
/* in W might be of the same order so that gaps are not */
/* exhibited correctly for very close eigenvalues. */
if (newfst == 1) {
/* Computing MAX */
d__1 = 0., d__2 = w[wbegin] - werr[wbegin] - *vl;
lgap = max(d__1,d__2);
} else {
lgap = wgap[wbegin + newfst - 2];
}
rgap = wgap[wbegin + newlst - 1];
/* Compute left- and rightmost eigenvalue of child */
/* to high precision in order to shift as close */
/* as possible and obtain as large relative gaps */
/* as possible */
for (k = 1; k <= 2; ++k) {
if (k == 1) {
p = indexw[wbegin - 1 + newfst];
} else {
p = indexw[wbegin - 1 + newlst];
}
offset = indexw[wbegin] - 1;
dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin
- 1], &p, &p, &rqtol, &rqtol, &offset, &
work[wbegin], &wgap[wbegin], &werr[wbegin]
, &work[indwrk], &iwork[iindwk], pivmin, &
spdiam, &in, &iinfo);
/* L55: */
}
if (wbegin + newlst - 1 < *dol || wbegin + newfst - 1
> *dou) {
/* if the cluster contains no desired eigenvalues */
/* skip the computation of that branch of the rep. tree */
/* We could skip before the refinement of the extremal */
/* eigenvalues of the child, but then the representation */
/* tree could be different from the one when nothing is */
/* skipped. For this reason we skip at this place. */
idone = idone + newlst - newfst + 1;
goto L139;
}
/* Compute RRR of child cluster. */
/* Note that the new RRR is stored in Z */
/* DLARRF needs LWORK = 2*N */
dlarrf_(&in, &d__[ibegin], &l[ibegin], &work[indld +
ibegin - 1], &newfst, &newlst, &work[wbegin],
&wgap[wbegin], &werr[wbegin], &spdiam, &lgap,
&rgap, pivmin, &tau, &z__[ibegin + newftt *
z_dim1], &z__[ibegin + (newftt + 1) * z_dim1],
&work[indwrk], &iinfo);
if (iinfo == 0) {
/* a new RRR for the cluster was found by DLARRF */
/* update shift and store it */
ssigma = sigma + tau;
z__[iend + (newftt + 1) * z_dim1] = ssigma;
/* WORK() are the midpoints and WERR() the semi-width */
/* Note that the entries in W are unchanged. */
i__4 = newlst;
for (k = newfst; k <= i__4; ++k) {
fudge = eps * 3. * (d__1 = work[wbegin + k -
1], abs(d__1));
work[wbegin + k - 1] -= tau;
fudge += eps * 4. * (d__1 = work[wbegin + k -
1], abs(d__1));
/* Fudge errors */
werr[wbegin + k - 1] += fudge;
/* Gaps are not fudged. Provided that WERR is small */
/* when eigenvalues are close, a zero gap indicates */
/* that a new representation is needed for resolving */
/* the cluster. A fudge could lead to a wrong decision */
/* of judging eigenvalues 'separated' which in */
/* reality are not. This could have a negative impact */
/* on the orthogonality of the computed eigenvectors. */
/* L116: */
}
++nclus;
k = newcls + (nclus << 1);
iwork[k - 1] = newfst;
iwork[k] = newlst;
} else {
*info = -2;
return 0;
}
} else {
/* Compute eigenvector of singleton */
iter = 0;
tol = log((doublereal) in) * 4. * eps;
k = newfst;
windex = wbegin + k - 1;
/* Computing MAX */
i__4 = windex - 1;
windmn = max(i__4,1);
/* Computing MIN */
i__4 = windex + 1;
windpl = min(i__4,*m);
lambda = work[windex];
++done;
/* Check if eigenvector computation is to be skipped */
if (windex < *dol || windex > *dou) {
eskip = TRUE_;
goto L125;
} else {
eskip = FALSE_;
}
left = work[windex] - werr[windex];
right = work[windex] + werr[windex];
indeig = indexw[windex];
/* Note that since we compute the eigenpairs for a child, */
/* all eigenvalue approximations are w.r.t the same shift. */
/* In this case, the entries in WORK should be used for */
/* computing the gaps since they exhibit even very small */
/* differences in the eigenvalues, as opposed to the */
/* entries in W which might "look" the same. */
if (k == 1) {
/* In the case RANGE='I' and with not much initial */
/* accuracy in LAMBDA and VL, the formula */
/* LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA ) */
/* can lead to an overestimation of the left gap and */
/* thus to inadequately early RQI 'convergence'. */
/* Prevent this by forcing a small left gap. */
/* Computing MAX */
d__1 = abs(left), d__2 = abs(right);
lgap = eps * max(d__1,d__2);
} else {
lgap = wgap[windmn];
}
if (k == im) {
/* In the case RANGE='I' and with not much initial */
/* accuracy in LAMBDA and VU, the formula */
/* can lead to an overestimation of the right gap and */
/* thus to inadequately early RQI 'convergence'. */
/* Prevent this by forcing a small right gap. */
/* Computing MAX */
d__1 = abs(left), d__2 = abs(right);
rgap = eps * max(d__1,d__2);
} else {
rgap = wgap[windex];
}
gap = min(lgap,rgap);
if (k == 1 || k == im) {
/* The eigenvector support can become wrong */
/* because significant entries could be cut off due to a */
/* large GAPTOL parameter in LAR1V. Prevent this. */
gaptol = 0.;
} else {
gaptol = gap * eps;
}
isupmn = in;
isupmx = 1;
/* Update WGAP so that it holds the minimum gap */
/* to the left or the right. This is crucial in the */
/* case where bisection is used to ensure that the */
/* eigenvalue is refined up to the required precision. */
/* The correct value is restored afterwards. */
savgap = wgap[windex];
wgap[windex] = gap;
/* We want to use the Rayleigh Quotient Correction */
/* as often as possible since it converges quadratically */
/* when we are close enough to the desired eigenvalue. */
/* However, the Rayleigh Quotient can have the wrong sign */
/* and lead us away from the desired eigenvalue. In this */
/* case, the best we can do is to use bisection. */
usedbs = FALSE_;
usedrq = FALSE_;
/* Bisection is initially turned off unless it is forced */
needbs = ! tryrqc;
L120:
/* Check if bisection should be used to refine eigenvalue */
if (needbs) {
/* Take the bisection as new iterate */
usedbs = TRUE_;
itmp1 = iwork[iindr + windex];
offset = indexw[wbegin] - 1;
d__1 = eps * 2.;
dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin
- 1], &indeig, &indeig, &c_b5, &d__1, &
offset, &work[wbegin], &wgap[wbegin], &
werr[wbegin], &work[indwrk], &iwork[
iindwk], pivmin, &spdiam, &itmp1, &iinfo);
if (iinfo != 0) {
*info = -3;
return 0;
}
lambda = work[windex];
/* Reset twist index from inaccurate LAMBDA to */
/* force computation of true MINGMA */
iwork[iindr + windex] = 0;
}
/* Given LAMBDA, compute the eigenvector. */
L__1 = ! usedbs;
dlar1v_(&in, &c__1, &in, &lambda, &d__[ibegin], &l[
ibegin], &work[indld + ibegin - 1], &work[
indlld + ibegin - 1], pivmin, &gaptol, &z__[
ibegin + windex * z_dim1], &L__1, &negcnt, &
ztz, &mingma, &iwork[iindr + windex], &isuppz[
(windex << 1) - 1], &nrminv, &resid, &rqcorr,
&work[indwrk]);
if (iter == 0) {
bstres = resid;
bstw = lambda;
} else if (resid < bstres) {
bstres = resid;
bstw = lambda;
}
/* Computing MIN */
i__4 = isupmn, i__5 = isuppz[(windex << 1) - 1];
isupmn = min(i__4,i__5);
/* Computing MAX */
i__4 = isupmx, i__5 = isuppz[windex * 2];
isupmx = max(i__4,i__5);
++iter;
/* sin alpha <= |resid|/gap */
/* Note that both the residual and the gap are */
/* proportional to the matrix, so ||T|| doesn't play */
/* a role in the quotient */
/* Convergence test for Rayleigh-Quotient iteration */
/* (omitted when Bisection has been used) */
if (resid > tol * gap && abs(rqcorr) > rqtol * abs(
lambda) && ! usedbs) {
/* We need to check that the RQCORR update doesn't */
/* move the eigenvalue away from the desired one and */
/* towards a neighbor. -> protection with bisection */
if (indeig <= negcnt) {
/* The wanted eigenvalue lies to the left */
sgndef = -1.;
} else {
/* The wanted eigenvalue lies to the right */
sgndef = 1.;
}
/* We only use the RQCORR if it improves the */
/* the iterate reasonably. */
if (rqcorr * sgndef >= 0. && lambda + rqcorr <=
right && lambda + rqcorr >= left) {
usedrq = TRUE_;
/* Store new midpoint of bisection interval in WORK */
if (sgndef == 1.) {
/* The current LAMBDA is on the left of the true */
/* eigenvalue */
left = lambda;
/* We prefer to assume that the error estimate */
/* is correct. We could make the interval not */
/* as a bracket but to be modified if the RQCORR */
/* chooses to. In this case, the RIGHT side should */
/* be modified as follows: */
/* RIGHT = MAX(RIGHT, LAMBDA + RQCORR) */
} else {
/* The current LAMBDA is on the right of the true */
/* eigenvalue */
right = lambda;
/* See comment about assuming the error estimate is */
/* correct above. */
/* LEFT = MIN(LEFT, LAMBDA + RQCORR) */
}
work[windex] = (right + left) * .5;
/* Take RQCORR since it has the correct sign and */
/* improves the iterate reasonably */
lambda += rqcorr;
/* Update width of error interval */
werr[windex] = (right - left) * .5;
} else {
needbs = TRUE_;
}
if (right - left < rqtol * abs(lambda)) {
/* The eigenvalue is computed to bisection accuracy */
/* compute eigenvector and stop */
usedbs = TRUE_;
goto L120;
} else if (iter < 10) {
goto L120;
} else if (iter == 10) {
needbs = TRUE_;
goto L120;
} else {
*info = 5;
return 0;
}
} else {
stp2ii = FALSE_;
if (usedrq && usedbs && bstres <= resid) {
lambda = bstw;
stp2ii = TRUE_;
}
if (stp2ii) {
/* improve error angle by second step */
L__1 = ! usedbs;
dlar1v_(&in, &c__1, &in, &lambda, &d__[ibegin]
, &l[ibegin], &work[indld + ibegin -
1], &work[indlld + ibegin - 1],
pivmin, &gaptol, &z__[ibegin + windex
* z_dim1], &L__1, &negcnt, &ztz, &
mingma, &iwork[iindr + windex], &
isuppz[(windex << 1) - 1], &nrminv, &
resid, &rqcorr, &work[indwrk]);
}
work[windex] = lambda;
}
/* Compute FP-vector support w.r.t. whole matrix */
isuppz[(windex << 1) - 1] += oldien;
isuppz[windex * 2] += oldien;
zfrom = isuppz[(windex << 1) - 1];
zto = isuppz[windex * 2];
isupmn += oldien;
isupmx += oldien;
/* Ensure vector is ok if support in the RQI has changed */
if (isupmn < zfrom) {
i__4 = zfrom - 1;
for (ii = isupmn; ii <= i__4; ++ii) {
z__[ii + windex * z_dim1] = 0.;
/* L122: */
}
}
if (isupmx > zto) {
i__4 = isupmx;
for (ii = zto + 1; ii <= i__4; ++ii) {
z__[ii + windex * z_dim1] = 0.;
/* L123: */
}
}
i__4 = zto - zfrom + 1;
dscal_(&i__4, &nrminv, &z__[zfrom + windex * z_dim1],
&c__1);
L125:
/* Update W */
w[windex] = lambda + sigma;
/* Recompute the gaps on the left and right */
/* But only allow them to become larger and not */
/* smaller (which can only happen through "bad" */
/* cancellation and doesn't reflect the theory */
/* where the initial gaps are underestimated due */
/* to WERR being too crude.) */
if (! eskip) {
if (k > 1) {
/* Computing MAX */
d__1 = wgap[windmn], d__2 = w[windex] - werr[
windex] - w[windmn] - werr[windmn];
wgap[windmn] = max(d__1,d__2);
}
if (windex < wend) {
/* Computing MAX */
d__1 = savgap, d__2 = w[windpl] - werr[windpl]
- w[windex] - werr[windex];
wgap[windex] = max(d__1,d__2);
}
}
++idone;
}
/* here ends the code for the current child */
L139:
/* Proceed to any remaining child nodes */
newfst = j + 1;
L140:
;
}
/* L150: */
}
++ndepth;
goto L40;
}
ibegin = iend + 1;
wbegin = wend + 1;
L170:
;
}
return 0;
/* End of DLARRV */
} /* dlarrv_ */
/* Subroutine */ int dlaed3_(integer *k, integer *n, integer *n1, doublereal *
d__, doublereal *q, integer *ldq, doublereal *rho, doublereal *dlamda,
doublereal *q2, integer *indx, integer *ctot, doublereal *w,
doublereal *s, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
Courant Institute, NAG Ltd., and Rice University
June 30, 1999
Purpose
=======
DLAED3 finds the roots of the secular equation, as defined by the
values in D, W, and RHO, between 1 and K. It makes the
appropriate calls to DLAED4 and then updates the eigenvectors by
multiplying the matrix of eigenvectors of the pair of eigensystems
being combined by the matrix of eigenvectors of the K-by-K system
which is solved here.
This code makes very mild assumptions about floating point
arithmetic. It will work on machines with a guard digit in
add/subtract, or on those binary machines without guard digits
which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
It could conceivably fail on hexadecimal or decimal machines
without guard digits, but we know of none.
Arguments
=========
K (input) INTEGER
The number of terms in the rational function to be solved by
DLAED4. K >= 0.
N (input) INTEGER
The number of rows and columns in the Q matrix.
N >= K (deflation may result in N>K).
N1 (input) INTEGER
The location of the last eigenvalue in the leading submatrix.
min(1,N) <= N1 <= N/2.
D (output) DOUBLE PRECISION array, dimension (N)
D(I) contains the updated eigenvalues for
1 <= I <= K.
Q (output) DOUBLE PRECISION array, dimension (LDQ,N)
Initially the first K columns are used as workspace.
On output the columns 1 to K contain
the updated eigenvectors.
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= max(1,N).
RHO (input) DOUBLE PRECISION
The value of the parameter in the rank one update equation.
RHO >= 0 required.
DLAMDA (input/output) DOUBLE PRECISION array, dimension (K)
The first K elements of this array contain the old roots
of the deflated updating problem. These are the poles
of the secular equation. May be changed on output by
having lowest order bit set to zero on Cray X-MP, Cray Y-MP,
Cray-2, or Cray C-90, as described above.
Q2 (input) DOUBLE PRECISION array, dimension (LDQ2, N)
The first K columns of this matrix contain the non-deflated
eigenvectors for the split problem.
INDX (input) INTEGER array, dimension (N)
The permutation used to arrange the columns of the deflated
Q matrix into three groups (see DLAED2).
The rows of the eigenvectors found by DLAED4 must be likewise
permuted before the matrix multiply can take place.
CTOT (input) INTEGER array, dimension (4)
A count of the total number of the various types of columns
in Q, as described in INDX. The fourth column type is any
column which has been deflated.
W (input/output) DOUBLE PRECISION array, dimension (K)
The first K elements of this array contain the components
of the deflation-adjusted updating vector. Destroyed on
output.
S (workspace) DOUBLE PRECISION array, dimension (N1 + 1)*K
Will contain the eigenvectors of the repaired matrix which
will be multiplied by the previously accumulated eigenvectors
to update the system.
LDS (input) INTEGER
The leading dimension of S. LDS >= max(1,K).
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: if INFO = 1, an eigenvalue did not converge
Further Details
===============
Based on contributions by
Jeff Rutter, Computer Science Division, University of California
at Berkeley, USA
Modified by Francoise Tisseur, University of Tennessee.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b22 = 1.;
static doublereal c_b23 = 0.;
/* System generated locals */
integer q_dim1, q_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
static doublereal temp;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static integer i__, j;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *),
dcopy_(integer *, doublereal *, integer *, doublereal *, integer
*), dlaed4_(integer *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *);
static integer n2;
extern doublereal dlamc3_(doublereal *, doublereal *);
static integer n12, ii, n23;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *), xerbla_(char *, integer *);
static integer iq2;
#define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
--d__;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
--dlamda;
--q2;
--indx;
--ctot;
--w;
--s;
/* Function Body */
*info = 0;
if (*k < 0) {
*info = -1;
} else if (*n < *k) {
*info = -2;
} else if (*ldq < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLAED3", &i__1);
return 0;
}
/* Quick return if possible */
if (*k == 0) {
return 0;
}
/* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
be computed with high relative accuracy (barring over/underflow).
This is a problem on machines without a guard digit in
add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
which on any of these machines zeros out the bottommost
bit of DLAMDA(I) if it is 1; this makes the subsequent
subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
occurs. On binary machines with a guard digit (almost all
machines) it does not change DLAMDA(I) at all. On hexadecimal
and decimal machines with a guard digit, it slightly
changes the bottommost bits of DLAMDA(I). It does not account
for hexadecimal or decimal machines without guard digits
(we know of none). We use a subroutine call to compute
2*DLAMBDA(I) to prevent optimizing compilers from eliminating
this code. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
dlamda[i__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__];
/* L10: */
}
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
dlaed4_(k, &j, &dlamda[1], &w[1], &q_ref(1, j), rho, &d__[j], info);
/* If the zero finder fails, the computation is terminated. */
if (*info != 0) {
goto L120;
}
/* L20: */
}
if (*k == 1) {
goto L110;
}
if (*k == 2) {
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
w[1] = q_ref(1, j);
w[2] = q_ref(2, j);
ii = indx[1];
q_ref(1, j) = w[ii];
ii = indx[2];
q_ref(2, j) = w[ii];
/* L30: */
}
goto L110;
}
/* Compute updated W. */
dcopy_(k, &w[1], &c__1, &s[1], &c__1);
/* Initialize W(I) = Q(I,I) */
i__1 = *ldq + 1;
dcopy_(k, &q[q_offset], &i__1, &w[1], &c__1);
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
w[i__] *= q_ref(i__, j) / (dlamda[i__] - dlamda[j]);
/* L40: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
w[i__] *= q_ref(i__, j) / (dlamda[i__] - dlamda[j]);
/* L50: */
}
/* L60: */
}
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
d__1 = sqrt(-w[i__]);
w[i__] = d_sign(&d__1, &s[i__]);
/* L70: */
}
/* Compute eigenvectors of the modified rank-1 modification. */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *k;
for (i__ = 1; i__ <= i__2; ++i__) {
s[i__] = w[i__] / q_ref(i__, j);
/* L80: */
}
temp = dnrm2_(k, &s[1], &c__1);
i__2 = *k;
for (i__ = 1; i__ <= i__2; ++i__) {
ii = indx[i__];
q_ref(i__, j) = s[ii] / temp;
/* L90: */
}
/* L100: */
}
/* Compute the updated eigenvectors. */
L110:
n2 = *n - *n1;
n12 = ctot[1] + ctot[2];
n23 = ctot[2] + ctot[3];
dlacpy_("A", &n23, k, &q_ref(ctot[1] + 1, 1), ldq, &s[1], &n23)
;
iq2 = *n1 * n12 + 1;
if (n23 != 0) {
dgemm_("N", "N", &n2, k, &n23, &c_b22, &q2[iq2], &n2, &s[1], &n23, &
c_b23, &q_ref(*n1 + 1, 1), ldq);
} else {
dlaset_("A", &n2, k, &c_b23, &c_b23, &q_ref(*n1 + 1, 1), ldq);
}
dlacpy_("A", &n12, k, &q[q_offset], ldq, &s[1], &n12);
if (n12 != 0) {
dgemm_("N", "N", n1, k, &n12, &c_b22, &q2[1], n1, &s[1], &n12, &c_b23,
&q[q_offset], ldq);
} else {
dlaset_("A", n1, k, &c_b23, &c_b23, &q_ref(1, 1), ldq);
}
L120:
return 0;
/* End of DLAED3 */
} /* dlaed3_ */
/* Subroutine */ int dpteqr_(char *compz, integer *n, doublereal *d__,
doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static doublereal c__[1] /* was [1][1] */;
static integer i__;
extern logical lsame_(char *, char *);
static doublereal vt[1] /* was [1][1] */;
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *), dbdsqr_(char *, integer *,
integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *);
static integer icompz;
extern /* Subroutine */ int dpttrf_(integer *, doublereal *, doublereal *,
integer *);
static integer nru;
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1999
Purpose
=======
DPTEQR computes all eigenvalues and, optionally, eigenvectors of a
symmetric positive definite tridiagonal matrix by first factoring the
matrix using DPTTRF, and then calling DBDSQR to compute the singular
values of the bidiagonal factor.
This routine computes the eigenvalues of the positive definite
tridiagonal matrix to high relative accuracy. This means that if the
eigenvalues range over many orders of magnitude in size, then the
small eigenvalues and corresponding eigenvectors will be computed
more accurately than, for example, with the standard QR method.
The eigenvectors of a full or band symmetric positive definite matrix
can also be found if DSYTRD, DSPTRD, or DSBTRD has been used to
reduce this matrix to tridiagonal form. (The reduction to tridiagonal
form, however, may preclude the possibility of obtaining high
relative accuracy in the small eigenvalues of the original matrix, if
these eigenvalues range over many orders of magnitude.)
Arguments
=========
COMPZ (input) CHARACTER*1
= 'N': Compute eigenvalues only.
= 'V': Compute eigenvectors of original symmetric
matrix also. Array Z contains the orthogonal
matrix used to reduce the original matrix to
tridiagonal form.
= 'I': Compute eigenvectors of tridiagonal matrix also.
N (input) INTEGER
The order of the matrix. N >= 0.
D (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the n diagonal elements of the tridiagonal
matrix.
On normal exit, D contains the eigenvalues, in descending
order.
E (input/output) DOUBLE PRECISION array, dimension (N-1)
On entry, the (n-1) subdiagonal elements of the tridiagonal
matrix.
On exit, E has been destroyed.
Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
On entry, if COMPZ = 'V', the orthogonal matrix used in the
reduction to tridiagonal form.
On exit, if COMPZ = 'V', the orthonormal eigenvectors of the
original symmetric matrix;
if COMPZ = 'I', the orthonormal eigenvectors of the
tridiagonal matrix.
If INFO > 0 on exit, Z contains the eigenvectors associated
with only the stored eigenvalues.
If COMPZ = 'N', then Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
COMPZ = 'V' or 'I', LDZ >= max(1,N).
WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: if INFO = i, and i is:
<= N the Cholesky factorization of the matrix could
not be performed because the i-th principal minor
was not positive definite.
> N the SVD algorithm failed to converge;
if INFO = N+i, i off-diagonal elements of the
bidiagonal factor did not converge to zero.
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
--e;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
/* Function Body */
*info = 0;
if (lsame_(compz, "N")) {
icompz = 0;
} else if (lsame_(compz, "V")) {
icompz = 1;
} else if (lsame_(compz, "I")) {
icompz = 2;
} else {
icompz = -1;
}
if (icompz < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPTEQR", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz > 0) {
z___ref(1, 1) = 1.;
}
return 0;
}
if (icompz == 2) {
dlaset_("Full", n, n, &c_b7, &c_b8, &z__[z_offset], ldz);
}
/* Call DPTTRF to factor the matrix. */
dpttrf_(n, &d__[1], &e[1], info);
if (*info != 0) {
return 0;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = sqrt(d__[i__]);
/* L10: */
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
e[i__] *= d__[i__];
/* L20: */
}
/* Call DBDSQR to compute the singular values/vectors of the
bidiagonal factor. */
if (icompz > 0) {
nru = *n;
} else {
nru = 0;
}
dbdsqr_("Lower", n, &c__0, &nru, &c__0, &d__[1], &e[1], vt, &c__1, &z__[
z_offset], ldz, c__, &c__1, &work[1], info);
/* Square the singular values. */
if (*info == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] *= d__[i__];
/* L30: */
}
} else {
*info = *n + *info;
}
return 0;
/* End of DPTEQR */
} /* dpteqr_ */
