/* Subroutine */ int pdnapps_(integer *comm, integer *n, integer *kev,
integer *np, doublereal *shiftr, doublereal *shifti, doublereal *v,
integer *ldv, doublereal *h__, integer *ldh, doublereal *resid,
doublereal *q, integer *ldq, doublereal *workl, doublereal *workd)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer h_dim1, h_offset, v_dim1, v_offset, q_dim1, q_offset, i__1, i__2,
i__3, i__4;
doublereal d__1, d__2;
/* Local variables */
static doublereal c__, f, g;
static integer i__, j;
static doublereal r__, s, t, u[3];
static real t0, t1;
static doublereal h11, h12, h21, h22, h32;
static integer jj, ir, nr;
static doublereal tau, ulp, tst1;
static integer iend;
static doublereal unfl, ovfl;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dlarf_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
ftnlen);
static logical cconj;
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, ftnlen), dcopy_(integer *,
doublereal *, integer *, doublereal *, integer *), daxpy_(integer
*, doublereal *, doublereal *, integer *, doublereal *, integer *)
;
extern doublereal dlapy2_(doublereal *, doublereal *);
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), dlarfg_(
integer *, doublereal *, doublereal *, integer *, doublereal *);
static doublereal sigmai;
extern /* Subroutine */ int second_(real *);
static doublereal sigmar;
static integer istart, kplusp, msglvl;
static doublereal smlnum;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, ftnlen),
dlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), dlaset_(char *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, ftnlen), pivout_(integer *
, integer *, integer *, integer *, integer *, char *, ftnlen),
pdvout_(integer *, integer *, integer *, doublereal *, integer *,
char *, ftnlen), pdmout_(integer *, integer *, integer *, integer
*, doublereal *, integer *, integer *, char *, ftnlen);
extern doublereal dlanhs_(char *, integer *, doublereal *, integer *,
doublereal *, ftnlen), pdlamch_(integer *, char *, ftnlen);
/* %--------------------% */
/* | MPI Communicator | */
/* %--------------------% */
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %------------------------% */
/* | Local Scalars & Arrays | */
/* %------------------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %----------------------% */
/* | Intrinsics Functions | */
/* %----------------------% */
/* %----------------% */
/* | Data statments | */
/* %----------------% */
/* Parameter adjustments */
--workd;
--resid;
--workl;
--shifti;
--shiftr;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
/* Function Body */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
if (first) {
/* %-----------------------------------------------% */
/* | Set machine-dependent constants for the | */
/* | stopping criterion. If norm(H) <= sqrt(OVFL), | */
/* | overflow should not occur. | */
/* | REFERENCE: LAPACK subroutine dlahqr | */
/* %-----------------------------------------------% */
unfl = pdlamch_(comm, "safe minimum", (ftnlen)12);
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = pdlamch_(comm, "precision", (ftnlen)9);
smlnum = unfl * (*n / ulp);
first = FALSE_;
}
/* %-------------------------------% */
/* | Initialize timing statistics | */
/* | & message level for debugging | */
/* %-------------------------------% */
second_(&t0);
msglvl = debug_1.mnapps;
kplusp = *kev + *np;
/* %--------------------------------------------% */
/* | Initialize Q to the identity to accumulate | */
/* | the rotations and reflections | */
/* %--------------------------------------------% */
dlaset_("All", &kplusp, &kplusp, &c_b5, &c_b6, &q[q_offset], ldq, (ftnlen)
3);
/* %----------------------------------------------% */
/* | Quick return if there are no shifts to apply | */
/* %----------------------------------------------% */
if (*np == 0) {
goto L9000;
}
/* %----------------------------------------------% */
/* | Chase the bulge with the application of each | */
/* | implicit shift. Each shift is applied to the | */
/* | whole matrix including each block. | */
/* %----------------------------------------------% */
cconj = FALSE_;
i__1 = *np;
for (jj = 1; jj <= i__1; ++jj) {
sigmar = shiftr[jj];
sigmai = shifti[jj];
if (msglvl > 2) {
pivout_(comm, &debug_1.logfil, &c__1, &jj, &debug_1.ndigit, "_na"
"pps: shift number.", (ftnlen)21);
pdvout_(comm, &debug_1.logfil, &c__1, &sigmar, &debug_1.ndigit,
"_napps: The real part of the shift ", (ftnlen)35);
pdvout_(comm, &debug_1.logfil, &c__1, &sigmai, &debug_1.ndigit,
"_napps: The imaginary part of the shift ", (ftnlen)40);
}
/* %-------------------------------------------------% */
/* | The following set of conditionals is necessary | */
/* | in order that complex conjugate pairs of shifts | */
/* | are applied together or not at all. | */
/* %-------------------------------------------------% */
if (cconj) {
/* %-----------------------------------------% */
/* | cconj = .true. means the previous shift | */
/* | had non-zero imaginary part. | */
/* %-----------------------------------------% */
cconj = FALSE_;
goto L110;
} else if (jj < *np && abs(sigmai) > 0.) {
/* %------------------------------------% */
/* | Start of a complex conjugate pair. | */
/* %------------------------------------% */
cconj = TRUE_;
} else if (jj == *np && abs(sigmai) > 0.) {
/* %----------------------------------------------% */
/* | The last shift has a nonzero imaginary part. | */
/* | Don't apply it; thus the order of the | */
/* | compressed H is order KEV+1 since only np-1 | */
/* | were applied. | */
/* %----------------------------------------------% */
++(*kev);
goto L110;
}
istart = 1;
L20:
/* %--------------------------------------------------% */
/* | if sigmai = 0 then | */
/* | Apply the jj-th shift ... | */
/* | else | */
/* | Apply the jj-th and (jj+1)-th together ... | */
/* | (Note that jj < np at this point in the code) | */
/* | end | */
/* | to the current block of H. The next do loop | */
/* | determines the current block ; | */
/* %--------------------------------------------------% */
i__2 = kplusp - 1;
for (i__ = istart; i__ <= i__2; ++i__) {
/* %----------------------------------------% */
/* | Check for splitting and deflation. Use | */
/* | a standard test as in the QR algorithm | */
/* | REFERENCE: LAPACK subroutine dlahqr | */
/* %----------------------------------------% */
tst1 = (d__1 = h__[i__ + i__ * h_dim1], abs(d__1)) + (d__2 = h__[
i__ + 1 + (i__ + 1) * h_dim1], abs(d__2));
if (tst1 == 0.) {
i__3 = kplusp - jj + 1;
tst1 = dlanhs_("1", &i__3, &h__[h_offset], ldh, &workl[1], (
ftnlen)1);
}
/* Computing MAX */
d__2 = ulp * tst1;
if ((d__1 = h__[i__ + 1 + i__ * h_dim1], abs(d__1)) <= max(d__2,
smlnum)) {
if (msglvl > 0) {
pivout_(comm, &debug_1.logfil, &c__1, &i__, &
debug_1.ndigit, "_napps: matrix splitting at row"
"/column no.", (ftnlen)42);
pivout_(comm, &debug_1.logfil, &c__1, &jj, &
debug_1.ndigit, "_napps: matrix splitting with s"
"hift number.", (ftnlen)43);
pdvout_(comm, &debug_1.logfil, &c__1, &h__[i__ + 1 + i__ *
h_dim1], &debug_1.ndigit, "_napps: off diagonal"
" element.", (ftnlen)29);
}
iend = i__;
h__[i__ + 1 + i__ * h_dim1] = 0.;
goto L40;
}
/* L30: */
}
iend = kplusp;
L40:
if (msglvl > 2) {
pivout_(comm, &debug_1.logfil, &c__1, &istart, &debug_1.ndigit,
"_napps: Start of current block ", (ftnlen)31);
pivout_(comm, &debug_1.logfil, &c__1, &iend, &debug_1.ndigit,
"_napps: End of current block ", (ftnlen)29);
}
/* %------------------------------------------------% */
/* | No reason to apply a shift to block of order 1 | */
/* %------------------------------------------------% */
if (istart == iend) {
goto L100;
}
/* %------------------------------------------------------% */
/* | If istart + 1 = iend then no reason to apply a | */
/* | complex conjugate pair of shifts on a 2 by 2 matrix. | */
/* %------------------------------------------------------% */
if (istart + 1 == iend && abs(sigmai) > 0.) {
goto L100;
}
h11 = h__[istart + istart * h_dim1];
h21 = h__[istart + 1 + istart * h_dim1];
if (abs(sigmai) <= 0.) {
/* %---------------------------------------------% */
/* | Real-valued shift ==> apply single shift QR | */
/* %---------------------------------------------% */
f = h11 - sigmar;
g = h21;
i__2 = iend - 1;
for (i__ = istart; i__ <= i__2; ++i__) {
/* %-----------------------------------------------------% */
/* | Contruct the plane rotation G to zero out the bulge | */
/* %-----------------------------------------------------% */
dlartg_(&f, &g, &c__, &s, &r__);
if (i__ > istart) {
/* %-------------------------------------------% */
/* | The following ensures that h(1:iend-1,1), | */
/* | the first iend-2 off diagonal of elements | */
/* | H, remain non negative. | */
/* %-------------------------------------------% */
if (r__ < 0.) {
r__ = -r__;
c__ = -c__;
s = -s;
}
h__[i__ + (i__ - 1) * h_dim1] = r__;
h__[i__ + 1 + (i__ - 1) * h_dim1] = 0.;
}
/* %---------------------------------------------% */
/* | Apply rotation to the left of H; H <- G'*H | */
/* %---------------------------------------------% */
i__3 = kplusp;
for (j = i__; j <= i__3; ++j) {
t = c__ * h__[i__ + j * h_dim1] + s * h__[i__ + 1 + j *
h_dim1];
h__[i__ + 1 + j * h_dim1] = -s * h__[i__ + j * h_dim1] +
c__ * h__[i__ + 1 + j * h_dim1];
h__[i__ + j * h_dim1] = t;
/* L50: */
}
/* %---------------------------------------------% */
/* | Apply rotation to the right of H; H <- H*G | */
/* %---------------------------------------------% */
/* Computing MIN */
i__4 = i__ + 2;
i__3 = min(i__4,iend);
for (j = 1; j <= i__3; ++j) {
t = c__ * h__[j + i__ * h_dim1] + s * h__[j + (i__ + 1) *
h_dim1];
h__[j + (i__ + 1) * h_dim1] = -s * h__[j + i__ * h_dim1]
+ c__ * h__[j + (i__ + 1) * h_dim1];
h__[j + i__ * h_dim1] = t;
/* L60: */
}
/* %----------------------------------------------------% */
/* | Accumulate the rotation in the matrix Q; Q <- Q*G | */
/* %----------------------------------------------------% */
/* Computing MIN */
i__4 = i__ + jj;
i__3 = min(i__4,kplusp);
for (j = 1; j <= i__3; ++j) {
t = c__ * q[j + i__ * q_dim1] + s * q[j + (i__ + 1) *
q_dim1];
q[j + (i__ + 1) * q_dim1] = -s * q[j + i__ * q_dim1] +
c__ * q[j + (i__ + 1) * q_dim1];
q[j + i__ * q_dim1] = t;
/* L70: */
}
/* %---------------------------% */
/* | Prepare for next rotation | */
/* %---------------------------% */
if (i__ < iend - 1) {
f = h__[i__ + 1 + i__ * h_dim1];
g = h__[i__ + 2 + i__ * h_dim1];
}
/* L80: */
}
/* %-----------------------------------% */
/* | Finished applying the real shift. | */
/* %-----------------------------------% */
} else {
/* %----------------------------------------------------% */
/* | Complex conjugate shifts ==> apply double shift QR | */
/* %----------------------------------------------------% */
h12 = h__[istart + (istart + 1) * h_dim1];
h22 = h__[istart + 1 + (istart + 1) * h_dim1];
h32 = h__[istart + 2 + (istart + 1) * h_dim1];
/* %---------------------------------------------------------% */
/* | Compute 1st column of (H - shift*I)*(H - conj(shift)*I) | */
/* %---------------------------------------------------------% */
s = sigmar * 2.f;
t = dlapy2_(&sigmar, &sigmai);
u[0] = (h11 * (h11 - s) + t * t) / h21 + h12;
u[1] = h11 + h22 - s;
u[2] = h32;
i__2 = iend - 1;
for (i__ = istart; i__ <= i__2; ++i__) {
/* Computing MIN */
i__3 = 3, i__4 = iend - i__ + 1;
nr = min(i__3,i__4);
/* %-----------------------------------------------------% */
/* | Construct Householder reflector G to zero out u(1). | */
/* | G is of the form I - tau*( 1 u )' * ( 1 u' ). | */
/* %-----------------------------------------------------% */
dlarfg_(&nr, u, &u[1], &c__1, &tau);
if (i__ > istart) {
h__[i__ + (i__ - 1) * h_dim1] = u[0];
h__[i__ + 1 + (i__ - 1) * h_dim1] = 0.;
if (i__ < iend - 1) {
h__[i__ + 2 + (i__ - 1) * h_dim1] = 0.;
}
}
u[0] = 1.;
/* %--------------------------------------% */
/* | Apply the reflector to the left of H | */
/* %--------------------------------------% */
i__3 = kplusp - i__ + 1;
dlarf_("Left", &nr, &i__3, u, &c__1, &tau, &h__[i__ + i__ *
h_dim1], ldh, &workl[1], (ftnlen)4);
/* %---------------------------------------% */
/* | Apply the reflector to the right of H | */
/* %---------------------------------------% */
/* Computing MIN */
i__3 = i__ + 3;
ir = min(i__3,iend);
dlarf_("Right", &ir, &nr, u, &c__1, &tau, &h__[i__ * h_dim1 +
1], ldh, &workl[1], (ftnlen)5);
/* %-----------------------------------------------------% */
/* | Accumulate the reflector in the matrix Q; Q <- Q*G | */
/* %-----------------------------------------------------% */
dlarf_("Right", &kplusp, &nr, u, &c__1, &tau, &q[i__ * q_dim1
+ 1], ldq, &workl[1], (ftnlen)5);
/* %----------------------------% */
/* | Prepare for next reflector | */
/* %----------------------------% */
if (i__ < iend - 1) {
u[0] = h__[i__ + 1 + i__ * h_dim1];
u[1] = h__[i__ + 2 + i__ * h_dim1];
if (i__ < iend - 2) {
u[2] = h__[i__ + 3 + i__ * h_dim1];
}
}
/* L90: */
}
/* %--------------------------------------------% */
/* | Finished applying a complex pair of shifts | */
/* | to the current block | */
/* %--------------------------------------------% */
}
L100:
/* %---------------------------------------------------------% */
/* | Apply the same shift to the next block if there is any. | */
/* %---------------------------------------------------------% */
istart = iend + 1;
if (iend < kplusp) {
goto L20;
}
/* %---------------------------------------------% */
/* | Loop back to the top to get the next shift. | */
/* %---------------------------------------------% */
L110:
;
}
/* %--------------------------------------------------% */
/* | Perform a similarity transformation that makes | */
/* | sure that H will have non negative sub diagonals | */
/* %--------------------------------------------------% */
i__1 = *kev;
for (j = 1; j <= i__1; ++j) {
if (h__[j + 1 + j * h_dim1] < 0.) {
i__2 = kplusp - j + 1;
dscal_(&i__2, &c_b43, &h__[j + 1 + j * h_dim1], ldh);
/* Computing MIN */
i__3 = j + 2;
i__2 = min(i__3,kplusp);
dscal_(&i__2, &c_b43, &h__[(j + 1) * h_dim1 + 1], &c__1);
/* Computing MIN */
i__3 = j + *np + 1;
i__2 = min(i__3,kplusp);
dscal_(&i__2, &c_b43, &q[(j + 1) * q_dim1 + 1], &c__1);
}
/* L120: */
}
i__1 = *kev;
for (i__ = 1; i__ <= i__1; ++i__) {
/* %--------------------------------------------% */
/* | Final check for splitting and deflation. | */
/* | Use a standard test as in the QR algorithm | */
/* | REFERENCE: LAPACK subroutine dlahqr | */
/* %--------------------------------------------% */
tst1 = (d__1 = h__[i__ + i__ * h_dim1], abs(d__1)) + (d__2 = h__[i__
+ 1 + (i__ + 1) * h_dim1], abs(d__2));
if (tst1 == 0.) {
tst1 = dlanhs_("1", kev, &h__[h_offset], ldh, &workl[1], (ftnlen)
1);
}
/* Computing MAX */
d__1 = ulp * tst1;
if (h__[i__ + 1 + i__ * h_dim1] <= max(d__1,smlnum)) {
h__[i__ + 1 + i__ * h_dim1] = 0.;
}
/* L130: */
}
/* %-------------------------------------------------% */
/* | Compute the (kev+1)-st column of (V*Q) and | */
/* | temporarily store the result in WORKD(N+1:2*N). | */
/* | This is needed in the residual update since we | */
/* | cannot GUARANTEE that the corresponding entry | */
/* | of H would be zero as in exact arithmetic. | */
/* %-------------------------------------------------% */
if (h__[*kev + 1 + *kev * h_dim1] > 0.) {
dgemv_("N", n, &kplusp, &c_b6, &v[v_offset], ldv, &q[(*kev + 1) *
q_dim1 + 1], &c__1, &c_b5, &workd[*n + 1], &c__1, (ftnlen)1);
}
/* %----------------------------------------------------------% */
/* | Compute column 1 to kev of (V*Q) in backward order | */
/* | taking advantage of the upper Hessenberg structure of Q. | */
/* %----------------------------------------------------------% */
i__1 = *kev;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = kplusp - i__ + 1;
dgemv_("N", n, &i__2, &c_b6, &v[v_offset], ldv, &q[(*kev - i__ + 1) *
q_dim1 + 1], &c__1, &c_b5, &workd[1], &c__1, (ftnlen)1);
dcopy_(n, &workd[1], &c__1, &v[(kplusp - i__ + 1) * v_dim1 + 1], &
c__1);
/* L140: */
}
/* %-------------------------------------------------% */
/* | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | */
/* %-------------------------------------------------% */
dlacpy_("A", n, kev, &v[(kplusp - *kev + 1) * v_dim1 + 1], ldv, &v[
v_offset], ldv, (ftnlen)1);
/* %--------------------------------------------------------------% */
/* | Copy the (kev+1)-st column of (V*Q) in the appropriate place | */
/* %--------------------------------------------------------------% */
if (h__[*kev + 1 + *kev * h_dim1] > 0.) {
dcopy_(n, &workd[*n + 1], &c__1, &v[(*kev + 1) * v_dim1 + 1], &c__1);
}
/* %---------------------------------------% */
/* | Update the residual vector: | */
/* | r <- sigmak*r + betak*v(:,kev+1) | */
/* | where | */
/* | sigmak = (e_{kplusp}'*Q)*e_{kev} | */
/* | betak = e_{kev+1}'*H*e_{kev} | */
/* %---------------------------------------% */
dscal_(n, &q[kplusp + *kev * q_dim1], &resid[1], &c__1);
if (h__[*kev + 1 + *kev * h_dim1] > 0.) {
daxpy_(n, &h__[*kev + 1 + *kev * h_dim1], &v[(*kev + 1) * v_dim1 + 1],
&c__1, &resid[1], &c__1);
}
if (msglvl > 1) {
pdvout_(comm, &debug_1.logfil, &c__1, &q[kplusp + *kev * q_dim1], &
debug_1.ndigit, "_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}", (
ftnlen)40);
pdvout_(comm, &debug_1.logfil, &c__1, &h__[*kev + 1 + *kev * h_dim1],
&debug_1.ndigit, "_napps: betak = e_{kev+1}^T*H*e_{kev}", (
ftnlen)37);
pivout_(comm, &debug_1.logfil, &c__1, kev, &debug_1.ndigit, "_napps:"
" Order of the final Hessenberg matrix ", (ftnlen)45);
if (msglvl > 2) {
pdmout_(comm, &debug_1.logfil, kev, kev, &h__[h_offset], ldh, &
debug_1.ndigit, "_napps: updated Hessenberg matrix H for"
" next iteration", (ftnlen)54);
}
}
L9000:
second_(&t1);
timing_1.tnapps += t1 - t0;
return 0;
/* %----------------% */
/* | End of pdnapps | */
/* %----------------% */
} /* pdnapps_ */
/* Subroutine */extern "C" int dlaqp2_(integer *m, integer *n, integer *offset,
doublereal *a, integer *lda, integer *jpvt, doublereal *tau,
doublereal *vn1, doublereal *vn2, doublereal *work)
{
/* -- LAPACK auxiliary 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
=======
DLAQP2 computes a QR factorization with column pivoting of
the block A(OFFSET+1:M,1:N).
The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.
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.
OFFSET (input) INTEGER
The number of rows of the matrix A that must be pivoted
but no factorized. OFFSET >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, the upper triangle of block A(OFFSET+1:M,1:N) is
the triangular factor obtained; the elements in block
A(OFFSET+1:M,1:N) below the diagonal, together with the
array TAU, represent the orthogonal matrix Q as a product of
elementary reflectors. Block A(1:OFFSET,1:N) has been
accordingly pivoted, but no factorized.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
JPVT (input/output) INTEGER array, dimension (N)
On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
to the front of A*P (a leading column); if JPVT(i) = 0,
the i-th column of A is a free column.
On exit, if JPVT(i) = k, then the i-th column of A*P
was the k-th column of A.
TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
The scalar factors of the elementary reflectors.
VN1 (input/output) DOUBLE PRECISION array, dimension (N)
The vector with the partial column norms.
VN2 (input/output) DOUBLE PRECISION array, dimension (N)
The vector with the exact column norms.
WORK (workspace) DOUBLE PRECISION array, dimension (N)
Further Details
===============
Based on contributions by
G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
X. Sun, Computer Science Dept., Duke University, USA
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static doublereal temp;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static doublereal temp2;
static integer i__, j;
extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *);
static integer offpi, itemp;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer mn;
extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *);
extern integer idamax_(integer *, doublereal *, integer *);
static doublereal aii;
static integer pvt;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--jpvt;
--tau;
--vn1;
--vn2;
--work;
/* Function Body
Computing MIN */
i__1 = *m - *offset;
mn = min(i__1,*n);
/* Compute factorization. */
i__1 = mn;
for (i__ = 1; i__ <= i__1; ++i__) {
offpi = *offset + i__;
/* Determine ith pivot column and swap if necessary. */
i__2 = *n - i__ + 1;
int ttt =idamax_(&i__2, &vn1[i__], &c__1);//zfm 可删 2003-1-8
pvt = i__ - 1 + idamax_(&i__2, &vn1[i__], &c__1);
//pvt的值决定了交换顺序 //zfm 2003-2-8
if (pvt != i__) {
dswap_(m, &a_ref(1, pvt), &c__1, &a_ref(1, i__), &c__1);
itemp = jpvt[pvt];
jpvt[pvt] = jpvt[i__];
jpvt[i__] = itemp;
vn1[pvt] = vn1[i__];
vn2[pvt] = vn2[i__];
}
/* Generate elementary reflector H(i). */
if (offpi < *m) {
i__2 = *m - offpi + 1;
dlarfg_(&i__2, &a_ref(offpi, i__), &a_ref(offpi + 1, i__), &c__1,
&tau[i__]);
} else {
dlarfg_(&c__1, &a_ref(*m, i__), &a_ref(*m, i__), &c__1, &tau[i__])
;
}
if (i__ < *n) {
/* Apply H(i)' to A(offset+i:m,i+1:n) from the left. */
aii = a_ref(offpi, i__);
a_ref(offpi, i__) = 1.;
i__2 = *m - offpi + 1;
i__3 = *n - i__;
dlarf_("Left", &i__2, &i__3, &a_ref(offpi, i__), &c__1, &tau[i__],
&a_ref(offpi, i__ + 1), lda, &work[1]);
a_ref(offpi, i__) = aii;
}
/* Update partial column norms. */
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
if (vn1[j] != 0.) {
/* Computing 2nd power */
d__2 = (d__1 = a_ref(offpi, j), abs(d__1)) / vn1[j];
temp = 1. - d__2 * d__2;
temp = max(temp,0.);
/* Computing 2nd power */
d__1 = vn1[j] / vn2[j];
temp2 = temp * .05 * (d__1 * d__1) + 1.;
if (temp2 == 1.) {
if (offpi < *m) {
i__3 = *m - offpi;
vn1[j] = dnrm2_(&i__3, &a_ref(offpi + 1, j), &c__1);
vn2[j] = vn1[j];
} else {
vn1[j] = 0.;
vn2[j] = 0.;
}
} else {
vn1[j] *= sqrt(temp);
}
}
/* L10: */
}
/* L20: */
}
return 0;
/* End of DLAQP2 */
} /* dlaqp2_ */
int dlahr2_(int *n, int *k, int *nb, double *
a, int *lda, double *tau, double *t, int *ldt,
double *y, int *ldy)
{
/* System generated locals */
int a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
i__3;
double d__1;
/* Local variables */
int i__;
double ei;
extern int dscal_(int *, double *, double *,
int *), dgemm_(char *, char *, int *, int *, int *
, double *, double *, int *, double *, int *,
double *, double *, int *), dgemv_(
char *, int *, int *, double *, double *, int
*, double *, int *, double *, double *, int *), dcopy_(int *, double *, int *, double *,
int *), dtrmm_(char *, char *, char *, char *, int *,
int *, double *, double *, int *, double *,
int *), daxpy_(int *,
double *, double *, int *, double *, int *),
dtrmv_(char *, char *, char *, int *, double *, int *,
double *, int *), dlarfg_(
int *, double *, double *, int *, double *),
dlacpy_(char *, int *, int *, double *, int *,
double *, int *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAHR2 reduces the first NB columns of A float general n-BY-(n-k+1) */
/* matrix A so that elements below the k-th subdiagonal are zero. The */
/* reduction is performed by an orthogonal similarity transformation */
/* Q' * A * Q. The routine returns the matrices V and T which determine */
/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */
/* This is an auxiliary routine called by DGEHRD. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* K (input) INTEGER */
/* The offset for the reduction. Elements below the k-th */
/* subdiagonal in the first NB columns are reduced to zero. */
/* K < N. */
/* NB (input) INTEGER */
/* The number of columns to be reduced. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1) */
/* On entry, the n-by-(n-k+1) general matrix A. */
/* On exit, the elements on and above the k-th subdiagonal in */
/* the first NB columns are overwritten with the corresponding */
/* elements of the reduced matrix; the elements below the k-th */
/* subdiagonal, with the array TAU, represent the matrix Q as a */
/* product of elementary reflectors. The other columns of A are */
/* unchanged. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* TAU (output) DOUBLE PRECISION array, dimension (NB) */
/* The scalar factors of the elementary reflectors. See Further */
/* Details. */
/* T (output) DOUBLE PRECISION array, dimension (LDT,NB) */
/* The upper triangular matrix T. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= NB. */
/* Y (output) DOUBLE PRECISION array, dimension (LDY,NB) */
/* The n-by-nb matrix Y. */
/* LDY (input) INTEGER */
/* The leading dimension of the array Y. LDY >= N. */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of nb elementary reflectors */
/* Q = H(1) H(2) . . . H(nb). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a float scalar, and v is a float vector with */
/* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
/* A(i+k+1:n,i), and tau in TAU(i). */
/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */
/* V which is needed, with T and Y, to apply the transformation to the */
/* unreduced part of the matrix, using an update of the form: */
/* A := (I - V*T*V') * (A - Y*V'). */
/* The contents of A on exit are illustrated by the following example */
/* with n = 7, k = 3 and nb = 2: */
/* ( a a a a a ) */
/* ( a a a a a ) */
/* ( a a a a a ) */
/* ( h h a a a ) */
/* ( v1 h a a a ) */
/* ( v1 v2 a a a ) */
/* ( v1 v2 a a a ) */
/* where a denotes an element of the original matrix A, h denotes a */
/* modified element of the upper Hessenberg matrix H, and vi denotes an */
/* element of the vector defining H(i). */
/* This file is a slight modification of LAPACK-3.0's DLAHRD */
/* incorporating improvements proposed by Quintana-Orti and Van de */
/* Gejin. Note that the entries of A(1:K,2:NB) differ from those */
/* returned by the original LAPACK routine. This function is */
/* not backward compatible with LAPACK3.0. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
--tau;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
/* Function Body */
if (*n <= 1) {
return 0;
}
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ > 1) {
/* Update A(K+1:N,I) */
/* Update I-th column of A - Y * V' */
i__2 = *n - *k;
i__3 = i__ - 1;
dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1],
ldy, &a[*k + i__ - 1 + a_dim1], lda, &c_b5, &a[*k + 1 +
i__ * a_dim1], &c__1);
/* Apply I - V * T' * V' to this column (call it b) from the */
/* left, using the last column of T as workspace */
/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */
/* ( V2 ) ( b2 ) */
/* where V1 is unit lower triangular */
/* w := V1' * b1 */
i__2 = i__ - 1;
dcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 +
1], &c__1);
i__2 = i__ - 1;
dtrmv_("Lower", "Transpose", "UNIT", &i__2, &a[*k + 1 + a_dim1],
lda, &t[*nb * t_dim1 + 1], &c__1);
/* w := w + V2'*b2 */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1],
lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b5, &t[*nb *
t_dim1 + 1], &c__1);
/* w := T'*w */
i__2 = i__ - 1;
dtrmv_("Upper", "Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt,
&t[*nb * t_dim1 + 1], &c__1);
/* b2 := b2 - V2*w */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &a[*k + i__ + a_dim1],
lda, &t[*nb * t_dim1 + 1], &c__1, &c_b5, &a[*k + i__ +
i__ * a_dim1], &c__1);
/* b1 := b1 - V1*w */
i__2 = i__ - 1;
dtrmv_("Lower", "NO TRANSPOSE", "UNIT", &i__2, &a[*k + 1 + a_dim1]
, lda, &t[*nb * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
daxpy_(&i__2, &c_b4, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__
* a_dim1], &c__1);
a[*k + i__ - 1 + (i__ - 1) * a_dim1] = ei;
}
/* Generate the elementary reflector H(I) to annihilate */
/* A(K+I+1:N,I) */
i__2 = *n - *k - i__ + 1;
/* Computing MIN */
i__3 = *k + i__ + 1;
dlarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[MIN(i__3, *n)+ i__ *
a_dim1], &c__1, &tau[i__]);
ei = a[*k + i__ + i__ * a_dim1];
a[*k + i__ + i__ * a_dim1] = 1.;
/* Compute Y(K+1:N,I) */
i__2 = *n - *k;
i__3 = *n - *k - i__ + 1;
dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b5, &a[*k + 1 + (i__ + 1) *
a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &y[*
k + 1 + i__ * y_dim1], &c__1);
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], lda, &
a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &t[i__ * t_dim1 +
1], &c__1);
i__2 = *n - *k;
i__3 = i__ - 1;
dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1], ldy,
&t[i__ * t_dim1 + 1], &c__1, &c_b5, &y[*k + 1 + i__ * y_dim1],
&c__1);
i__2 = *n - *k;
dscal_(&i__2, &tau[i__], &y[*k + 1 + i__ * y_dim1], &c__1);
/* Compute T(1:I,I) */
i__2 = i__ - 1;
d__1 = -tau[i__];
dscal_(&i__2, &d__1, &t[i__ * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
dtrmv_("Upper", "No Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt,
&t[i__ * t_dim1 + 1], &c__1)
;
t[i__ + i__ * t_dim1] = tau[i__];
/* L10: */
}
a[*k + *nb + *nb * a_dim1] = ei;
/* Compute Y(1:K,1:NB) */
dlacpy_("ALL", k, nb, &a[(a_dim1 << 1) + 1], lda, &y[y_offset], ldy);
dtrmm_("RIGHT", "Lower", "NO TRANSPOSE", "UNIT", k, nb, &c_b5, &a[*k + 1
+ a_dim1], lda, &y[y_offset], ldy);
if (*n > *k + *nb) {
i__1 = *n - *k - *nb;
dgemm_("NO TRANSPOSE", "NO TRANSPOSE", k, nb, &i__1, &c_b5, &a[(*nb +
2) * a_dim1 + 1], lda, &a[*k + 1 + *nb + a_dim1], lda, &c_b5,
&y[y_offset], ldy);
}
dtrmm_("RIGHT", "Upper", "NO TRANSPOSE", "NON-UNIT", k, nb, &c_b5, &t[
t_offset], ldt, &y[y_offset], ldy);
return 0;
/* End of DLAHR2 */
} /* dlahr2_ */
/* Subroutine */
int dgehd2_(integer *n, integer *ilo, integer *ihi, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__;
doublereal aii;
extern /* Subroutine */
int dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *), dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *), xerbla_(char *, integer *);
/* -- LAPACK computational routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*n < 0)
{
*info = -1;
}
else if (*ilo < 1 || *ilo > max(1,*n))
{
*info = -2;
}
else if (*ihi < min(*ilo,*n) || *ihi > *n)
{
*info = -3;
}
else if (*lda < max(1,*n))
{
*info = -5;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DGEHD2", &i__1);
return 0;
}
i__1 = *ihi - 1;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
/* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) */
i__2 = *ihi - i__;
/* Computing MIN */
i__3 = i__ + 2;
dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3,*n) + i__ * a_dim1], &c__1, &tau[i__]);
aii = a[i__ + 1 + i__ * a_dim1];
a[i__ + 1 + i__ * a_dim1] = 1.;
/* Apply H(i) to A(1:ihi,i+1:ihi) from the right */
i__2 = *ihi - i__;
dlarf_("Right", ihi, &i__2, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ i__], &a[(i__ + 1) * a_dim1 + 1], lda, &work[1]);
/* Apply H(i) to A(i+1:ihi,i+1:n) from the left */
i__2 = *ihi - i__;
i__3 = *n - i__;
dlarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ i__], &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1]);
a[i__ + 1 + i__ * a_dim1] = aii;
/* L10: */
}
return 0;
/* End of DGEHD2 */
}
int dgebd2_(int *m, int *n, double *a, int *
lda, double *d__, double *e, double *tauq, double *
taup, double *work, int *info)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
int i__;
extern int dlarf_(char *, int *, int *,
double *, int *, double *, double *, int *,
double *), dlarfg_(int *, double *,
double *, int *, double *), xerbla_(char *, int *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGEBD2 reduces a float general m by n matrix A to upper or lower */
/* bidiagonal form B by an orthogonal transformation: Q' * A * P = B. */
/* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows in the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns in the matrix A. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the m by n general matrix to be reduced. */
/* On exit, */
/* if m >= n, the diagonal and the first superdiagonal are */
/* overwritten with the upper bidiagonal matrix B; the */
/* elements below the diagonal, with the array TAUQ, represent */
/* the orthogonal matrix Q as a product of elementary */
/* reflectors, and the elements above the first superdiagonal, */
/* with the array TAUP, represent the orthogonal matrix P as */
/* a product of elementary reflectors; */
/* if m < n, the diagonal and the first subdiagonal are */
/* overwritten with the lower bidiagonal matrix B; the */
/* elements below the first subdiagonal, with the array TAUQ, */
/* represent the orthogonal matrix Q as a product of */
/* elementary reflectors, and the elements above the diagonal, */
/* with the array TAUP, represent the orthogonal matrix P as */
/* a product of elementary reflectors. */
/* See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,M). */
/* D (output) DOUBLE PRECISION array, dimension (MIN(M,N)) */
/* The diagonal elements of the bidiagonal matrix B: */
/* D(i) = A(i,i). */
/* E (output) DOUBLE PRECISION array, dimension (MIN(M,N)-1) */
/* The off-diagonal elements of the bidiagonal matrix B: */
/* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */
/* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */
/* TAUQ (output) DOUBLE PRECISION array dimension (MIN(M,N)) */
/* The scalar factors of the elementary reflectors which */
/* represent the orthogonal matrix Q. See Further Details. */
/* TAUP (output) DOUBLE PRECISION array, dimension (MIN(M,N)) */
/* The scalar factors of the elementary reflectors which */
/* represent the orthogonal matrix P. See Further Details. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(M,N)) */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The matrices Q and P are represented as products of elementary */
/* reflectors: */
/* If m >= n, */
/* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) */
/* Each H(i) and G(i) has the form: */
/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
/* where tauq and taup are float scalars, and v and u are float vectors; */
/* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); */
/* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); */
/* tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* If m < n, */
/* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) */
/* Each H(i) and G(i) has the form: */
/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
/* where tauq and taup are float scalars, and v and u are float vectors; */
/* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); */
/* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); */
/* tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* The contents of A on exit are illustrated by the following examples: */
/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
/* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) */
/* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) */
/* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) */
/* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) */
/* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) */
/* ( v1 v2 v3 v4 v5 ) */
/* where d and e denote diagonal and off-diagonal elements of B, vi */
/* denotes an element of the vector defining H(i), and ui an element of */
/* the vector defining G(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--d__;
--e;
--tauq;
--taup;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < MAX(1,*m)) {
*info = -4;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("DGEBD2", &i__1);
return 0;
}
if (*m >= *n) {
/* Reduce to upper bidiagonal form */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[MIN(i__3, *m)+ i__ *
a_dim1], &c__1, &tauq[i__]);
d__[i__] = a[i__ + i__ * a_dim1];
a[i__ + i__ * a_dim1] = 1.;
/* Apply H(i) to A(i:m,i+1:n) from the left */
if (i__ < *n) {
i__2 = *m - i__ + 1;
i__3 = *n - i__;
dlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
tauq[i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]
);
}
a[i__ + i__ * a_dim1] = d__[i__];
if (i__ < *n) {
/* Generate elementary reflector G(i) to annihilate */
/* A(i,i+2:n) */
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + MIN(
i__3, *n)* a_dim1], lda, &taup[i__]);
e[i__] = a[i__ + (i__ + 1) * a_dim1];
a[i__ + (i__ + 1) * a_dim1] = 1.;
/* Apply G(i) to A(i+1:m,i+1:n) from the right */
i__2 = *m - i__;
i__3 = *n - i__;
dlarf_("Right", &i__2, &i__3, &a[i__ + (i__ + 1) * a_dim1],
lda, &taup[i__], &a[i__ + 1 + (i__ + 1) * a_dim1],
lda, &work[1]);
a[i__ + (i__ + 1) * a_dim1] = e[i__];
} else {
taup[i__] = 0.;
}
/* L10: */
}
} else {
/* Reduce to lower bidiagonal form */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector G(i) to annihilate A(i,i+1:n) */
i__2 = *n - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + MIN(i__3, *n)*
a_dim1], lda, &taup[i__]);
d__[i__] = a[i__ + i__ * a_dim1];
a[i__ + i__ * a_dim1] = 1.;
/* Apply G(i) to A(i+1:m,i:n) from the right */
if (i__ < *m) {
i__2 = *m - i__;
i__3 = *n - i__ + 1;
dlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &
taup[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]);
}
a[i__ + i__ * a_dim1] = d__[i__];
if (i__ < *m) {
/* Generate elementary reflector H(i) to annihilate */
/* A(i+2:m,i) */
i__2 = *m - i__;
/* Computing MIN */
i__3 = i__ + 2;
dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[MIN(i__3, *m)+
i__ * a_dim1], &c__1, &tauq[i__]);
e[i__] = a[i__ + 1 + i__ * a_dim1];
a[i__ + 1 + i__ * a_dim1] = 1.;
/* Apply H(i) to A(i+1:m,i+1:n) from the left */
i__2 = *m - i__;
i__3 = *n - i__;
dlarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &
c__1, &tauq[i__], &a[i__ + 1 + (i__ + 1) * a_dim1],
lda, &work[1]);
a[i__ + 1 + i__ * a_dim1] = e[i__];
} else {
tauq[i__] = 0.;
}
/* L20: */
}
}
return 0;
/* End of DGEBD2 */
} /* dgebd2_ */
/* Subroutine */ int dgehd2_(integer *n, integer *ilo, integer *ihi,
doublereal *a, integer *lda, doublereal *tau, doublereal *work,
integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
DGEHD2 reduces a real general matrix A to upper Hessenberg form H by
an orthogonal similarity transformation: Q' * A * Q = H .
Arguments
=========
N (input) INTEGER
The order of the matrix A. N >= 0.
ILO (input) INTEGER
IHI (input) INTEGER
It is assumed that A 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; otherwise they should be
set to 1 and N respectively. See Further Details.
1 <= ILO <= IHI <= max(1,N).
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the n by n general matrix to be reduced.
On exit, the upper triangle and the first subdiagonal of A
are overwritten with the upper Hessenberg matrix H, and the
elements below the first subdiagonal, with the array TAU,
represent the orthogonal matrix Q as a product of elementary
reflectors. See Further Details.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
TAU (output) DOUBLE PRECISION array, dimension (N-1)
The scalar factors of the elementary reflectors (see Further
Details).
WORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
Further Details
===============
The matrix Q is represented as a product of (ihi-ilo) elementary
reflectors
Q = H(ilo) H(ilo+1) . . . H(ihi-1).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a real scalar, and v is a real vector with
v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
exit in A(i+2:ihi,i), and tau in TAU(i).
The contents of A are illustrated by the following example, with
n = 7, ilo = 2 and ihi = 6:
on entry, on exit,
( a a a a a a a ) ( a a h h h h a )
( a a a a a a ) ( a h h h h a )
( a a a a a a ) ( h h h h h h )
( a a a a a a ) ( v2 h h h h h )
( a a a a a a ) ( v2 v3 h h h h )
( a a a a a a ) ( v2 v3 v4 h h h )
( a ) ( a )
where a denotes an element of the original matrix A, h denotes a
modified element of the upper Hessenberg matrix H, and vi denotes an
element of the vector defining H(i).
=====================================================================
Test the input parameters
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
static integer i;
extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *), dlarfg_(integer *, doublereal *,
doublereal *, integer *, doublereal *), xerbla_(char *, integer *);
static doublereal aii;
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -2;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEHD2", &i__1);
return 0;
}
i__1 = *ihi - 1;
for (i = *ilo; i <= *ihi-1; ++i) {
/* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
*/
i__2 = *ihi - i;
/* Computing MIN */
i__3 = i + 2;
dlarfg_(&i__2, &A(i+1,i), &A(min(i+2,*n),i),
&c__1, &TAU(i));
aii = A(i+1,i);
A(i+1,i) = 1.;
/* Apply H(i) to A(1:ihi,i+1:ihi) from the right */
i__2 = *ihi - i;
dlarf_("Right", ihi, &i__2, &A(i+1,i), &c__1, &TAU(i), &
A(1,i+1), lda, &WORK(1));
/* Apply H(i) to A(i+1:ihi,i+1:n) from the left */
i__2 = *ihi - i;
i__3 = *n - i;
dlarf_("Left", &i__2, &i__3, &A(i+1,i), &c__1, &TAU(i), &
A(i+1,i+1), lda, &WORK(1));
A(i+1,i) = aii;
/* L10: */
}
return 0;
/* End of DGEHD2 */
} /* dgehd2_ */
/* 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 DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) >*/
/* Subroutine */ int dgeqr2_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *tau, doublereal *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, k;
doublereal aii;
extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, ftnlen), dlarfg_(integer *, doublereal *,
doublereal *, integer *, doublereal *), xerbla_(char *, integer *,
ftnlen);
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* February 29, 1992 */
/* .. Scalar Arguments .. */
/*< INTEGER INFO, LDA, M, N >*/
/* .. */
/* .. Array Arguments .. */
/*< DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) >*/
/* .. */
/* Purpose */
/* ======= */
/* DGEQR2 computes a QR factorization of a real m by n matrix A: */
/* A = Q * R. */
/* 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/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the m by n matrix A. */
/* On exit, the elements on and above the diagonal of the array */
/* contain the min(m,n) by n upper trapezoidal matrix R (R is */
/* upper triangular if m >= n); the elements below the diagonal, */
/* with the array TAU, represent the orthogonal matrix Q as a */
/* product of elementary reflectors (see Further Details). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of elementary reflectors */
/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */
/* and tau in TAU(i). */
/* ===================================================================== */
/* .. Parameters .. */
/*< DOUBLE PRECISION ONE >*/
/*< PARAMETER ( ONE = 1.0D+0 ) >*/
/* .. */
/* .. Local Scalars .. */
/*< INTEGER I, K >*/
/*< DOUBLE PRECISION AII >*/
/* .. */
/* .. External Subroutines .. */
/*< EXTERNAL DLARF, DLARFG, XERBLA >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC MAX, MIN >*/
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/*< INFO = 0 >*/
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
/*< IF( M.LT.0 ) THEN >*/
if (*m < 0) {
/*< INFO = -1 >*/
*info = -1;
/*< ELSE IF( N.LT.0 ) THEN >*/
} else if (*n < 0) {
/*< INFO = -2 >*/
*info = -2;
/*< ELSE IF( LDA.LT.MAX( 1, M ) ) THEN >*/
} else if (*lda < max(1,*m)) {
/*< INFO = -4 >*/
*info = -4;
/*< END IF >*/
}
/*< IF( INFO.NE.0 ) THEN >*/
if (*info != 0) {
/*< CALL XERBLA( 'DGEQR2', -INFO ) >*/
i__1 = -(*info);
xerbla_("DGEQR2", &i__1, (ftnlen)6);
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/*< K = MIN( M, N ) >*/
k = min(*m,*n);
/*< DO 10 I = 1, K >*/
i__1 = k;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
/*< >*/
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3,*m) + i__ * a_dim1]
, &c__1, &tau[i__]);
/*< IF( I.LT.N ) THEN >*/
if (i__ < *n) {
/* Apply H(i) to A(i:m,i+1:n) from the left */
/*< AII = A( I, I ) >*/
aii = a[i__ + i__ * a_dim1];
/*< A( I, I ) = ONE >*/
a[i__ + i__ * a_dim1] = 1.;
/*< >*/
i__2 = *m - i__ + 1;
i__3 = *n - i__;
dlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &tau[
i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], (
ftnlen)4);
/*< A( I, I ) = AII >*/
a[i__ + i__ * a_dim1] = aii;
/*< END IF >*/
}
/*< 10 CONTINUE >*/
/* L10: */
}
/*< RETURN >*/
return 0;
/* End of DGEQR2 */
/*< END >*/
} /* dgeqr2_ */
/* Subroutine */ int dlatrz_(integer *m, integer *n, integer *l, doublereal *
a, integer *lda, doublereal *tau, doublereal *work)
{
/* -- LAPACK 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
=======
DLATRZ factors the M-by-(M+L) real upper trapezoidal matrix
[ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z, by means
of orthogonal transformations. Z is an (M+L)-by-(M+L) orthogonal
matrix and, R and A1 are M-by-M upper triangular matrices.
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.
L (input) INTEGER
The number of columns of the matrix A containing the
meaningful part of the Householder vectors. N-M >= L >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the leading M-by-N upper trapezoidal part of the
array A must contain the matrix to be factorized.
On exit, the leading M-by-M upper triangular part of A
contains the upper triangular matrix R, and elements N-L+1 to
N of the first M rows of A, with the array TAU, represent the
orthogonal matrix Z as a product of M elementary reflectors.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
TAU (output) DOUBLE PRECISION array, dimension (M)
The scalar factors of the elementary reflectors.
WORK (workspace) DOUBLE PRECISION array, dimension (M)
Further Details
===============
Based on contributions by
A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
The factorization is obtained by Householder's method. The kth
transformation matrix, Z( k ), which is used to introduce zeros into
the ( m - k + 1 )th row of A, is given in the form
Z( k ) = ( I 0 ),
( 0 T( k ) )
where
T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),
( 0 )
( z( k ) )
tau is a scalar and z( k ) is an l element vector. tau and z( k )
are chosen to annihilate the elements of the kth row of A2.
The scalar tau is returned in the kth element of TAU and the vector
u( k ) in the kth row of A2, such that the elements of z( k ) are
in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in
the upper triangular part of A1.
Z is given by
Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).
=====================================================================
Test the input arguments
Quick return if possible
Parameter adjustments */
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
static integer i__;
extern /* Subroutine */ int dlarz_(char *, integer *, integer *, integer *
, doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *), dlarfg_(integer *, doublereal *,
doublereal *, integer *, doublereal *);
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
--work;
/* Function Body */
if (*m == 0) {
return 0;
} else if (*m == *n) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
tau[i__] = 0.;
/* L10: */
}
return 0;
}
for (i__ = *m; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) to annihilate
[ A(i,i) A(i,n-l+1:n) ] */
i__1 = *l + 1;
dlarfg_(&i__1, &a_ref(i__, i__), &a_ref(i__, *n - *l + 1), lda, &tau[
i__]);
/* Apply H(i) to A(1:i-1,i:n) from the right */
i__1 = i__ - 1;
i__2 = *n - i__ + 1;
dlarz_("Right", &i__1, &i__2, l, &a_ref(i__, *n - *l + 1), lda, &tau[
i__], &a_ref(1, i__), lda, &work[1]);
/* L20: */
}
return 0;
/* End of DLATRZ */
} /* dlatrz_ */
/* Subroutine */ int dsytd2_(char* uplo, integer* n, doublereal* a, integer *
lda, doublereal* d__, doublereal* e, doublereal* tau, integer* info) {
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__;
extern doublereal ddot_(integer*, doublereal*, integer*, doublereal*,
integer*);
doublereal taui;
extern /* Subroutine */ int dsyr2_(char*, integer*, doublereal*,
doublereal*, integer*, doublereal*, integer*, doublereal*,
integer*);
doublereal alpha;
extern logical lsame_(char*, char*);
extern /* Subroutine */ int daxpy_(integer*, doublereal*, doublereal*,
integer*, doublereal*, integer*);
logical upper;
extern /* Subroutine */ int dsymv_(char*, integer*, doublereal*,
doublereal*, integer*, doublereal*, integer*, doublereal*,
doublereal*, integer*), dlarfg_(integer*, doublereal*,
doublereal*, integer*, doublereal*), 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 */
/* ======= */
/* DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal */
/* form T by an orthogonal similarity transformation: Q' * A * Q = T. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* symmetric matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
/* n-by-n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n-by-n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, if UPLO = 'U', the diagonal and first superdiagonal */
/* of A are overwritten by the corresponding elements of the */
/* tridiagonal matrix T, and the elements above the first */
/* superdiagonal, with the array TAU, represent the orthogonal */
/* matrix Q as a product of elementary reflectors; if UPLO */
/* = 'L', the diagonal and first subdiagonal of A are over- */
/* written by the corresponding elements of the tridiagonal */
/* matrix T, and the elements below the first subdiagonal, with */
/* the array TAU, represent the orthogonal matrix Q as a product */
/* of elementary reflectors. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* D (output) DOUBLE PRECISION array, dimension (N) */
/* The diagonal elements of the tridiagonal matrix T: */
/* D(i) = A(i,i). */
/* E (output) DOUBLE PRECISION array, dimension (N-1) */
/* The off-diagonal elements of the tridiagonal matrix T: */
/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */
/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(n-1) . . . H(2) H(1). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */
/* A(1:i-1,i+1), and tau in TAU(i). */
/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(1) H(2) . . . H(n-1). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */
/* and tau in TAU(i). */
/* The contents of A on exit are illustrated by the following examples */
/* with n = 5: */
/* if UPLO = 'U': if UPLO = 'L': */
/* ( d e v2 v3 v4 ) ( d ) */
/* ( d e v3 v4 ) ( e d ) */
/* ( d e v4 ) ( v1 e d ) */
/* ( d e ) ( v1 v2 e d ) */
/* ( d ) ( v1 v2 v3 e d ) */
/* where d and e denote diagonal and off-diagonal elements of T, and vi */
/* denotes an element of the vector defining H(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--d__;
--e;
--tau;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1, *n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYTD2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
if (upper) {
/* Reduce the upper triangle of A */
for (i__ = *n - 1; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) = I - tau * v * v' */
/* to annihilate A(1:i-1,i+1) */
dlarfg_(&i__, &a[i__ + (i__ + 1) * a_dim1], &a[(i__ + 1) * a_dim1
+ 1], &c__1, &taui);
e[i__] = a[i__ + (i__ + 1) * a_dim1];
if (taui != 0.) {
/* Apply H(i) from both sides to A(1:i,1:i) */
a[i__ + (i__ + 1) * a_dim1] = 1.;
/* Compute x := tau * A * v storing x in TAU(1:i) */
dsymv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) *
a_dim1 + 1], &c__1, &c_b8, &tau[1], &c__1);
/* Compute w := x - 1/2 * tau * (x'*v) * v */
alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &a[(i__ + 1)
* a_dim1 + 1], &c__1);
daxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[
1], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w' - w * v' */
dsyr2_(uplo, &i__, &c_b14, &a[(i__ + 1) * a_dim1 + 1], &c__1,
&tau[1], &c__1, &a[a_offset], lda);
a[i__ + (i__ + 1) * a_dim1] = e[i__];
}
d__[i__ + 1] = a[i__ + 1 + (i__ + 1) * a_dim1];
tau[i__] = taui;
/* L10: */
}
d__[1] = a[a_dim1 + 1];
} else {
/* Reduce the lower triangle of A */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) = I - tau * v * v' */
/* to annihilate A(i+2:n,i) */
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *n)+ i__ *
a_dim1], &c__1, &taui);
e[i__] = a[i__ + 1 + i__ * a_dim1];
if (taui != 0.) {
/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
a[i__ + 1 + i__ * a_dim1] = 1.;
/* Compute x := tau * A * v storing y in TAU(i:n-1) */
i__2 = *n - i__;
dsymv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1],
lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b8, &tau[
i__], &c__1);
/* Compute w := x - 1/2 * tau * (x'*v) * v */
i__2 = *n - i__;
alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &a[i__ +
1 + i__ * a_dim1], &c__1);
i__2 = *n - i__;
daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
i__], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w' - w * v' */
i__2 = *n - i__;
dsyr2_(uplo, &i__2, &c_b14, &a[i__ + 1 + i__ * a_dim1], &c__1,
&tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1],
lda);
a[i__ + 1 + i__ * a_dim1] = e[i__];
}
d__[i__] = a[i__ + i__ * a_dim1];
tau[i__] = taui;
/* L20: */
}
d__[*n] = a[*n + *n * a_dim1];
}
return 0;
/* End of DSYTD2 */
} /* dsytd2_ */
/* Subroutine */ int dtzrqf_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *tau, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
integer i__, k, m1;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *), dgemv_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *), dcopy_(integer *, doublereal *,
integer *, doublereal *, integer *), daxpy_(integer *, doublereal
*, doublereal *, integer *, doublereal *, integer *), dlarfg_(
integer *, doublereal *, doublereal *, integer *, doublereal *),
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 */
/* ======= */
/* This routine is deprecated and has been replaced by routine DTZRZF. */
/* DTZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A */
/* to upper triangular form by means of orthogonal transformations. */
/* The upper trapezoidal matrix A is factored as */
/* A = ( R 0 ) * Z, */
/* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper */
/* triangular matrix. */
/* 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. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the leading M-by-N upper trapezoidal part of the */
/* array A must contain the matrix to be factorized. */
/* On exit, the leading M-by-M upper triangular part of A */
/* contains the upper triangular matrix R, and elements M+1 to */
/* N of the first M rows of A, with the array TAU, represent the */
/* orthogonal matrix Z as a product of M elementary reflectors. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) DOUBLE PRECISION array, dimension (M) */
/* The scalar factors of the elementary reflectors. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The factorization is obtained by Householder's method. The kth */
/* transformation matrix, Z( k ), which is used to introduce zeros into */
/* the ( m - k + 1 )th row of A, is given in the form */
/* Z( k ) = ( I 0 ), */
/* ( 0 T( k ) ) */
/* where */
/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */
/* ( 0 ) */
/* ( z( k ) ) */
/* tau is a scalar and z( k ) is an ( n - m ) element vector. */
/* tau and z( k ) are chosen to annihilate the elements of the kth row */
/* of X. */
/* The scalar tau is returned in the kth element of TAU and the vector */
/* u( k ) in the kth row of A, such that the elements of z( k ) are */
/* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */
/* the upper triangular part of A. */
/* Z is given by */
/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < *m) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DTZRQF", &i__1);
return 0;
}
/* Perform the factorization. */
if (*m == 0) {
return 0;
}
if (*m == *n) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
tau[i__] = 0.;
/* L10: */
}
} else {
/* Computing MIN */
i__1 = *m + 1;
m1 = min(i__1,*n);
for (k = *m; k >= 1; --k) {
/* Use a Householder reflection to zero the kth row of A. */
/* First set up the reflection. */
i__1 = *n - *m + 1;
dlarfg_(&i__1, &a[k + k * a_dim1], &a[k + m1 * a_dim1], lda, &tau[
k]);
if (tau[k] != 0. && k > 1) {
/* We now perform the operation A := A*P( k ). */
/* Use the first ( k - 1 ) elements of TAU to store a( k ), */
/* where a( k ) consists of the first ( k - 1 ) elements of */
/* the kth column of A. Also let B denote the first */
/* ( k - 1 ) rows of the last ( n - m ) columns of A. */
i__1 = k - 1;
dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &tau[1], &c__1);
/* Form w = a( k ) + B*z( k ) in TAU. */
i__1 = k - 1;
i__2 = *n - *m;
dgemv_("No transpose", &i__1, &i__2, &c_b8, &a[m1 * a_dim1 +
1], lda, &a[k + m1 * a_dim1], lda, &c_b8, &tau[1], &
c__1);
/* Now form a( k ) := a( k ) - tau*w */
/* and B := B - tau*w*z( k )'. */
i__1 = k - 1;
d__1 = -tau[k];
daxpy_(&i__1, &d__1, &tau[1], &c__1, &a[k * a_dim1 + 1], &
c__1);
i__1 = k - 1;
i__2 = *n - *m;
d__1 = -tau[k];
dger_(&i__1, &i__2, &d__1, &tau[1], &c__1, &a[k + m1 * a_dim1]
, lda, &a[m1 * a_dim1 + 1], lda);
}
/* L20: */
}
}
return 0;
/* End of DTZRQF */
} /* dtzrqf_ */
/* Subroutine */ int dlabrd_(integer *m, integer *n, integer *nb, doublereal *
a, integer *lda, doublereal *d__, doublereal *e, doublereal *tauq,
doublereal *taup, doublereal *x, integer *ldx, doublereal *y, integer
*ldy)
{
/* System generated locals */
integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2,
i__3;
/* Local variables */
integer i__;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dgemv_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *), dlarfg_(integer *, doublereal *,
doublereal *, integer *, doublereal *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLABRD reduces the first NB rows and columns of a real general */
/* m by n matrix A to upper or lower bidiagonal form by an orthogonal */
/* transformation Q' * A * P, and returns the matrices X and Y which */
/* are needed to apply the transformation to the unreduced part of A. */
/* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower */
/* bidiagonal form. */
/* This is an auxiliary routine called by DGEBRD */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows in the matrix A. */
/* N (input) INTEGER */
/* The number of columns in the matrix A. */
/* NB (input) INTEGER */
/* The number of leading rows and columns of A to be reduced. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the m by n general matrix to be reduced. */
/* On exit, the first NB rows and columns of the matrix are */
/* overwritten; the rest of the array is unchanged. */
/* If m >= n, elements on and below the diagonal in the first NB */
/* columns, with the array TAUQ, represent the orthogonal */
/* matrix Q as a product of elementary reflectors; and */
/* elements above the diagonal in the first NB rows, with the */
/* array TAUP, represent the orthogonal matrix P as a product */
/* of elementary reflectors. */
/* If m < n, elements below the diagonal in the first NB */
/* columns, with the array TAUQ, represent the orthogonal */
/* matrix Q as a product of elementary reflectors, and */
/* elements on and above the diagonal in the first NB rows, */
/* with the array TAUP, represent the orthogonal matrix P as */
/* a product of elementary reflectors. */
/* See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* D (output) DOUBLE PRECISION array, dimension (NB) */
/* The diagonal elements of the first NB rows and columns of */
/* the reduced matrix. D(i) = A(i,i). */
/* E (output) DOUBLE PRECISION array, dimension (NB) */
/* The off-diagonal elements of the first NB rows and columns of */
/* the reduced matrix. */
/* TAUQ (output) DOUBLE PRECISION array dimension (NB) */
/* The scalar factors of the elementary reflectors which */
/* represent the orthogonal matrix Q. See Further Details. */
/* TAUP (output) DOUBLE PRECISION array, dimension (NB) */
/* The scalar factors of the elementary reflectors which */
/* represent the orthogonal matrix P. See Further Details. */
/* X (output) DOUBLE PRECISION array, dimension (LDX,NB) */
/* The m-by-nb matrix X required to update the unreduced part */
/* of A. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= M. */
/* Y (output) DOUBLE PRECISION array, dimension (LDY,NB) */
/* The n-by-nb matrix Y required to update the unreduced part */
/* of A. */
/* LDY (input) INTEGER */
/* The leading dimension of the array Y. LDY >= N. */
/* Further Details */
/* =============== */
/* The matrices Q and P are represented as products of elementary */
/* reflectors: */
/* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) */
/* Each H(i) and G(i) has the form: */
/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
/* where tauq and taup are real scalars, and v and u are real vectors. */
/* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in */
/* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in */
/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in */
/* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in */
/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* The elements of the vectors v and u together form the m-by-nb matrix */
/* V and the nb-by-n matrix U' which are needed, with X and Y, to apply */
/* the transformation to the unreduced part of the matrix, using a block */
/* update of the form: A := A - V*Y' - X*U'. */
/* The contents of A on exit are illustrated by the following examples */
/* with nb = 2: */
/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
/* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) */
/* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) */
/* ( v1 v2 a a a ) ( v1 1 a a a a ) */
/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */
/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */
/* ( v1 v2 a a a ) */
/* where a denotes an element of the original matrix which is unchanged, */
/* vi denotes an element of the vector defining H(i), and ui an element */
/* of the vector defining G(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--d__;
--e;
--tauq;
--taup;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
/* Function Body */
if (*m <= 0 || *n <= 0) {
return 0;
}
if (*m >= *n) {
/* Reduce to upper bidiagonal form */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i:m,i) */
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + a_dim1], lda,
&y[i__ + y_dim1], ldy, &c_b5, &a[i__ + i__ * a_dim1], &
c__1);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + x_dim1], ldx,
&a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[i__ + i__ *
a_dim1], &c__1);
/* Generate reflection Q(i) to annihilate A(i+1:m,i) */
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3, *m)+ i__ *
a_dim1], &c__1, &tauq[i__]);
d__[i__] = a[i__ + i__ * a_dim1];
if (i__ < *n) {
a[i__ + i__ * a_dim1] = 1.;
/* Compute Y(i+1:n,i) */
i__2 = *m - i__ + 1;
i__3 = *n - i__;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + (i__ + 1) *
a_dim1], lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &
y[i__ + 1 + i__ * y_dim1], &c__1);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1],
lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ *
y_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 +
y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[
i__ + 1 + i__ * y_dim1], &c__1);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &x[i__ + x_dim1],
ldx, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ *
y_dim1 + 1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_("Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) *
a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5,
&y[i__ + 1 + i__ * y_dim1], &c__1);
i__2 = *n - i__;
dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
/* Update A(i,i+1:n) */
i__2 = *n - i__;
dgemv_("No transpose", &i__2, &i__, &c_b4, &y[i__ + 1 +
y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b5, &a[i__ + (
i__ + 1) * a_dim1], lda);
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_("Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) *
a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b5, &a[
i__ + (i__ + 1) * a_dim1], lda);
/* Generate reflection P(i) to annihilate A(i,i+2:n) */
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + min(
i__3, *n)* a_dim1], lda, &taup[i__]);
e[i__] = a[i__ + (i__ + 1) * a_dim1];
a[i__ + (i__ + 1) * a_dim1] = 1.;
/* Compute X(i+1:m,i) */
i__2 = *m - i__;
i__3 = *n - i__;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__
+ 1) * a_dim1], lda, &a[i__ + (i__ + 1) * a_dim1],
lda, &c_b16, &x[i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *n - i__;
dgemv_("Transpose", &i__2, &i__, &c_b5, &y[i__ + 1 + y_dim1],
ldy, &a[i__ + (i__ + 1) * a_dim1], lda, &c_b16, &x[
i__ * x_dim1 + 1], &c__1);
i__2 = *m - i__;
dgemv_("No transpose", &i__2, &i__, &c_b4, &a[i__ + 1 +
a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
i__ + 1 + i__ * x_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) *
a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, &
c_b16, &x[i__ * x_dim1 + 1], &c__1);
i__2 = *m - i__;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 +
x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *m - i__;
dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
}
/* L10: */
}
} else {
/* Reduce to lower bidiagonal form */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i,i:n) */
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + y_dim1], ldy,
&a[i__ + a_dim1], lda, &c_b5, &a[i__ + i__ * a_dim1],
lda);
i__2 = i__ - 1;
i__3 = *n - i__ + 1;
dgemv_("Transpose", &i__2, &i__3, &c_b4, &a[i__ * a_dim1 + 1],
lda, &x[i__ + x_dim1], ldx, &c_b5, &a[i__ + i__ * a_dim1],
lda);
/* Generate reflection P(i) to annihilate A(i,i+1:n) */
i__2 = *n - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3, *n)*
a_dim1], lda, &taup[i__]);
d__[i__] = a[i__ + i__ * a_dim1];
if (i__ < *m) {
a[i__ + i__ * a_dim1] = 1.;
/* Compute X(i+1:m,i) */
i__2 = *m - i__;
i__3 = *n - i__ + 1;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + i__ *
a_dim1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, &
x[i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &y[i__ + y_dim1],
ldy, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ *
x_dim1 + 1], &c__1);
i__2 = *m - i__;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 +
a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
i__ + 1 + i__ * x_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__ + 1;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ * a_dim1 +
1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ *
x_dim1 + 1], &c__1);
i__2 = *m - i__;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 +
x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
i__ + 1 + i__ * x_dim1], &c__1);
i__2 = *m - i__;
dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
/* Update A(i+1:m,i) */
i__2 = *m - i__;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 +
a_dim1], lda, &y[i__ + y_dim1], ldy, &c_b5, &a[i__ +
1 + i__ * a_dim1], &c__1);
i__2 = *m - i__;
dgemv_("No transpose", &i__2, &i__, &c_b4, &x[i__ + 1 +
x_dim1], ldx, &a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[
i__ + 1 + i__ * a_dim1], &c__1);
/* Generate reflection Q(i) to annihilate A(i+2:m,i) */
i__2 = *m - i__;
/* Computing MIN */
i__3 = i__ + 2;
dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *m)+
i__ * a_dim1], &c__1, &tauq[i__]);
e[i__] = a[i__ + 1 + i__ * a_dim1];
a[i__ + 1 + i__ * a_dim1] = 1.;
/* Compute Y(i+1:n,i) */
i__2 = *m - i__;
i__3 = *n - i__;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__ +
1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1,
&c_b16, &y[i__ + 1 + i__ * y_dim1], &c__1);
i__2 = *m - i__;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + a_dim1],
lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[
i__ * y_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 +
y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[
i__ + 1 + i__ * y_dim1], &c__1);
i__2 = *m - i__;
dgemv_("Transpose", &i__2, &i__, &c_b5, &x[i__ + 1 + x_dim1],
ldx, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[
i__ * y_dim1 + 1], &c__1);
i__2 = *n - i__;
dgemv_("Transpose", &i__, &i__2, &c_b4, &a[(i__ + 1) * a_dim1
+ 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[i__
+ 1 + i__ * y_dim1], &c__1);
i__2 = *n - i__;
dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
}
/* L20: */
}
}
return 0;
/* End of DLABRD */
} /* dlabrd_ */
/* Subroutine */
int dgeqrt3_(integer *m, integer *n, doublereal *a, integer * lda, doublereal *t, integer *ldt, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, t_dim1, t_offset, i__1, i__2;
/* Local variables */
integer i__, j, i1, j1, n1, n2;
extern /* Subroutine */
int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *);
integer iinfo;
extern /* Subroutine */
int dtrmm_(char *, char *, char *, char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *), dlarfg_( integer *, doublereal *, doublereal *, integer *, doublereal *), xerbla_(char *, integer *);
/* -- LAPACK computational routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
/* Function Body */
*info = 0;
if (*n < 0)
{
*info = -2;
}
else if (*m < *n)
{
*info = -1;
}
else if (*lda < max(1,*m))
{
*info = -4;
}
else if (*ldt < max(1,*n))
{
*info = -6;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DGEQRT3", &i__1);
return 0;
}
if (*n == 1)
{
/* Compute Householder transform when N=1 */
dlarfg_(m, &a[a_offset], &a[min(2,*m) + a_dim1], &c__1, &t[t_offset]);
}
else
{
/* Otherwise, split A into blocks... */
n1 = *n / 2;
n2 = *n - n1;
/* Computing MIN */
i__1 = n1 + 1;
j1 = min(i__1,*n);
/* Computing MIN */
i__1 = *n + 1;
i1 = min(i__1,*m);
/* Compute A(1:M,1:N1) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1^H */
dgeqrt3_(m, &n1, &a[a_offset], lda, &t[t_offset], ldt, &iinfo);
/* Compute A(1:M,J1:N) = Q1^H A(1:M,J1:N) [workspace: T(1:N1,J1:N)] */
i__1 = n2;
for (j = 1;
j <= i__1;
++j)
{
i__2 = n1;
for (i__ = 1;
i__ <= i__2;
++i__)
{
t[i__ + (j + n1) * t_dim1] = a[i__ + (j + n1) * a_dim1];
}
}
dtrmm_("L", "L", "T", "U", &n1, &n2, &c_b8, &a[a_offset], lda, &t[j1 * t_dim1 + 1], ldt) ;
i__1 = *m - n1;
dgemm_("T", "N", &n1, &n2, &i__1, &c_b8, &a[j1 + a_dim1], lda, &a[j1 + j1 * a_dim1], lda, &c_b8, &t[j1 * t_dim1 + 1], ldt);
dtrmm_("L", "U", "T", "N", &n1, &n2, &c_b8, &t[t_offset], ldt, &t[j1 * t_dim1 + 1], ldt) ;
i__1 = *m - n1;
dgemm_("N", "N", &i__1, &n2, &n1, &c_b20, &a[j1 + a_dim1], lda, &t[j1 * t_dim1 + 1], ldt, &c_b8, &a[j1 + j1 * a_dim1], lda);
dtrmm_("L", "L", "N", "U", &n1, &n2, &c_b8, &a[a_offset], lda, &t[j1 * t_dim1 + 1], ldt) ;
i__1 = n2;
for (j = 1;
j <= i__1;
++j)
{
i__2 = n1;
for (i__ = 1;
i__ <= i__2;
++i__)
{
a[i__ + (j + n1) * a_dim1] -= t[i__ + (j + n1) * t_dim1];
}
}
/* Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2^H */
i__1 = *m - n1;
dgeqrt3_(&i__1, &n2, &a[j1 + j1 * a_dim1], lda, &t[j1 + j1 * t_dim1], ldt, &iinfo);
/* Compute T3 = T(1:N1,J1:N) = -T1 Y1^H Y2 T2 */
i__1 = n1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
i__2 = n2;
for (j = 1;
j <= i__2;
++j)
{
t[i__ + (j + n1) * t_dim1] = a[j + n1 + i__ * a_dim1];
}
}
dtrmm_("R", "L", "N", "U", &n1, &n2, &c_b8, &a[j1 + j1 * a_dim1], lda, &t[j1 * t_dim1 + 1], ldt);
i__1 = *m - *n;
dgemm_("T", "N", &n1, &n2, &i__1, &c_b8, &a[i1 + a_dim1], lda, &a[i1 + j1 * a_dim1], lda, &c_b8, &t[j1 * t_dim1 + 1], ldt);
dtrmm_("L", "U", "N", "N", &n1, &n2, &c_b20, &t[t_offset], ldt, &t[j1 * t_dim1 + 1], ldt);
dtrmm_("R", "U", "N", "N", &n1, &n2, &c_b8, &t[j1 + j1 * t_dim1], ldt, &t[j1 * t_dim1 + 1], ldt);
/* Y = (Y1,Y2);
R = [ R1 A(1:N1,J1:N) ];
T = [T1 T3] */
/* [ 0 R2 ] [ 0 T2] */
}
return 0;
/* End of DGEQRT3 */
}
/* 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)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DHSEQR computes the eigenvalues of a real upper 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 >= 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 SGEHRD
when the matrix output by DGEBAL is reduced to Hessenberg
form. Otherwise ILO and IHI should be set to 1 and N
respectively.
1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
H (input/output) DOUBLE PRECISION array, dimension (LDH,N)
On entry, the upper Hessenberg matrix H.
On exit, if JOB = 'S', 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) < 0. If JOB = 'E',
the contents of H are unspecified on exit.
LDH (input) INTEGER
The leading dimension of the array H. LDH >= 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) > 0 and
WI(i+1) < 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, 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 Z contains Q*Z.
Normally Q is the orthogonal matrix generated by DORGHR after
the call to DGEHRD which formed the Hessenberg matrix H.
LDZ (input) INTEGER
The leading dimension of the array Z.
LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise.
WORK (workspace) DOUBLE PRECISION array, dimension (N)
LWORK (input) INTEGER
This argument is currently redundant.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, DHSEQR failed to compute all of the
eigenvalues in a total of 30*(IHI-ILO+1) iterations;
elements 1:ilo-1 and i+1:n of WR and WI contain those
eigenvalues which have been successfully computed.
=====================================================================
Decode and test the input parameters
Parameter adjustments
Function Body */
/* Table of constant values */
static doublereal c_b9 = 0.;
static doublereal c_b10 = 1.;
static integer c__4 = 4;
static integer c_n1 = -1;
static integer c__2 = 2;
static integer c__8 = 8;
static integer c__15 = 15;
static logical c_false = FALSE_;
static integer c__1 = 1;
/* System generated locals */
address a__1[2];
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3[2], i__4,
i__5;
doublereal d__1, d__2;
char ch__1[2];
/* Builtin functions
Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer maxb;
static doublereal absw;
static integer ierr;
static doublereal unfl, temp, ovfl;
static integer i, j, k, l;
static doublereal s[225] /* was [15][15] */, v[16];
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 itemp;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer i1, i2;
static logical initz, wantt, wantz;
extern doublereal dlapy2_(doublereal *, doublereal *);
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
static integer ii, nh;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *);
static integer nr, ns;
extern integer idamax_(integer *, doublereal *, integer *);
static integer nv;
extern doublereal dlanhs_(char *, integer *, doublereal *, integer *,
doublereal *);
extern /* Subroutine */ int dlahqr_(logical *, logical *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *);
static doublereal vv[16];
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
dlarfx_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *), xerbla_(char *,
integer *);
static doublereal smlnum;
static integer itn;
static doublereal tau;
static integer its;
static doublereal ulp, tst1;
#define S(I) s[(I)]
#define WAS(I) was[(I)]
#define V(I) v[(I)]
#define VV(I) vv[(I)]
#define WR(I) wr[(I)-1]
#define WI(I) wi[(I)-1]
#define WORK(I) work[(I)-1]
#define H(I,J) h[(I)-1 + ((J)-1)* ( *ldh)]
#define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)]
wantt = lsame_(job, "S");
initz = lsame_(compz, "I");
wantz = initz || lsame_(compz, "V");
*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;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DHSEQR", &i__1);
return 0;
}
/* Initialize Z, if necessary */
if (initz) {
dlaset_("Full", n, n, &c_b9, &c_b10, &Z(1,1), ldz);
}
/* Store the eigenvalues isolated by DGEBAL. */
i__1 = *ilo - 1;
for (i = 1; i <= *ilo-1; ++i) {
WR(i) = H(i,i);
WI(i) = 0.;
/* L10: */
}
i__1 = *n;
for (i = *ihi + 1; i <= *n; ++i) {
WR(i) = H(i,i);
WI(i) = 0.;
/* L20: */
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
WR(*ilo) = H(*ilo,*ilo);
WI(*ilo) = 0.;
return 0;
}
/* Set rows and columns ILO to IHI to zero below the first
subdiagonal. */
i__1 = *ihi - 2;
for (j = *ilo; j <= *ihi-2; ++j) {
i__2 = *n;
for (i = j + 2; i <= *n; ++i) {
H(i,j) = 0.;
/* L30: */
}
/* L40: */
}
nh = *ihi - *ilo + 1;
/* Determine the order of the multi-shift QR algorithm to be used.
Writing concatenation */
i__3[0] = 1, a__1[0] = job;
i__3[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__3, &c__2, 2L);
ns = ilaenv_(&c__4, "DHSEQR", ch__1, n, ilo, ihi, &c_n1, 6L, 2L);
/* Writing concatenation */
i__3[0] = 1, a__1[0] = job;
i__3[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__3, &c__2, 2L);
maxb = ilaenv_(&c__8, "DHSEQR", ch__1, n, ilo, ihi, &c_n1, 6L, 2L);
if (ns <= 2 || ns > nh || maxb >= nh) {
/* Use the standard double-shift algorithm */
dlahqr_(&wantt, &wantz, n, ilo, ihi, &H(1,1), ldh, &WR(1), &WI(1)
, ilo, ihi, &Z(1,1), ldz, info);
return 0;
}
maxb = max(3,maxb);
/* Computing MIN */
i__1 = min(ns,maxb);
ns = min(i__1,15);
/* Now 2 < NS <= MAXB < NH.
Set machine-dependent constants for the stopping criterion.
If norm(H) <= sqrt(OVFL), overflow should not occur. */
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision");
smlnum = unfl * (nh / ulp);
/* I1 and I2 are the indices of the first row and last column of H
to which transformations must be applied. If eigenvalues only are
being computed, I1 and I2 are set inside the main loop. */
if (wantt) {
i1 = 1;
i2 = *n;
}
/* ITN is the total number of multiple-shift QR iterations allowed. */
itn = nh * 30;
/* The main loop begins here. I is the loop index and decreases from
IHI to ILO in steps of at most MAXB. Each iteration of the loop
works with the active submatrix in rows and columns L to I.
Eigenvalues I+1 to IHI have already converged. Either L = ILO or
H(L,L-1) is negligible so that the matrix splits. */
i = *ihi;
L50:
l = *ilo;
if (i < *ilo) {
goto L170;
}
/* Perform multiple-shift QR iterations on rows and columns ILO to I
until a submatrix of order at most MAXB splits off at the bottom
because a subdiagonal element has become negligible. */
i__1 = itn;
for (its = 0; its <= itn; ++its) {
/* Look for a single small subdiagonal element. */
i__2 = l + 1;
for (k = i; k >= l+1; --k) {
tst1 = (d__1 = H(k-1,k-1), abs(d__1)) + (d__2 =
H(k,k), abs(d__2));
if (tst1 == 0.) {
i__4 = i - l + 1;
tst1 = dlanhs_("1", &i__4, &H(l,l), ldh, &WORK(1));
}
/* Computing MAX */
d__2 = ulp * tst1;
if ((d__1 = H(k,k-1), abs(d__1)) <= max(d__2,
smlnum)) {
goto L70;
}
/* L60: */
}
L70:
l = k;
if (l > *ilo) {
/* H(L,L-1) is negligible. */
H(l,l-1) = 0.;
}
/* Exit from loop if a submatrix of order <= MAXB has split off
. */
if (l >= i - maxb + 1) {
goto L160;
}
/* Now the active submatrix is in rows and columns L to I. If
eigenvalues only are being computed, only the active submatr
ix
need be transformed. */
if (! wantt) {
i1 = l;
i2 = i;
}
if (its == 20 || its == 30) {
/* Exceptional shifts. */
i__2 = i;
for (ii = i - ns + 1; ii <= i; ++ii) {
WR(ii) = ((d__1 = H(ii,ii-1), abs(d__1)) + (
d__2 = H(ii,ii), abs(d__2))) * 1.5;
WI(ii) = 0.;
/* L80: */
}
} else {
/* Use eigenvalues of trailing submatrix of order NS as
shifts. */
dlacpy_("Full", &ns, &ns, &H(i-ns+1,i-ns+1),
ldh, s, &c__15);
dlahqr_(&c_false, &c_false, &ns, &c__1, &ns, s, &c__15, &WR(i -
ns + 1), &WI(i - ns + 1), &c__1, &ns, &Z(1,1), ldz, &
ierr);
if (ierr > 0) {
/* If DLAHQR failed to compute all NS eigenvalues
, use the
unconverged diagonal elements as the remaining
shifts. */
i__2 = ierr;
for (ii = 1; ii <= ierr; ++ii) {
WR(i - ns + ii) = S(ii + ii * 15 - 16);
WI(i - ns + ii) = 0.;
/* L90: */
}
}
}
/* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns))
where G is the Hessenberg submatrix H(L:I,L:I) and w is
the vector of shifts (stored in WR and WI). The result is
stored in the local array V. */
V(0) = 1.;
i__2 = ns + 1;
for (ii = 2; ii <= ns+1; ++ii) {
V(ii - 1) = 0.;
/* L100: */
}
nv = 1;
i__2 = i;
for (j = i - ns + 1; j <= i; ++j) {
if (WI(j) >= 0.) {
if (WI(j) == 0.) {
/* real shift */
i__4 = nv + 1;
dcopy_(&i__4, v, &c__1, vv, &c__1);
i__4 = nv + 1;
d__1 = -WR(j);
dgemv_("No transpose", &i__4, &nv, &c_b10, &H(l,l), ldh, vv, &c__1, &d__1, v, &c__1);
++nv;
} else if (WI(j) > 0.) {
/* complex conjugate pair of shifts */
i__4 = nv + 1;
dcopy_(&i__4, v, &c__1, vv, &c__1);
i__4 = nv + 1;
d__1 = WR(j) * -2.;
dgemv_("No transpose", &i__4, &nv, &c_b10, &H(l,l), ldh, v, &c__1, &d__1, vv, &c__1);
i__4 = nv + 1;
itemp = idamax_(&i__4, vv, &c__1);
/* Computing MAX */
d__2 = (d__1 = VV(itemp - 1), abs(d__1));
temp = 1. / max(d__2,smlnum);
i__4 = nv + 1;
dscal_(&i__4, &temp, vv, &c__1);
absw = dlapy2_(&WR(j), &WI(j));
temp = temp * absw * absw;
i__4 = nv + 2;
i__5 = nv + 1;
dgemv_("No transpose", &i__4, &i__5, &c_b10, &H(l,l), ldh, vv, &c__1, &temp, v, &c__1);
nv += 2;
}
/* Scale V(1:NV) so that max(abs(V(i))) = 1. If V
is zero,
reset it to the unit vector. */
itemp = idamax_(&nv, v, &c__1);
temp = (d__1 = V(itemp - 1), abs(d__1));
if (temp == 0.) {
V(0) = 1.;
i__4 = nv;
for (ii = 2; ii <= nv; ++ii) {
V(ii - 1) = 0.;
/* L110: */
}
} else {
temp = max(temp,smlnum);
d__1 = 1. / temp;
dscal_(&nv, &d__1, v, &c__1);
}
}
/* L120: */
}
/* Multiple-shift QR step */
i__2 = i - 1;
for (k = l; k <= i-1; ++k) {
/* The first iteration of this loop determines a reflect
ion G
from the vector V and applies it from left and right
to H,
thus creating a nonzero bulge below the subdiagonal.
Each subsequent iteration determines a reflection G t
o
restore the Hessenberg form in the (K-1)th column, an
d thus
chases the bulge one step toward the bottom of the ac
tive
submatrix. NR is the order of G.
Computing MIN */
i__4 = ns + 1, i__5 = i - k + 1;
nr = min(i__4,i__5);
if (k > l) {
dcopy_(&nr, &H(k,k-1), &c__1, v, &c__1);
}
dlarfg_(&nr, v, &V(1), &c__1, &tau);
if (k > l) {
H(k,k-1) = V(0);
i__4 = i;
for (ii = k + 1; ii <= i; ++ii) {
H(ii,k-1) = 0.;
/* L130: */
}
}
V(0) = 1.;
/* Apply G from the left to transform the rows of the ma
trix in
columns K to I2. */
i__4 = i2 - k + 1;
dlarfx_("Left", &nr, &i__4, v, &tau, &H(k,k), ldh, &
WORK(1));
/* Apply G from the right to transform the columns of th
e
matrix in rows I1 to min(K+NR,I).
Computing MIN */
i__5 = k + nr;
i__4 = min(i__5,i) - i1 + 1;
dlarfx_("Right", &i__4, &nr, v, &tau, &H(i1,k), ldh, &
WORK(1));
if (wantz) {
/* Accumulate transformations in the matrix Z */
dlarfx_("Right", &nh, &nr, v, &tau, &Z(*ilo,k),
ldz, &WORK(1));
}
/* L140: */
}
/* L150: */
}
/* Failure to converge in remaining number of iterations */
*info = i;
return 0;
L160:
/* A submatrix of order <= MAXB in rows and columns L to I has split
off. Use the double-shift QR algorithm to handle it. */
dlahqr_(&wantt, &wantz, n, &l, &i, &H(1,1), ldh, &WR(1), &WI(1), ilo,
ihi, &Z(1,1), ldz, info);
if (*info > 0) {
return 0;
}
/* Decrement number of remaining iterations, and return to start of
the main loop with a new value of I. */
itn -= its;
i = l - 1;
goto L50;
L170:
return 0;
/* End of DHSEQR */
} /* dhseqr_ */
/* Subroutine */ int dlaqrb_(logical *wantt, integer *n, integer *ilo,
integer *ihi, doublereal *h__, integer *ldh, doublereal *wr,
doublereal *wi, doublereal *z__, integer *info)
{
/* System generated locals */
integer h_dim1, h_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
/* Local variables */
static integer i__, j, k, l, m;
static doublereal s, v[3];
static integer i1, i2;
static doublereal t1, t2, t3, v1, v2, v3, h00, h10, h11, h12, h21, h22,
h33, h44;
static integer nh;
static doublereal cs;
static integer nr;
static doublereal sn, h33s, h44s;
static integer itn, its;
static doublereal ulp, sum, tst1, h43h34, unfl, ovfl;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
static doublereal work[1];
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dlanv2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), dlabad_(
doublereal *, doublereal *);
extern doublereal dlamch_(char *, ftnlen);
extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *);
extern doublereal dlanhs_(char *, integer *, doublereal *, integer *,
doublereal *, ftnlen);
static doublereal smlnum;
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %------------------------% */
/* | Local Scalars & Arrays | */
/* %------------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--wr;
--wi;
--z__;
/* Function Body */
*info = 0;
/* %--------------------------% */
/* | Quick return if possible | */
/* %--------------------------% */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
wr[*ilo] = h__[*ilo + *ilo * h_dim1];
wi[*ilo] = 0.;
return 0;
}
/* %---------------------------------------------% */
/* | Initialize the vector of last components of | */
/* | the Schur vectors for accumulation. | */
/* %---------------------------------------------% */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
z__[j] = 0.;
/* L5: */
}
z__[*n] = 1.;
nh = *ihi - *ilo + 1;
/* %-------------------------------------------------------------% */
/* | Set machine-dependent constants for the stopping criterion. | */
/* | If norm(H) <= sqrt(OVFL), overflow should not occur. | */
/* %-------------------------------------------------------------% */
unfl = dlamch_("safe minimum", (ftnlen)12);
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("precision", (ftnlen)9);
smlnum = unfl * (nh / ulp);
/* %---------------------------------------------------------------% */
/* | I1 and I2 are the indices of the first row and last column | */
/* | of H to which transformations must be applied. If eigenvalues | */
/* | only are computed, I1 and I2 are set inside the main loop. | */
/* | Zero out H(J+2,J) = ZERO for J=1:N if WANTT = .TRUE. | */
/* | else H(J+2,J) for J=ILO:IHI-ILO-1 if WANTT = .FALSE. | */
/* %---------------------------------------------------------------% */
if (*wantt) {
i1 = 1;
i2 = *n;
i__1 = i2 - 2;
for (i__ = 1; i__ <= i__1; ++i__) {
h__[i1 + i__ + 1 + i__ * h_dim1] = 0.;
/* L8: */
}
} else {
i__1 = *ihi - *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
h__[*ilo + i__ + 1 + (*ilo + i__ - 1) * h_dim1] = 0.;
/* L9: */
}
}
/* %---------------------------------------------------% */
/* | ITN is the total number of QR iterations allowed. | */
/* %---------------------------------------------------% */
itn = nh * 30;
/* ------------------------------------------------------------------ */
/* The main loop begins here. I is the loop index and decreases from */
/* IHI to ILO in steps of 1 or 2. Each iteration of the loop works */
/* with the active submatrix in rows and columns L to I. */
/* Eigenvalues I+1 to IHI have already converged. Either L = ILO or */
/* H(L,L-1) is negligible so that the matrix splits. */
/* ------------------------------------------------------------------ */
i__ = *ihi;
L10:
l = *ilo;
if (i__ < *ilo) {
goto L150;
}
/* %--------------------------------------------------------------% */
/* | Perform QR iterations on rows and columns ILO to I until a | */
/* | submatrix of order 1 or 2 splits off at the bottom because a | */
/* | subdiagonal element has become negligible. | */
/* %--------------------------------------------------------------% */
i__1 = itn;
for (its = 0; its <= i__1; ++its) {
/* %----------------------------------------------% */
/* | Look for a single small subdiagonal element. | */
/* %----------------------------------------------% */
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
tst1 = (d__1 = h__[k - 1 + (k - 1) * h_dim1], abs(d__1)) + (d__2 =
h__[k + k * h_dim1], abs(d__2));
if (tst1 == 0.) {
i__3 = i__ - l + 1;
tst1 = dlanhs_("1", &i__3, &h__[l + l * h_dim1], ldh, work, (
ftnlen)1);
}
/* Computing MAX */
d__2 = ulp * tst1;
if ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= max(d__2,
smlnum)) {
goto L30;
}
/* L20: */
}
L30:
l = k;
if (l > *ilo) {
/* %------------------------% */
/* | H(L,L-1) is negligible | */
/* %------------------------% */
h__[l + (l - 1) * h_dim1] = 0.;
}
/* %-------------------------------------------------------------% */
/* | Exit from loop if a submatrix of order 1 or 2 has split off | */
/* %-------------------------------------------------------------% */
if (l >= i__ - 1) {
goto L140;
}
/* %---------------------------------------------------------% */
/* | Now the active submatrix is in rows and columns L to I. | */
/* | If eigenvalues only are being computed, only the active | */
/* | submatrix need be transformed. | */
/* %---------------------------------------------------------% */
if (! (*wantt)) {
i1 = l;
i2 = i__;
}
if (its == 10 || its == 20) {
/* %-------------------% */
/* | Exceptional shift | */
/* %-------------------% */
s = (d__1 = h__[i__ + (i__ - 1) * h_dim1], abs(d__1)) + (d__2 =
h__[i__ - 1 + (i__ - 2) * h_dim1], abs(d__2));
h44 = s * .75;
h33 = h44;
h43h34 = s * -.4375 * s;
} else {
/* %-----------------------------------------% */
/* | Prepare to use Wilkinson's double shift | */
/* %-----------------------------------------% */
h44 = h__[i__ + i__ * h_dim1];
h33 = h__[i__ - 1 + (i__ - 1) * h_dim1];
h43h34 = h__[i__ + (i__ - 1) * h_dim1] * h__[i__ - 1 + i__ *
h_dim1];
}
/* %-----------------------------------------------------% */
/* | Look for two consecutive small subdiagonal elements | */
/* %-----------------------------------------------------% */
i__2 = l;
for (m = i__ - 2; m >= i__2; --m) {
/* %---------------------------------------------------------% */
/* | Determine the effect of starting the double-shift QR | */
/* | iteration at row M, and see if this would make H(M,M-1) | */
/* | negligible. | */
/* %---------------------------------------------------------% */
h11 = h__[m + m * h_dim1];
h22 = h__[m + 1 + (m + 1) * h_dim1];
h21 = h__[m + 1 + m * h_dim1];
h12 = h__[m + (m + 1) * h_dim1];
h44s = h44 - h11;
h33s = h33 - h11;
v1 = (h33s * h44s - h43h34) / h21 + h12;
v2 = h22 - h11 - h33s - h44s;
v3 = h__[m + 2 + (m + 1) * h_dim1];
s = abs(v1) + abs(v2) + abs(v3);
v1 /= s;
v2 /= s;
v3 /= s;
v[0] = v1;
v[1] = v2;
v[2] = v3;
if (m == l) {
goto L50;
}
h00 = h__[m - 1 + (m - 1) * h_dim1];
h10 = h__[m + (m - 1) * h_dim1];
tst1 = abs(v1) * (abs(h00) + abs(h11) + abs(h22));
if (abs(h10) * (abs(v2) + abs(v3)) <= ulp * tst1) {
goto L50;
}
/* L40: */
}
L50:
/* %----------------------% */
/* | Double-shift QR step | */
/* %----------------------% */
i__2 = i__ - 1;
for (k = m; k <= i__2; ++k) {
/* ------------------------------------------------------------ */
/* The first iteration of this loop determines a reflection G */
/* from the vector V and applies it from left and right to H, */
/* thus creating a nonzero bulge below the subdiagonal. */
/* Each subsequent iteration determines a reflection G to */
/* restore the Hessenberg form in the (K-1)th column, and thus */
/* chases the bulge one step toward the bottom of the active */
/* submatrix. NR is the order of G. */
/* ------------------------------------------------------------ */
/* Computing MIN */
i__3 = 3, i__4 = i__ - k + 1;
nr = min(i__3,i__4);
if (k > m) {
dcopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
}
dlarfg_(&nr, v, &v[1], &c__1, &t1);
if (k > m) {
h__[k + (k - 1) * h_dim1] = v[0];
h__[k + 1 + (k - 1) * h_dim1] = 0.;
if (k < i__ - 1) {
h__[k + 2 + (k - 1) * h_dim1] = 0.;
}
} else if (m > l) {
h__[k + (k - 1) * h_dim1] = -h__[k + (k - 1) * h_dim1];
}
v2 = v[1];
t2 = t1 * v2;
if (nr == 3) {
v3 = v[2];
t3 = t1 * v3;
/* %------------------------------------------------% */
/* | Apply G from the left to transform the rows of | */
/* | the matrix in columns K to I2. | */
/* %------------------------------------------------% */
i__3 = i2;
for (j = k; j <= i__3; ++j) {
sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1]
+ v3 * h__[k + 2 + j * h_dim1];
h__[k + j * h_dim1] -= sum * t1;
h__[k + 1 + j * h_dim1] -= sum * t2;
h__[k + 2 + j * h_dim1] -= sum * t3;
/* L60: */
}
/* %----------------------------------------------------% */
/* | Apply G from the right to transform the columns of | */
/* | the matrix in rows I1 to min(K+3,I). | */
/* %----------------------------------------------------% */
/* Computing MIN */
i__4 = k + 3;
i__3 = min(i__4,i__);
for (j = i1; j <= i__3; ++j) {
sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
+ v3 * h__[j + (k + 2) * h_dim1];
h__[j + k * h_dim1] -= sum * t1;
h__[j + (k + 1) * h_dim1] -= sum * t2;
h__[j + (k + 2) * h_dim1] -= sum * t3;
/* L70: */
}
/* %----------------------------------% */
/* | Accumulate transformations for Z | */
/* %----------------------------------% */
sum = z__[k] + v2 * z__[k + 1] + v3 * z__[k + 2];
z__[k] -= sum * t1;
z__[k + 1] -= sum * t2;
z__[k + 2] -= sum * t3;
} else if (nr == 2) {
/* %------------------------------------------------% */
/* | Apply G from the left to transform the rows of | */
/* | the matrix in columns K to I2. | */
/* %------------------------------------------------% */
i__3 = i2;
for (j = k; j <= i__3; ++j) {
sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1];
h__[k + j * h_dim1] -= sum * t1;
h__[k + 1 + j * h_dim1] -= sum * t2;
/* L90: */
}
/* %----------------------------------------------------% */
/* | Apply G from the right to transform the columns of | */
/* | the matrix in rows I1 to min(K+3,I). | */
/* %----------------------------------------------------% */
i__3 = i__;
for (j = i1; j <= i__3; ++j) {
sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
;
h__[j + k * h_dim1] -= sum * t1;
h__[j + (k + 1) * h_dim1] -= sum * t2;
/* L100: */
}
/* %----------------------------------% */
/* | Accumulate transformations for Z | */
/* %----------------------------------% */
sum = z__[k] + v2 * z__[k + 1];
z__[k] -= sum * t1;
z__[k + 1] -= sum * t2;
}
/* L120: */
}
/* L130: */
}
/* %-------------------------------------------------------% */
/* | Failure to converge in remaining number of iterations | */
/* %-------------------------------------------------------% */
*info = i__;
return 0;
L140:
if (l == i__) {
/* %------------------------------------------------------% */
/* | H(I,I-1) is negligible: one eigenvalue has converged | */
/* %------------------------------------------------------% */
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.;
} else if (l == i__ - 1) {
/* %--------------------------------------------------------% */
/* | H(I-1,I-2) is negligible; | */
/* | a pair of eigenvalues have converged. | */
/* | | */
/* | Transform the 2-by-2 submatrix to standard Schur form, | */
/* | and compute and store the eigenvalues. | */
/* %--------------------------------------------------------% */
dlanv2_(&h__[i__ - 1 + (i__ - 1) * h_dim1], &h__[i__ - 1 + i__ *
h_dim1], &h__[i__ + (i__ - 1) * h_dim1], &h__[i__ + i__ *
h_dim1], &wr[i__ - 1], &wi[i__ - 1], &wr[i__], &wi[i__], &cs,
&sn);
if (*wantt) {
/* %-----------------------------------------------------% */
/* | Apply the transformation to the rest of H and to Z, | */
/* | as required. | */
/* %-----------------------------------------------------% */
if (i2 > i__) {
i__1 = i2 - i__;
drot_(&i__1, &h__[i__ - 1 + (i__ + 1) * h_dim1], ldh, &h__[
i__ + (i__ + 1) * h_dim1], ldh, &cs, &sn);
}
i__1 = i__ - i1 - 1;
drot_(&i__1, &h__[i1 + (i__ - 1) * h_dim1], &c__1, &h__[i1 + i__ *
h_dim1], &c__1, &cs, &sn);
sum = cs * z__[i__ - 1] + sn * z__[i__];
z__[i__] = cs * z__[i__] - sn * z__[i__ - 1];
z__[i__ - 1] = sum;
}
}
/* %---------------------------------------------------------% */
/* | Decrement number of remaining iterations, and return to | */
/* | start of the main loop with new value of I. | */
/* %---------------------------------------------------------% */
itn -= its;
i__ = l - 1;
goto L10;
L150:
return 0;
/* %---------------% */
/* | End of dlaqrb | */
/* %---------------% */
} /* dlaqrb_ */
/* Subroutine */ int dgeqpf_(integer *m, integer *n, doublereal *a, integer *
lda, integer *jpvt, doublereal *tau, doublereal *work, integer *info)
{
/* -- LAPACK test routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
DGEQPF computes a QR factorization with column pivoting of a
real M-by-N matrix A: A*P = Q*R.
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/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, the upper triangle of the array contains the
min(M,N)-by-N upper triangular matrix R; the elements
below the diagonal, together with the array TAU,
represent the orthogonal matrix Q as a product of
min(m,n) elementary reflectors.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
JPVT (input/output) INTEGER array, dimension (N)
On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
to the front of A*P (a leading column); if JPVT(i) = 0,
the i-th column of A is a free column.
On exit, if JPVT(i) = k, then the i-th column of A*P
was the k-th column of A.
TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
The scalar factors of the elementary reflectors.
WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
The matrix Q is represented as a product of elementary reflectors
Q = H(1) H(2) . . . H(n)
Each H(i) has the form
H = I - tau * v * v'
where tau is a real scalar, and v is a real vector with
v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).
The matrix P is represented in jpvt as follows: If
jpvt(j) = i
then the jth column of P is the ith canonical unit vector.
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static doublereal temp;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static doublereal temp2;
static integer i, j;
extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *);
static integer itemp;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *), dgeqr2_(integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *),
dorm2r_(char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *);
static integer ma, mn;
extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal aii;
static integer pvt;
#define JPVT(I) jpvt[(I)-1]
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEQPF", &i__1);
return 0;
}
mn = min(*m,*n);
/* Move initial columns up front */
itemp = 1;
i__1 = *n;
for (i = 1; i <= *n; ++i) {
if (JPVT(i) != 0) {
if (i != itemp) {
dswap_(m, &A(1,i), &c__1, &A(1,itemp), &
c__1);
JPVT(i) = JPVT(itemp);
JPVT(itemp) = i;
} else {
JPVT(i) = i;
}
++itemp;
} else {
JPVT(i) = i;
}
/* L10: */
}
--itemp;
/* Compute the QR factorization and update remaining columns */
if (itemp > 0) {
ma = min(itemp,*m);
dgeqr2_(m, &ma, &A(1,1), lda, &TAU(1), &WORK(1), info);
if (ma < *n) {
i__1 = *n - ma;
dorm2r_("Left", "Transpose", m, &i__1, &ma, &A(1,1), lda, &
TAU(1), &A(1,ma+1), lda, &WORK(1), info);
}
}
if (itemp < mn) {
/* Initialize partial column norms. The first n elements of
work store the exact column norms. */
i__1 = *n;
for (i = itemp + 1; i <= *n; ++i) {
i__2 = *m - itemp;
WORK(i) = dnrm2_(&i__2, &A(itemp+1,i), &c__1);
WORK(*n + i) = WORK(i);
/* L20: */
}
/* Compute factorization */
i__1 = mn;
for (i = itemp + 1; i <= mn; ++i) {
/* Determine ith pivot column and swap if necessary */
i__2 = *n - i + 1;
pvt = i - 1 + idamax_(&i__2, &WORK(i), &c__1);
if (pvt != i) {
dswap_(m, &A(1,pvt), &c__1, &A(1,i), &
c__1);
itemp = JPVT(pvt);
JPVT(pvt) = JPVT(i);
JPVT(i) = itemp;
WORK(pvt) = WORK(i);
WORK(*n + pvt) = WORK(*n + i);
}
/* Generate elementary reflector H(i) */
if (i < *m) {
i__2 = *m - i + 1;
dlarfg_(&i__2, &A(i,i), &A(i+1,i), &
c__1, &TAU(i));
} else {
dlarfg_(&c__1, &A(*m,*m), &A(*m,*m), &
c__1, &TAU(*m));
}
if (i < *n) {
/* Apply H(i) to A(i:m,i+1:n) from the left */
aii = A(i,i);
A(i,i) = 1.;
i__2 = *m - i + 1;
i__3 = *n - i;
dlarf_("LEFT", &i__2, &i__3, &A(i,i), &c__1, &TAU(
i), &A(i,i+1), lda, &WORK((*n << 1) +
1));
A(i,i) = aii;
}
/* Update partial column norms */
i__2 = *n;
for (j = i + 1; j <= *n; ++j) {
if (WORK(j) != 0.) {
/* Computing 2nd power */
d__2 = (d__1 = A(i,j), abs(d__1)) / WORK(j);
temp = 1. - d__2 * d__2;
temp = max(temp,0.);
/* Computing 2nd power */
d__1 = WORK(j) / WORK(*n + j);
temp2 = temp * .05 * (d__1 * d__1) + 1.;
if (temp2 == 1.) {
if (*m - i > 0) {
i__3 = *m - i;
WORK(j) = dnrm2_(&i__3, &A(i+1,j), &
c__1);
WORK(*n + j) = WORK(j);
} else {
WORK(j) = 0.;
WORK(*n + j) = 0.;
}
} else {
WORK(j) *= sqrt(temp);
}
}
/* L30: */
}
/* L40: */
}
}
return 0;
/* End of DGEQPF */
} /* dgeqpf_ */
/* Subroutine */ int dlahqr_(logical *wantt, logical *wantz, integer *n,
integer *ilo, integer *ihi, doublereal *h__, integer *ldh, doublereal
*wr, doublereal *wi, integer *iloz, integer *ihiz, doublereal *z__,
integer *ldz, integer *info)
{
/* System generated locals */
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, k, l, m;
doublereal s, v[3];
integer i1, i2;
doublereal t1, t2, t3, v2, v3, aa, ab, ba, bb, h11, h12, h21, h22, cs;
integer nh;
doublereal sn;
integer nr;
doublereal tr;
integer nz;
doublereal det, h21s;
integer its;
doublereal ulp, sum, tst, rt1i, rt2i, rt1r, rt2r;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *), dcopy_(
integer *, doublereal *, integer *, doublereal *, integer *),
dlanv2_(doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *), dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *);
doublereal safmin, safmax, rtdisc, smlnum;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAHQR is an auxiliary routine called by DHSEQR to update the */
/* eigenvalues and Schur decomposition already computed by DHSEQR, by */
/* dealing with the Hessenberg submatrix in rows and columns ILO to */
/* IHI. */
/* Arguments */
/* ========= */
/* WANTT (input) LOGICAL */
/* = .TRUE. : the full Schur form T is required; */
/* = .FALSE.: only eigenvalues are required. */
/* WANTZ (input) LOGICAL */
/* = .TRUE. : the matrix of Schur vectors Z is required; */
/* = .FALSE.: Schur vectors are not required. */
/* N (input) INTEGER */
/* The order of the matrix H. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that H is already upper quasi-triangular in */
/* rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless */
/* ILO = 1). DLAHQR works primarily with the Hessenberg */
/* submatrix in rows and columns ILO to IHI, but applies */
/* transformations to all of H if WANTT is .TRUE.. */
/* 1 <= ILO <= max(1,IHI); IHI <= N. */
/* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if INFO is zero and if WANTT is .TRUE., H is upper */
/* quasi-triangular in rows and columns ILO:IHI, with any */
/* 2-by-2 diagonal blocks in standard form. If INFO is zero */
/* and WANTT is .FALSE., the contents of H are unspecified on */
/* exit. The output state of H if INFO is nonzero is given */
/* below under the description of INFO. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= 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 ILO to IHI are stored in the corresponding */
/* elements of WR and WI. 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) > 0 and WI(i+1) < 0. If WANTT is .TRUE., 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). */
/* ILOZ (input) INTEGER */
/* IHIZ (input) INTEGER */
/* Specify the rows of Z to which transformations must be */
/* applied if WANTZ is .TRUE.. */
/* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */
/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
/* If WANTZ is .TRUE., on entry Z must contain the current */
/* matrix Z of transformations accumulated by DHSEQR, and on */
/* exit Z has been updated; transformations are applied only to */
/* the submatrix Z(ILOZ:IHIZ,ILO:IHI). */
/* If WANTZ is .FALSE., Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* .GT. 0: If INFO = i, DLAHQR failed to compute all the */
/* eigenvalues ILO to IHI in a total of 30 iterations */
/* per eigenvalue; elements i+1:ihi of WR and WI */
/* contain those eigenvalues which have been */
/* successfully computed. */
/* If INFO .GT. 0 and WANTT is .FALSE., then on exit, */
/* the remaining unconverged eigenvalues are the */
/* eigenvalues of the upper Hessenberg matrix rows */
/* and columns ILO thorugh INFO of the final, output */
/* value of H. */
/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */
/* (*) (initial value of H)*U = U*(final value of H) */
/* where U is an orthognal matrix. The final */
/* value of H is upper Hessenberg and triangular in */
/* rows and columns INFO+1 through IHI. */
/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
/* (final value of Z) = (initial value of Z)*U */
/* where U is the orthogonal matrix in (*) */
/* (regardless of the value of WANTT.) */
/* Further Details */
/* =============== */
/* 02-96 Based on modifications by */
/* David Day, Sandia National Laboratory, USA */
/* 12-04 Further modifications by */
/* Ralph Byers, University of Kansas, USA */
/* This is a modified version of DLAHQR from LAPACK version 3.0. */
/* It is (1) more robust against overflow and underflow and */
/* (2) adopts the more conservative Ahues & Tisseur stopping */
/* criterion (LAWN 122, 1997). */
/* ========================================================= */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* 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;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
wr[*ilo] = h__[*ilo + *ilo * h_dim1];
wi[*ilo] = 0.;
return 0;
}
/* ==== clear out the trash ==== */
i__1 = *ihi - 3;
for (j = *ilo; j <= i__1; ++j) {
h__[j + 2 + j * h_dim1] = 0.;
h__[j + 3 + j * h_dim1] = 0.;
/* L10: */
}
if (*ilo <= *ihi - 2) {
h__[*ihi + (*ihi - 2) * h_dim1] = 0.;
}
nh = *ihi - *ilo + 1;
nz = *ihiz - *iloz + 1;
/* Set machine-dependent constants for the stopping criterion. */
safmin = dlamch_("SAFE MINIMUM");
safmax = 1. / safmin;
dlabad_(&safmin, &safmax);
ulp = dlamch_("PRECISION");
smlnum = safmin * ((doublereal) nh / ulp);
/* I1 and I2 are the indices of the first row and last column of H */
/* to which transformations must be applied. If eigenvalues only are */
/* being computed, I1 and I2 are set inside the main loop. */
if (*wantt) {
i1 = 1;
i2 = *n;
}
/* The main loop begins here. I is the loop index and decreases from */
/* IHI to ILO in steps of 1 or 2. Each iteration of the loop works */
/* with the active submatrix in rows and columns L to I. */
/* Eigenvalues I+1 to IHI have already converged. Either L = ILO or */
/* H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L20:
l = *ilo;
if (i__ < *ilo) {
goto L160;
}
/* Perform QR iterations on rows and columns ILO to I until a */
/* submatrix of order 1 or 2 splits off at the bottom because a */
/* subdiagonal element has become negligible. */
for (its = 0; its <= 30; ++its) {
/* Look for a single small subdiagonal element. */
i__1 = l + 1;
for (k = i__; k >= i__1; --k) {
if ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= smlnum) {
goto L40;
}
tst = (d__1 = h__[k - 1 + (k - 1) * h_dim1], abs(d__1)) + (d__2 =
h__[k + k * h_dim1], abs(d__2));
if (tst == 0.) {
if (k - 2 >= *ilo) {
tst += (d__1 = h__[k - 1 + (k - 2) * h_dim1], abs(d__1));
}
if (k + 1 <= *ihi) {
tst += (d__1 = h__[k + 1 + k * h_dim1], abs(d__1));
}
}
/* ==== The following is a conservative small subdiagonal */
/* . deflation criterion due to Ahues & Tisseur (LAWN 122, */
/* . 1997). It has better mathematical foundation and */
/* . improves accuracy in some cases. ==== */
if ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= ulp * tst) {
/* Computing MAX */
d__3 = (d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)), d__4 = (
d__2 = h__[k - 1 + k * h_dim1], abs(d__2));
ab = max(d__3,d__4);
/* Computing MIN */
d__3 = (d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)), d__4 = (
d__2 = h__[k - 1 + k * h_dim1], abs(d__2));
ba = min(d__3,d__4);
/* Computing MAX */
d__3 = (d__1 = h__[k + k * h_dim1], abs(d__1)), d__4 = (d__2 =
h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1],
abs(d__2));
aa = max(d__3,d__4);
/* Computing MIN */
d__3 = (d__1 = h__[k + k * h_dim1], abs(d__1)), d__4 = (d__2 =
h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1],
abs(d__2));
bb = min(d__3,d__4);
s = aa + ab;
/* Computing MAX */
d__1 = smlnum, d__2 = ulp * (bb * (aa / s));
if (ba * (ab / s) <= max(d__1,d__2)) {
goto L40;
}
}
/* L30: */
}
L40:
l = k;
if (l > *ilo) {
/* H(L,L-1) is negligible */
h__[l + (l - 1) * h_dim1] = 0.;
}
/* Exit from loop if a submatrix of order 1 or 2 has split off. */
if (l >= i__ - 1) {
goto L150;
}
/* Now the active submatrix is in rows and columns L to I. If */
/* eigenvalues only are being computed, only the active submatrix */
/* need be transformed. */
if (! (*wantt)) {
i1 = l;
i2 = i__;
}
if (its == 10 || its == 20) {
/* Exceptional shift. */
h11 = s * .75 + h__[i__ + i__ * h_dim1];
h12 = s * -.4375;
h21 = s;
h22 = h11;
} else {
/* Prepare to use Francis' double shift */
/* (i.e. 2nd degree generalized Rayleigh quotient) */
h11 = h__[i__ - 1 + (i__ - 1) * h_dim1];
h21 = h__[i__ + (i__ - 1) * h_dim1];
h12 = h__[i__ - 1 + i__ * h_dim1];
h22 = h__[i__ + i__ * h_dim1];
}
s = abs(h11) + abs(h12) + abs(h21) + abs(h22);
if (s == 0.) {
rt1r = 0.;
rt1i = 0.;
rt2r = 0.;
rt2i = 0.;
} else {
h11 /= s;
h21 /= s;
h12 /= s;
h22 /= s;
tr = (h11 + h22) / 2.;
det = (h11 - tr) * (h22 - tr) - h12 * h21;
rtdisc = sqrt((abs(det)));
if (det >= 0.) {
/* ==== complex conjugate shifts ==== */
rt1r = tr * s;
rt2r = rt1r;
rt1i = rtdisc * s;
rt2i = -rt1i;
} else {
/* ==== real shifts (use only one of them) ==== */
rt1r = tr + rtdisc;
rt2r = tr - rtdisc;
if ((d__1 = rt1r - h22, abs(d__1)) <= (d__2 = rt2r - h22, abs(
d__2))) {
rt1r *= s;
rt2r = rt1r;
} else {
rt2r *= s;
rt1r = rt2r;
}
rt1i = 0.;
rt2i = 0.;
}
}
/* Look for two consecutive small subdiagonal elements. */
i__1 = l;
for (m = i__ - 2; m >= i__1; --m) {
/* Determine the effect of starting the double-shift QR */
/* iteration at row M, and see if this would make H(M,M-1) */
/* negligible. (The following uses scaling to avoid */
/* overflows and most underflows.) */
h21s = h__[m + 1 + m * h_dim1];
s = (d__1 = h__[m + m * h_dim1] - rt2r, abs(d__1)) + abs(rt2i) +
abs(h21s);
h21s = h__[m + 1 + m * h_dim1] / s;
v[0] = h21s * h__[m + (m + 1) * h_dim1] + (h__[m + m * h_dim1] -
rt1r) * ((h__[m + m * h_dim1] - rt2r) / s) - rt1i * (rt2i
/ s);
v[1] = h21s * (h__[m + m * h_dim1] + h__[m + 1 + (m + 1) * h_dim1]
- rt1r - rt2r);
v[2] = h21s * h__[m + 2 + (m + 1) * h_dim1];
s = abs(v[0]) + abs(v[1]) + abs(v[2]);
v[0] /= s;
v[1] /= s;
v[2] /= s;
if (m == l) {
goto L60;
}
if ((d__1 = h__[m + (m - 1) * h_dim1], abs(d__1)) * (abs(v[1]) +
abs(v[2])) <= ulp * abs(v[0]) * ((d__2 = h__[m - 1 + (m -
1) * h_dim1], abs(d__2)) + (d__3 = h__[m + m * h_dim1],
abs(d__3)) + (d__4 = h__[m + 1 + (m + 1) * h_dim1], abs(
d__4)))) {
goto L60;
}
/* L50: */
}
L60:
/* Double-shift QR step */
i__1 = i__ - 1;
for (k = m; k <= i__1; ++k) {
/* The first iteration of this loop determines a reflection G */
/* from the vector V and applies it from left and right to H, */
/* thus creating a nonzero bulge below the subdiagonal. */
/* Each subsequent iteration determines a reflection G to */
/* restore the Hessenberg form in the (K-1)th column, and thus */
/* chases the bulge one step toward the bottom of the active */
/* submatrix. NR is the order of G. */
/* Computing MIN */
i__2 = 3, i__3 = i__ - k + 1;
nr = min(i__2,i__3);
if (k > m) {
dcopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
}
dlarfg_(&nr, v, &v[1], &c__1, &t1);
if (k > m) {
h__[k + (k - 1) * h_dim1] = v[0];
h__[k + 1 + (k - 1) * h_dim1] = 0.;
if (k < i__ - 1) {
h__[k + 2 + (k - 1) * h_dim1] = 0.;
}
} else if (m > l) {
h__[k + (k - 1) * h_dim1] = -h__[k + (k - 1) * h_dim1];
}
v2 = v[1];
t2 = t1 * v2;
if (nr == 3) {
v3 = v[2];
t3 = t1 * v3;
/* Apply G from the left to transform the rows of the matrix */
/* in columns K to I2. */
i__2 = i2;
for (j = k; j <= i__2; ++j) {
sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1]
+ v3 * h__[k + 2 + j * h_dim1];
h__[k + j * h_dim1] -= sum * t1;
h__[k + 1 + j * h_dim1] -= sum * t2;
h__[k + 2 + j * h_dim1] -= sum * t3;
/* L70: */
}
/* Apply G from the right to transform the columns of the */
/* matrix in rows I1 to min(K+3,I). */
/* Computing MIN */
i__3 = k + 3;
i__2 = min(i__3,i__);
for (j = i1; j <= i__2; ++j) {
sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
+ v3 * h__[j + (k + 2) * h_dim1];
h__[j + k * h_dim1] -= sum * t1;
h__[j + (k + 1) * h_dim1] -= sum * t2;
h__[j + (k + 2) * h_dim1] -= sum * t3;
/* L80: */
}
if (*wantz) {
/* Accumulate transformations in the matrix Z */
i__2 = *ihiz;
for (j = *iloz; j <= i__2; ++j) {
sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) *
z_dim1] + v3 * z__[j + (k + 2) * z_dim1];
z__[j + k * z_dim1] -= sum * t1;
z__[j + (k + 1) * z_dim1] -= sum * t2;
z__[j + (k + 2) * z_dim1] -= sum * t3;
/* L90: */
}
}
} else if (nr == 2) {
/* Apply G from the left to transform the rows of the matrix */
/* in columns K to I2. */
i__2 = i2;
for (j = k; j <= i__2; ++j) {
sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1];
h__[k + j * h_dim1] -= sum * t1;
h__[k + 1 + j * h_dim1] -= sum * t2;
/* L100: */
}
/* Apply G from the right to transform the columns of the */
/* matrix in rows I1 to min(K+3,I). */
i__2 = i__;
for (j = i1; j <= i__2; ++j) {
sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
;
h__[j + k * h_dim1] -= sum * t1;
h__[j + (k + 1) * h_dim1] -= sum * t2;
/* L110: */
}
if (*wantz) {
/* Accumulate transformations in the matrix Z */
i__2 = *ihiz;
for (j = *iloz; j <= i__2; ++j) {
sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) *
z_dim1];
z__[j + k * z_dim1] -= sum * t1;
z__[j + (k + 1) * z_dim1] -= sum * t2;
/* L120: */
}
}
}
/* L130: */
}
/* L140: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L150:
if (l == i__) {
/* H(I,I-1) is negligible: one eigenvalue has converged. */
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.;
} else if (l == i__ - 1) {
/* H(I-1,I-2) is negligible: a pair of eigenvalues have converged. */
/* Transform the 2-by-2 submatrix to standard Schur form, */
/* and compute and store the eigenvalues. */
dlanv2_(&h__[i__ - 1 + (i__ - 1) * h_dim1], &h__[i__ - 1 + i__ *
h_dim1], &h__[i__ + (i__ - 1) * h_dim1], &h__[i__ + i__ *
h_dim1], &wr[i__ - 1], &wi[i__ - 1], &wr[i__], &wi[i__], &cs,
&sn);
if (*wantt) {
/* Apply the transformation to the rest of H. */
if (i2 > i__) {
i__1 = i2 - i__;
drot_(&i__1, &h__[i__ - 1 + (i__ + 1) * h_dim1], ldh, &h__[
i__ + (i__ + 1) * h_dim1], ldh, &cs, &sn);
}
i__1 = i__ - i1 - 1;
drot_(&i__1, &h__[i1 + (i__ - 1) * h_dim1], &c__1, &h__[i1 + i__ *
h_dim1], &c__1, &cs, &sn);
}
if (*wantz) {
/* Apply the transformation to Z. */
drot_(&nz, &z__[*iloz + (i__ - 1) * z_dim1], &c__1, &z__[*iloz +
i__ * z_dim1], &c__1, &cs, &sn);
}
}
/* return to start of the main loop with new value of I. */
i__ = l - 1;
goto L20;
L160:
return 0;
/* End of DLAHQR */
} /* dlahqr_ */
/* Subroutine */ int dlahrd_(integer *n, integer *k, integer *nb, doublereal *
a, integer *lda, doublereal *tau, doublereal *t, integer *ldt,
doublereal *y, integer *ldy)
{
/* System generated locals */
integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
i__3;
doublereal d__1;
/* Local variables */
static integer i__;
static doublereal ei;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dgemv_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, ftnlen), dcopy_(integer *, doublereal *,
integer *, doublereal *, integer *), daxpy_(integer *, doublereal
*, doublereal *, integer *, doublereal *, integer *), dtrmv_(char
*, char *, char *, integer *, doublereal *, integer *, doublereal
*, integer *, ftnlen, ftnlen, ftnlen), dlarfg_(integer *,
doublereal *, doublereal *, integer *, doublereal *);
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAHRD reduces the first NB columns of a real general n-by-(n-k+1) */
/* matrix A so that elements below the k-th subdiagonal are zero. The */
/* reduction is performed by an orthogonal similarity transformation */
/* Q' * A * Q. The routine returns the matrices V and T which determine */
/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */
/* This is an auxiliary routine called by DGEHRD. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* K (input) INTEGER */
/* The offset for the reduction. Elements below the k-th */
/* subdiagonal in the first NB columns are reduced to zero. */
/* NB (input) INTEGER */
/* The number of columns to be reduced. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1) */
/* On entry, the n-by-(n-k+1) general matrix A. */
/* On exit, the elements on and above the k-th subdiagonal in */
/* the first NB columns are overwritten with the corresponding */
/* elements of the reduced matrix; the elements below the k-th */
/* subdiagonal, with the array TAU, represent the matrix Q as a */
/* product of elementary reflectors. The other columns of A are */
/* unchanged. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* TAU (output) DOUBLE PRECISION array, dimension (NB) */
/* The scalar factors of the elementary reflectors. See Further */
/* Details. */
/* T (output) DOUBLE PRECISION array, dimension (LDT,NB) */
/* The upper triangular matrix T. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= NB. */
/* Y (output) DOUBLE PRECISION array, dimension (LDY,NB) */
/* The n-by-nb matrix Y. */
/* LDY (input) INTEGER */
/* The leading dimension of the array Y. LDY >= N. */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of nb elementary reflectors */
/* Q = H(1) H(2) . . . H(nb). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
/* A(i+k+1:n,i), and tau in TAU(i). */
/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */
/* V which is needed, with T and Y, to apply the transformation to the */
/* unreduced part of the matrix, using an update of the form: */
/* A := (I - V*T*V') * (A - Y*V'). */
/* The contents of A on exit are illustrated by the following example */
/* with n = 7, k = 3 and nb = 2: */
/* ( a h a a a ) */
/* ( a h a a a ) */
/* ( a h a a a ) */
/* ( h h a a a ) */
/* ( v1 h a a a ) */
/* ( v1 v2 a a a ) */
/* ( v1 v2 a a a ) */
/* where a denotes an element of the original matrix A, h denotes a */
/* modified element of the upper Hessenberg matrix H, and vi denotes an */
/* element of the vector defining H(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
--tau;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
/* Function Body */
if (*n <= 1) {
return 0;
}
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ > 1) {
/* Update A(1:n,i) */
/* Compute i-th column of A - Y * V' */
i__2 = i__ - 1;
dgemv_("No transpose", n, &i__2, &c_b4, &y[y_offset], ldy, &a[*k
+ i__ - 1 + a_dim1], lda, &c_b5, &a[i__ * a_dim1 + 1], &
c__1, (ftnlen)12);
/* Apply I - V * T' * V' to this column (call it b) from the */
/* left, using the last column of T as workspace */
/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */
/* ( V2 ) ( b2 ) */
/* where V1 is unit lower triangular */
/* w := V1' * b1 */
i__2 = i__ - 1;
dcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 +
1], &c__1);
i__2 = i__ - 1;
dtrmv_("Lower", "Transpose", "Unit", &i__2, &a[*k + 1 + a_dim1],
lda, &t[*nb * t_dim1 + 1], &c__1, (ftnlen)5, (ftnlen)9, (
ftnlen)4);
/* w := w + V2'*b2 */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1],
lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b5, &t[*nb *
t_dim1 + 1], &c__1, (ftnlen)9);
/* w := T'*w */
i__2 = i__ - 1;
dtrmv_("Upper", "Transpose", "Non-unit", &i__2, &t[t_offset], ldt,
&t[*nb * t_dim1 + 1], &c__1, (ftnlen)5, (ftnlen)9, (
ftnlen)8);
/* b2 := b2 - V2*w */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[*k + i__ + a_dim1],
lda, &t[*nb * t_dim1 + 1], &c__1, &c_b5, &a[*k + i__ +
i__ * a_dim1], &c__1, (ftnlen)12);
/* b1 := b1 - V1*w */
i__2 = i__ - 1;
dtrmv_("Lower", "No transpose", "Unit", &i__2, &a[*k + 1 + a_dim1]
, lda, &t[*nb * t_dim1 + 1], &c__1, (ftnlen)5, (ftnlen)12,
(ftnlen)4);
i__2 = i__ - 1;
daxpy_(&i__2, &c_b4, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__
* a_dim1], &c__1);
a[*k + i__ - 1 + (i__ - 1) * a_dim1] = ei;
}
/* Generate the elementary reflector H(i) to annihilate */
/* A(k+i+1:n,i) */
i__2 = *n - *k - i__ + 1;
/* Computing MIN */
i__3 = *k + i__ + 1;
dlarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[min(i__3,*n) + i__ *
a_dim1], &c__1, &tau[i__]);
ei = a[*k + i__ + i__ * a_dim1];
a[*k + i__ + i__ * a_dim1] = 1.;
/* Compute Y(1:n,i) */
i__2 = *n - *k - i__ + 1;
dgemv_("No transpose", n, &i__2, &c_b5, &a[(i__ + 1) * a_dim1 + 1],
lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &y[i__ *
y_dim1 + 1], &c__1, (ftnlen)12);
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], lda, &
a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &t[i__ * t_dim1 +
1], &c__1, (ftnlen)9);
i__2 = i__ - 1;
dgemv_("No transpose", n, &i__2, &c_b4, &y[y_offset], ldy, &t[i__ *
t_dim1 + 1], &c__1, &c_b5, &y[i__ * y_dim1 + 1], &c__1, (
ftnlen)12);
dscal_(n, &tau[i__], &y[i__ * y_dim1 + 1], &c__1);
/* Compute T(1:i,i) */
i__2 = i__ - 1;
d__1 = -tau[i__];
dscal_(&i__2, &d__1, &t[i__ * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt,
&t[i__ * t_dim1 + 1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen)8)
;
t[i__ + i__ * t_dim1] = tau[i__];
/* L10: */
}
a[*k + *nb + *nb * a_dim1] = ei;
return 0;
/* End of DLAHRD */
} /* dlahrd_ */
/* Subroutine */ int dsytd2_(char *uplo, integer *n, doublereal *a, integer *
lda, doublereal *d__, doublereal *e, doublereal *tau, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal
form T by an orthogonal similarity transformation: Q' * A * Q = T.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
symmetric matrix A is stored:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the symmetric matrix A. If UPLO = 'U', the leading
n-by-n upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading n-by-n lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit, if UPLO = 'U', the diagonal and first superdiagonal
of A are overwritten by the corresponding elements of the
tridiagonal matrix T, and the elements above the first
superdiagonal, with the array TAU, represent the orthogonal
matrix Q as a product of elementary reflectors; if UPLO
= 'L', the diagonal and first subdiagonal of A are over-
written by the corresponding elements of the tridiagonal
matrix T, and the elements below the first subdiagonal, with
the array TAU, represent the orthogonal matrix Q as a product
of elementary reflectors. See Further Details.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
D (output) DOUBLE PRECISION array, dimension (N)
The diagonal elements of the tridiagonal matrix T:
D(i) = A(i,i).
E (output) DOUBLE PRECISION array, dimension (N-1)
The off-diagonal elements of the tridiagonal matrix T:
E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
TAU (output) DOUBLE PRECISION array, dimension (N-1)
The scalar factors of the elementary reflectors (see Further
Details).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
Further Details
===============
If UPLO = 'U', the matrix Q is represented as a product of elementary
reflectors
Q = H(n-1) . . . H(2) H(1).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a real scalar, and v is a real vector with
v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
A(1:i-1,i+1), and tau in TAU(i).
If UPLO = 'L', the matrix Q is represented as a product of elementary
reflectors
Q = H(1) H(2) . . . H(n-1).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a real scalar, and v is a real vector with
v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
and tau in TAU(i).
The contents of A on exit are illustrated by the following examples
with n = 5:
if UPLO = 'U': if UPLO = 'L':
( d e v2 v3 v4 ) ( d )
( d e v3 v4 ) ( e d )
( d e v4 ) ( v1 e d )
( d e ) ( v1 v2 e d )
( d ) ( v1 v2 v3 e d )
where d and e denote diagonal and off-diagonal elements of T, and vi
denotes an element of the vector defining H(i).
=====================================================================
Test the input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b8 = 0.;
static doublereal c_b14 = -1.;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal taui;
extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer i__;
static doublereal alpha;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static logical upper;
extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *), dlarfg_(integer *, doublereal *,
doublereal *, integer *, doublereal *), xerbla_(char *, integer *
);
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--d__;
--e;
--tau;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYTD2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
if (upper) {
/* Reduce the upper triangle of A */
for (i__ = *n - 1; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) = I - tau * v * v'
to annihilate A(1:i-1,i+1) */
dlarfg_(&i__, &a_ref(i__, i__ + 1), &a_ref(1, i__ + 1), &c__1, &
taui);
e[i__] = a_ref(i__, i__ + 1);
if (taui != 0.) {
/* Apply H(i) from both sides to A(1:i,1:i) */
a_ref(i__, i__ + 1) = 1.;
/* Compute x := tau * A * v storing x in TAU(1:i) */
dsymv_(uplo, &i__, &taui, &a[a_offset], lda, &a_ref(1, i__ +
1), &c__1, &c_b8, &tau[1], &c__1);
/* Compute w := x - 1/2 * tau * (x'*v) * v */
alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &a_ref(1,
i__ + 1), &c__1);
daxpy_(&i__, &alpha, &a_ref(1, i__ + 1), &c__1, &tau[1], &
c__1);
/* Apply the transformation as a rank-2 update:
A := A - v * w' - w * v' */
dsyr2_(uplo, &i__, &c_b14, &a_ref(1, i__ + 1), &c__1, &tau[1],
&c__1, &a[a_offset], lda);
a_ref(i__, i__ + 1) = e[i__];
}
d__[i__ + 1] = a_ref(i__ + 1, i__ + 1);
tau[i__] = taui;
/* L10: */
}
d__[1] = a_ref(1, 1);
} else {
/* Reduce the lower triangle of A */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) = I - tau * v * v'
to annihilate A(i+2:n,i)
Computing MIN */
i__2 = i__ + 2;
i__3 = *n - i__;
dlarfg_(&i__3, &a_ref(i__ + 1, i__), &a_ref(min(i__2,*n), i__), &
c__1, &taui);
e[i__] = a_ref(i__ + 1, i__);
if (taui != 0.) {
/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
a_ref(i__ + 1, i__) = 1.;
/* Compute x := tau * A * v storing y in TAU(i:n-1) */
i__2 = *n - i__;
dsymv_(uplo, &i__2, &taui, &a_ref(i__ + 1, i__ + 1), lda, &
a_ref(i__ + 1, i__), &c__1, &c_b8, &tau[i__], &c__1);
/* Compute w := x - 1/2 * tau * (x'*v) * v */
i__2 = *n - i__;
alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &a_ref(
i__ + 1, i__), &c__1);
i__2 = *n - i__;
daxpy_(&i__2, &alpha, &a_ref(i__ + 1, i__), &c__1, &tau[i__],
&c__1);
/* Apply the transformation as a rank-2 update:
A := A - v * w' - w * v' */
i__2 = *n - i__;
dsyr2_(uplo, &i__2, &c_b14, &a_ref(i__ + 1, i__), &c__1, &tau[
i__], &c__1, &a_ref(i__ + 1, i__ + 1), lda)
;
a_ref(i__ + 1, i__) = e[i__];
}
d__[i__] = a_ref(i__, i__);
tau[i__] = taui;
/* L20: */
}
d__[*n] = a_ref(*n, *n);
}
return 0;
/* End of DSYTD2 */
} /* dsytd2_ */
/* Subroutine */ int dlatrz_(integer *m, integer *n, integer *l, doublereal *
a, integer *lda, doublereal *tau, doublereal *work)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
integer i__;
extern /* Subroutine */ int dlarz_(char *, integer *, integer *, integer *
, doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *), dlarfg_(integer *, doublereal *,
doublereal *, integer *, doublereal *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLATRZ factors the M-by-(M+L) real upper trapezoidal matrix */
/* [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z, by means */
/* of orthogonal transformations. Z is an (M+L)-by-(M+L) orthogonal */
/* matrix and, R and A1 are M-by-M upper triangular matrices. */
/* 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. */
/* L (input) INTEGER */
/* The number of columns of the matrix A containing the */
/* meaningful part of the Householder vectors. N-M >= L >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the leading M-by-N upper trapezoidal part of the */
/* array A must contain the matrix to be factorized. */
/* On exit, the leading M-by-M upper triangular part of A */
/* contains the upper triangular matrix R, and elements N-L+1 to */
/* N of the first M rows of A, with the array TAU, represent the */
/* orthogonal matrix Z as a product of M elementary reflectors. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) DOUBLE PRECISION array, dimension (M) */
/* The scalar factors of the elementary reflectors. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (M) */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
/* The factorization is obtained by Householder's method. The kth */
/* transformation matrix, Z( k ), which is used to introduce zeros into */
/* the ( m - k + 1 )th row of A, is given in the form */
/* Z( k ) = ( I 0 ), */
/* ( 0 T( k ) ) */
/* where */
/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */
/* ( 0 ) */
/* ( z( k ) ) */
/* tau is a scalar and z( k ) is an l element vector. tau and z( k ) */
/* are chosen to annihilate the elements of the kth row of A2. */
/* The scalar tau is returned in the kth element of TAU and the vector */
/* u( k ) in the kth row of A2, such that the elements of z( k ) are */
/* in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in */
/* the upper triangular part of A1. */
/* Z is given by */
/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Quick return if possible */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
if (*m == 0) {
return 0;
} else if (*m == *n) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
tau[i__] = 0.;
/* L10: */
}
return 0;
}
for (i__ = *m; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) to annihilate */
/* [ A(i,i) A(i,n-l+1:n) ] */
i__1 = *l + 1;
dlarfg_(&i__1, &a[i__ + i__ * a_dim1], &a[i__ + (*n - *l + 1) *
a_dim1], lda, &tau[i__]);
/* Apply H(i) to A(1:i-1,i:n) from the right */
i__1 = i__ - 1;
i__2 = *n - i__ + 1;
dlarz_("Right", &i__1, &i__2, l, &a[i__ + (*n - *l + 1) * a_dim1],
lda, &tau[i__], &a[i__ * a_dim1 + 1], lda, &work[1]);
/* L20: */
}
return 0;
/* End of DLATRZ */
} /* dlatrz_ */
/* 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_ */
/* Subroutine */ HYPRE_Int dgeqr2_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *tau, doublereal *work, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DGEQR2 computes a QR factorization of a real m by n matrix A:
A = Q * R.
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/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the m by n matrix A.
On exit, the elements on and above the diagonal of the array
contain the min(m,n) by n upper trapezoidal matrix R (R is
upper triangular if m >= n); the elements below the diagonal,
with the array TAU, represent the orthogonal matrix Q as a
product of elementary reflectors (see Further Details).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
The scalar factors of the elementary reflectors (see Further
Details).
WORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
The matrix Q is represented as a product of elementary reflectors
Q = H(1) H(2) . . . H(k), where k = min(m,n).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a real scalar, and v is a real vector with
v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
and tau in TAU(i).
=====================================================================
Test the input arguments
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
static integer i__, k;
extern /* Subroutine */ HYPRE_Int dlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *), dlarfg_(integer *, doublereal *,
doublereal *, integer *, doublereal *), xerbla_(char *, integer *);
static doublereal aii;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEQR2", &i__1);
return 0;
}
k = min(*m,*n);
i__1 = k;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) to annihilate A(i+1:m,i)
Computing MIN */
i__2 = i__ + 1;
i__3 = *m - i__ + 1;
dlarfg_(&i__3, &a_ref(i__, i__), &a_ref(min(i__2,*m), i__), &c__1, &
tau[i__]);
if (i__ < *n) {
/* Apply H(i) to A(i:m,i+1:n) from the left */
aii = a_ref(i__, i__);
a_ref(i__, i__) = 1.;
i__2 = *m - i__ + 1;
i__3 = *n - i__;
dlarf_("Left", &i__2, &i__3, &a_ref(i__, i__), &c__1, &tau[i__], &
a_ref(i__, i__ + 1), lda, &work[1]);
a_ref(i__, i__) = aii;
}
/* L10: */
}
return 0;
/* End of DGEQR2 */
} /* dgeqr2_ */
/* Subroutine */ int dlaexc_(logical *wantq, integer *n, doublereal *t,
integer *ldt, doublereal *q, integer *ldq, integer *j1, integer *n1,
integer *n2, doublereal *work, integer *info)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in
an upper quasi-triangular matrix T by an orthogonal similarity
transformation.
T must be in Schur canonical form, that is, block upper triangular
with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block
has its diagonal elemnts equal and its off-diagonal elements of
opposite sign.
Arguments
=========
WANTQ (input) LOGICAL
= .TRUE. : accumulate the transformation in the matrix Q;
= .FALSE.: do not accumulate the transformation.
N (input) INTEGER
The order of the matrix T. N >= 0.
T (input/output) DOUBLE PRECISION array, dimension (LDT,N)
On entry, the upper quasi-triangular matrix T, in Schur
canonical form.
On exit, the updated matrix T, again in Schur canonical form.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= max(1,N).
Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
On entry, if WANTQ is .TRUE., the orthogonal matrix Q.
On exit, if WANTQ is .TRUE., the updated matrix Q.
If WANTQ is .FALSE., Q is not referenced.
LDQ (input) INTEGER
The leading dimension of the array Q.
LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N.
J1 (input) INTEGER
The index of the first row of the first block T11.
N1 (input) INTEGER
The order of the first block T11. N1 = 0, 1 or 2.
N2 (input) INTEGER
The order of the second block T22. N2 = 0, 1 or 2.
WORK (workspace) DOUBLE PRECISION array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
= 1: the transformed matrix T would be too far from Schur
form; the blocks are not swapped and T and Q are
unchanged.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c__4 = 4;
static logical c_false = FALSE_;
static integer c_n1 = -1;
static integer c__2 = 2;
static integer c__3 = 3;
/* System generated locals */
integer q_dim1, q_offset, t_dim1, t_offset, i__1;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
/* Local variables */
static integer ierr;
static doublereal temp;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
static doublereal d__[16] /* was [4][4] */;
static integer k;
static doublereal u[3], scale, x[4] /* was [2][2] */, dnorm;
static integer j2, j3, j4;
static doublereal xnorm, u1[3], u2[3];
extern /* Subroutine */ int dlanv2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), dlasy2_(
logical *, logical *, integer *, integer *, integer *, doublereal
*, integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *);
static integer nd;
static doublereal cs, t11, t22;
extern doublereal dlamch_(char *);
static doublereal t33;
extern doublereal dlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *);
static doublereal sn;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), dlarfx_(char *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *);
static doublereal thresh, smlnum, wi1, wi2, wr1, wr2, eps, tau, tau1,
tau2;
#define d___ref(a_1,a_2) d__[(a_2)*4 + a_1 - 5]
#define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
#define t_ref(a_1,a_2) t[(a_2)*t_dim1 + a_1]
#define x_ref(a_1,a_2) x[(a_2)*2 + a_1 - 3]
t_dim1 = *ldt;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
--work;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0 || *n1 == 0 || *n2 == 0) {
return 0;
}
if (*j1 + *n1 > *n) {
return 0;
}
j2 = *j1 + 1;
j3 = *j1 + 2;
j4 = *j1 + 3;
if (*n1 == 1 && *n2 == 1) {
/* Swap two 1-by-1 blocks. */
t11 = t_ref(*j1, *j1);
t22 = t_ref(j2, j2);
/* Determine the transformation to perform the interchange. */
d__1 = t22 - t11;
dlartg_(&t_ref(*j1, j2), &d__1, &cs, &sn, &temp);
/* Apply transformation to the matrix T. */
if (j3 <= *n) {
i__1 = *n - *j1 - 1;
drot_(&i__1, &t_ref(*j1, j3), ldt, &t_ref(j2, j3), ldt, &cs, &sn);
}
i__1 = *j1 - 1;
drot_(&i__1, &t_ref(1, *j1), &c__1, &t_ref(1, j2), &c__1, &cs, &sn);
t_ref(*j1, *j1) = t22;
t_ref(j2, j2) = t11;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
drot_(n, &q_ref(1, *j1), &c__1, &q_ref(1, j2), &c__1, &cs, &sn);
}
} else {
/* Swapping involves at least one 2-by-2 block.
Copy the diagonal block of order N1+N2 to the local array D
and compute its norm. */
nd = *n1 + *n2;
dlacpy_("Full", &nd, &nd, &t_ref(*j1, *j1), ldt, d__, &c__4);
dnorm = dlange_("Max", &nd, &nd, d__, &c__4, &work[1]);
/* Compute machine-dependent threshold for test for accepting
swap. */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
/* Computing MAX */
d__1 = eps * 10. * dnorm;
thresh = max(d__1,smlnum);
/* Solve T11*X - X*T22 = scale*T12 for X. */
dlasy2_(&c_false, &c_false, &c_n1, n1, n2, d__, &c__4, &d___ref(*n1 +
1, *n1 + 1), &c__4, &d___ref(1, *n1 + 1), &c__4, &scale, x, &
c__2, &xnorm, &ierr);
/* Swap the adjacent diagonal blocks. */
k = *n1 + *n1 + *n2 - 3;
switch (k) {
case 1: goto L10;
case 2: goto L20;
case 3: goto L30;
}
L10:
/* N1 = 1, N2 = 2: generate elementary reflector H so that:
( scale, X11, X12 ) H = ( 0, 0, * ) */
u[0] = scale;
u[1] = x_ref(1, 1);
u[2] = x_ref(1, 2);
dlarfg_(&c__3, &u[2], u, &c__1, &tau);
u[2] = 1.;
t11 = t_ref(*j1, *j1);
/* Perform swap provisionally on diagonal block in D. */
dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
/* Test whether to reject swap.
Computing MAX */
d__4 = (d__1 = d___ref(3, 1), abs(d__1)), d__5 = (d__2 = d___ref(3, 2)
, abs(d__2)), d__4 = max(d__4,d__5), d__5 = (d__3 = d___ref(3,
3) - t11, abs(d__3));
if (max(d__4,d__5) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
i__1 = *n - *j1 + 1;
dlarfx_("L", &c__3, &i__1, u, &tau, &t_ref(*j1, *j1), ldt, &work[1]);
dlarfx_("R", &j2, &c__3, u, &tau, &t_ref(1, *j1), ldt, &work[1]);
t_ref(j3, *j1) = 0.;
t_ref(j3, j2) = 0.;
t_ref(j3, j3) = t11;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
dlarfx_("R", n, &c__3, u, &tau, &q_ref(1, *j1), ldq, &work[1]);
}
goto L40;
L20:
/* N1 = 2, N2 = 1: generate elementary reflector H so that:
H ( -X11 ) = ( * )
( -X21 ) = ( 0 )
( scale ) = ( 0 ) */
u[0] = -x_ref(1, 1);
u[1] = -x_ref(2, 1);
u[2] = scale;
dlarfg_(&c__3, u, &u[1], &c__1, &tau);
u[0] = 1.;
t33 = t_ref(j3, j3);
/* Perform swap provisionally on diagonal block in D. */
dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
/* Test whether to reject swap.
Computing MAX */
d__4 = (d__1 = d___ref(2, 1), abs(d__1)), d__5 = (d__2 = d___ref(3, 1)
, abs(d__2)), d__4 = max(d__4,d__5), d__5 = (d__3 = d___ref(1,
1) - t33, abs(d__3));
if (max(d__4,d__5) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
dlarfx_("R", &j3, &c__3, u, &tau, &t_ref(1, *j1), ldt, &work[1]);
i__1 = *n - *j1;
dlarfx_("L", &c__3, &i__1, u, &tau, &t_ref(*j1, j2), ldt, &work[1]);
t_ref(*j1, *j1) = t33;
t_ref(j2, *j1) = 0.;
t_ref(j3, *j1) = 0.;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
dlarfx_("R", n, &c__3, u, &tau, &q_ref(1, *j1), ldq, &work[1]);
}
goto L40;
L30:
/* N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so
that:
H(2) H(1) ( -X11 -X12 ) = ( * * )
( -X21 -X22 ) ( 0 * )
( scale 0 ) ( 0 0 )
( 0 scale ) ( 0 0 ) */
u1[0] = -x_ref(1, 1);
u1[1] = -x_ref(2, 1);
u1[2] = scale;
dlarfg_(&c__3, u1, &u1[1], &c__1, &tau1);
u1[0] = 1.;
temp = -tau1 * (x_ref(1, 2) + u1[1] * x_ref(2, 2));
u2[0] = -temp * u1[1] - x_ref(2, 2);
u2[1] = -temp * u1[2];
u2[2] = scale;
dlarfg_(&c__3, u2, &u2[1], &c__1, &tau2);
u2[0] = 1.;
/* Perform swap provisionally on diagonal block in D. */
dlarfx_("L", &c__3, &c__4, u1, &tau1, d__, &c__4, &work[1])
;
dlarfx_("R", &c__4, &c__3, u1, &tau1, d__, &c__4, &work[1])
;
dlarfx_("L", &c__3, &c__4, u2, &tau2, &d___ref(2, 1), &c__4, &work[1]);
dlarfx_("R", &c__4, &c__3, u2, &tau2, &d___ref(1, 2), &c__4, &work[1]);
/* Test whether to reject swap.
Computing MAX */
d__5 = (d__1 = d___ref(3, 1), abs(d__1)), d__6 = (d__2 = d___ref(3, 2)
, abs(d__2)), d__5 = max(d__5,d__6), d__6 = (d__3 = d___ref(4,
1), abs(d__3)), d__5 = max(d__5,d__6), d__6 = (d__4 =
d___ref(4, 2), abs(d__4));
if (max(d__5,d__6) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
i__1 = *n - *j1 + 1;
dlarfx_("L", &c__3, &i__1, u1, &tau1, &t_ref(*j1, *j1), ldt, &work[1]);
dlarfx_("R", &j4, &c__3, u1, &tau1, &t_ref(1, *j1), ldt, &work[1]);
i__1 = *n - *j1 + 1;
dlarfx_("L", &c__3, &i__1, u2, &tau2, &t_ref(j2, *j1), ldt, &work[1]);
dlarfx_("R", &j4, &c__3, u2, &tau2, &t_ref(1, j2), ldt, &work[1]);
t_ref(j3, *j1) = 0.;
t_ref(j3, j2) = 0.;
t_ref(j4, *j1) = 0.;
t_ref(j4, j2) = 0.;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
dlarfx_("R", n, &c__3, u1, &tau1, &q_ref(1, *j1), ldq, &work[1]);
dlarfx_("R", n, &c__3, u2, &tau2, &q_ref(1, j2), ldq, &work[1]);
}
L40:
if (*n2 == 2) {
/* Standardize new 2-by-2 block T11 */
dlanv2_(&t_ref(*j1, *j1), &t_ref(*j1, j2), &t_ref(j2, *j1), &
t_ref(j2, j2), &wr1, &wi1, &wr2, &wi2, &cs, &sn);
i__1 = *n - *j1 - 1;
drot_(&i__1, &t_ref(*j1, *j1 + 2), ldt, &t_ref(j2, *j1 + 2), ldt,
&cs, &sn);
i__1 = *j1 - 1;
drot_(&i__1, &t_ref(1, *j1), &c__1, &t_ref(1, j2), &c__1, &cs, &
sn);
if (*wantq) {
drot_(n, &q_ref(1, *j1), &c__1, &q_ref(1, j2), &c__1, &cs, &
sn);
}
}
if (*n1 == 2) {
/* Standardize new 2-by-2 block T22 */
j3 = *j1 + *n2;
j4 = j3 + 1;
dlanv2_(&t_ref(j3, j3), &t_ref(j3, j4), &t_ref(j4, j3), &t_ref(j4,
j4), &wr1, &wi1, &wr2, &wi2, &cs, &sn);
if (j3 + 2 <= *n) {
i__1 = *n - j3 - 1;
drot_(&i__1, &t_ref(j3, j3 + 2), ldt, &t_ref(j4, j3 + 2), ldt,
&cs, &sn);
}
i__1 = j3 - 1;
drot_(&i__1, &t_ref(1, j3), &c__1, &t_ref(1, j4), &c__1, &cs, &sn)
;
if (*wantq) {
drot_(n, &q_ref(1, j3), &c__1, &q_ref(1, j4), &c__1, &cs, &sn)
;
}
}
}
return 0;
/* Exit with INFO = 1 if swap was rejected. */
L50:
*info = 1;
return 0;
/* End of DLAEXC */
} /* dlaexc_ */
/* Subroutine */ int dtzrqf_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *tau, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DTZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A
to upper triangular form by means of orthogonal transformations.
The upper trapezoidal matrix A is factored as
A = ( R 0 ) * Z,
where Z is an N-by-N orthogonal matrix and R is an M-by-M upper
triangular matrix.
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.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the leading M-by-N upper trapezoidal part of the
array A must contain the matrix to be factorized.
On exit, the leading M-by-M upper triangular part of A
contains the upper triangular matrix R, and elements M+1 to
N of the first M rows of A, with the array TAU, represent the
orthogonal matrix Z as a product of M elementary reflectors.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
TAU (output) DOUBLE PRECISION array, dimension (M)
The scalar factors of the elementary reflectors.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
The factorization is obtained by Householder's method. The kth
transformation matrix, Z( k ), which is used to introduce zeros into
the ( m - k + 1 )th row of A, is given in the form
Z( k ) = ( I 0 ),
( 0 T( k ) )
where
T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),
( 0 )
( z( k ) )
tau is a scalar and z( k ) is an ( n - m ) element vector.
tau and z( k ) are chosen to annihilate the elements of the kth row
of X.
The scalar tau is returned in the kth element of TAU and the vector
u( k ) in the kth row of A, such that the elements of z( k ) are
in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
the upper triangular part of A.
Z is given by
Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b8 = 1.;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer i, k;
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dcopy_(integer *,
doublereal *, integer *, doublereal *, integer *), daxpy_(integer
*, doublereal *, doublereal *, integer *, doublereal *, integer *)
;
static integer m1;
extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *), xerbla_(char *, integer *);
#define TAU(I) tau[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < *m) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DTZRQF", &i__1);
return 0;
}
/* Perform the factorization. */
if (*m == 0) {
return 0;
}
if (*m == *n) {
i__1 = *n;
for (i = 1; i <= *n; ++i) {
TAU(i) = 0.;
/* L10: */
}
} else {
/* Computing MIN */
i__1 = *m + 1;
m1 = min(i__1,*n);
for (k = *m; k >= 1; --k) {
/* Use a Householder reflection to zero the kth row of A
.
First set up the reflection. */
i__1 = *n - *m + 1;
dlarfg_(&i__1, &A(k,k), &A(k,m1), lda, &TAU(
k));
if (TAU(k) != 0. && k > 1) {
/* We now perform the operation A := A*P( k ).
Use the first ( k - 1 ) elements of TAU to sto
re a( k ),
where a( k ) consists of the first ( k - 1 )
elements of
the kth column of A. Also let B denote
the first
( k - 1 ) rows of the last ( n - m ) columns o
f A. */
i__1 = k - 1;
dcopy_(&i__1, &A(1,k), &c__1, &TAU(1), &c__1);
/* Form w = a( k ) + B*z( k ) in TAU. */
i__1 = k - 1;
i__2 = *n - *m;
dgemv_("No transpose", &i__1, &i__2, &c_b8, &A(1,m1), lda, &A(k,m1), lda, &c_b8, &TAU(1), &
c__1);
/* Now form a( k ) := a( k ) - tau*w
and B := B - tau*w*z( k )'. */
i__1 = k - 1;
d__1 = -TAU(k);
daxpy_(&i__1, &d__1, &TAU(1), &c__1, &A(1,k), &
c__1);
i__1 = k - 1;
i__2 = *n - *m;
d__1 = -TAU(k);
dger_(&i__1, &i__2, &d__1, &TAU(1), &c__1, &A(k,m1)
, lda, &A(1,m1), lda);
}
/* L20: */
}
}
return 0;
/* End of DTZRQF */
} /* dtzrqf_ */
/* Subroutine */ HYPRE_Int dlatrd_(const char *uplo, integer *n, integer *nb, doublereal *
a, integer *lda, doublereal *e, doublereal *tau, doublereal *w,
integer *ldw)
{
/* -- 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, 1992
Purpose
=======
DLATRD reduces NB rows and columns of a real symmetric matrix A to
symmetric tridiagonal form by an orthogonal similarity
transformation Q' * A * Q, and returns the matrices V and W which are
needed to apply the transformation to the unreduced part of A.
If UPLO = 'U', DLATRD reduces the last NB rows and columns of a
matrix, of which the upper triangle is supplied;
if UPLO = 'L', DLATRD reduces the first NB rows and columns of a
matrix, of which the lower triangle is supplied.
This is an auxiliary routine called by DSYTRD.
Arguments
=========
UPLO (input) CHARACTER
Specifies whether the upper or lower triangular part of the
symmetric matrix A is stored:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A.
NB (input) INTEGER
The number of rows and columns to be reduced.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the symmetric matrix A. If UPLO = 'U', the leading
n-by-n upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading n-by-n lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit:
if UPLO = 'U', the last NB columns have been reduced to
tridiagonal form, with the diagonal elements overwriting
the diagonal elements of A; the elements above the diagonal
with the array TAU, represent the orthogonal matrix Q as a
product of elementary reflectors;
if UPLO = 'L', the first NB columns have been reduced to
tridiagonal form, with the diagonal elements overwriting
the diagonal elements of A; the elements below the diagonal
with the array TAU, represent the orthogonal matrix Q as a
product of elementary reflectors.
See Further Details.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= (1,N).
E (output) DOUBLE PRECISION array, dimension (N-1)
If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
elements of the last NB columns of the reduced matrix;
if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
the first NB columns of the reduced matrix.
TAU (output) DOUBLE PRECISION array, dimension (N-1)
The scalar factors of the elementary reflectors, stored in
TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.
See Further Details.
W (output) DOUBLE PRECISION array, dimension (LDW,NB)
The n-by-nb matrix W required to update the unreduced part
of A.
LDW (input) INTEGER
The leading dimension of the array W. LDW >= max(1,N).
Further Details
===============
If UPLO = 'U', the matrix Q is represented as a product of elementary
reflectors
Q = H(n) H(n-1) . . . H(n-nb+1).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a real scalar, and v is a real vector with
v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),
and tau in TAU(i-1).
If UPLO = 'L', the matrix Q is represented as a product of elementary
reflectors
Q = H(1) H(2) . . . H(nb).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a real scalar, and v is a real vector with
v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
and tau in TAU(i).
The elements of the vectors v together form the n-by-nb matrix V
which is needed, with W, to apply the transformation to the unreduced
part of the matrix, using a symmetric rank-2k update of the form:
A := A - V*W' - W*V'.
The contents of A on exit are illustrated by the following examples
with n = 5 and nb = 2:
if UPLO = 'U': if UPLO = 'L':
( a a a v4 v5 ) ( d )
( a a v4 v5 ) ( 1 d )
( a 1 v5 ) ( v1 1 a )
( d 1 ) ( v1 v2 a a )
( d ) ( v1 v2 a a a )
where d denotes a diagonal element of the reduced matrix, a denotes
an element of the original matrix that is unchanged, and vi denotes
an element of the vector defining H(i).
=====================================================================
Quick return if possible
Parameter adjustments */
/* Table of constant values */
static doublereal c_b5 = -1.;
static doublereal c_b6 = 1.;
static integer c__1 = 1;
static doublereal c_b16 = 0.;
/* System generated locals */
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
/* Local variables */
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static integer i__;
static doublereal alpha;
extern /* Subroutine */ HYPRE_Int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(const char *,const char *);
extern /* Subroutine */ HYPRE_Int dgemv_(const char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), daxpy_(integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *),
dsymv_(const char *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *), dlarfg_(integer *, doublereal *, doublereal *, integer *,
doublereal *);
static integer iw;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define w_ref(a_1,a_2) w[(a_2)*w_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--e;
--tau;
w_dim1 = *ldw;
w_offset = 1 + w_dim1 * 1;
w -= w_offset;
/* Function Body */
if (*n <= 0) {
return 0;
}
if (lsame_(uplo, "U")) {
/* Reduce last NB columns of upper triangle */
i__1 = *n - *nb + 1;
for (i__ = *n; i__ >= i__1; --i__) {
iw = i__ - *n + *nb;
if (i__ < *n) {
/* Update A(1:i,i) */
i__2 = *n - i__;
dgemv_("No transpose", &i__, &i__2, &c_b5, &a_ref(1, i__ + 1),
lda, &w_ref(i__, iw + 1), ldw, &c_b6, &a_ref(1, i__),
&c__1);
i__2 = *n - i__;
dgemv_("No transpose", &i__, &i__2, &c_b5, &w_ref(1, iw + 1),
ldw, &a_ref(i__, i__ + 1), lda, &c_b6, &a_ref(1, i__),
&c__1);
}
if (i__ > 1) {
/* Generate elementary reflector H(i) to annihilate
A(1:i-2,i) */
i__2 = i__ - 1;
dlarfg_(&i__2, &a_ref(i__ - 1, i__), &a_ref(1, i__), &c__1, &
tau[i__ - 1]);
e[i__ - 1] = a_ref(i__ - 1, i__);
a_ref(i__ - 1, i__) = 1.;
/* Compute W(1:i-1,i) */
i__2 = i__ - 1;
dsymv_("Upper", &i__2, &c_b6, &a[a_offset], lda, &a_ref(1,
i__), &c__1, &c_b16, &w_ref(1, iw), &c__1);
if (i__ < *n) {
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_("Transpose", &i__2, &i__3, &c_b6, &w_ref(1, iw + 1)
, ldw, &a_ref(1, i__), &c__1, &c_b16, &w_ref(i__
+ 1, iw), &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(1, i__
+ 1), lda, &w_ref(i__ + 1, iw), &c__1, &c_b6, &
w_ref(1, iw), &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_("Transpose", &i__2, &i__3, &c_b6, &a_ref(1, i__ +
1), lda, &a_ref(1, i__), &c__1, &c_b16, &w_ref(
i__ + 1, iw), &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &w_ref(1, iw
+ 1), ldw, &w_ref(i__ + 1, iw), &c__1, &c_b6, &
w_ref(1, iw), &c__1);
}
i__2 = i__ - 1;
dscal_(&i__2, &tau[i__ - 1], &w_ref(1, iw), &c__1);
i__2 = i__ - 1;
alpha = tau[i__ - 1] * -.5 * ddot_(&i__2, &w_ref(1, iw), &
c__1, &a_ref(1, i__), &c__1);
i__2 = i__ - 1;
daxpy_(&i__2, &alpha, &a_ref(1, i__), &c__1, &w_ref(1, iw), &
c__1);
}
/* L10: */
}
} else {
/* Reduce first NB columns of lower triangle */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i:n,i) */
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(i__, 1), lda, &
w_ref(i__, 1), ldw, &c_b6, &a_ref(i__, i__), &c__1);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &w_ref(i__, 1), ldw, &
a_ref(i__, 1), lda, &c_b6, &a_ref(i__, i__), &c__1);
if (i__ < *n) {
/* Generate elementary reflector H(i) to annihilate
A(i+2:n,i)
Computing MIN */
i__2 = i__ + 2;
i__3 = *n - i__;
dlarfg_(&i__3, &a_ref(i__ + 1, i__), &a_ref(min(i__2,*n), i__)
, &c__1, &tau[i__]);
e[i__] = a_ref(i__ + 1, i__);
a_ref(i__ + 1, i__) = 1.;
/* Compute W(i+1:n,i) */
i__2 = *n - i__;
dsymv_("Lower", &i__2, &c_b6, &a_ref(i__ + 1, i__ + 1), lda, &
a_ref(i__ + 1, i__), &c__1, &c_b16, &w_ref(i__ + 1,
i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b6, &w_ref(i__ + 1, 1),
ldw, &a_ref(i__ + 1, i__), &c__1, &c_b16, &w_ref(1,
i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(i__ + 1, 1)
, lda, &w_ref(1, i__), &c__1, &c_b6, &w_ref(i__ + 1,
i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b6, &a_ref(i__ + 1, 1),
lda, &a_ref(i__ + 1, i__), &c__1, &c_b16, &w_ref(1,
i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &w_ref(i__ + 1, 1)
, ldw, &w_ref(1, i__), &c__1, &c_b6, &w_ref(i__ + 1,
i__), &c__1);
i__2 = *n - i__;
dscal_(&i__2, &tau[i__], &w_ref(i__ + 1, i__), &c__1);
i__2 = *n - i__;
alpha = tau[i__] * -.5 * ddot_(&i__2, &w_ref(i__ + 1, i__), &
c__1, &a_ref(i__ + 1, i__), &c__1);
i__2 = *n - i__;
daxpy_(&i__2, &alpha, &a_ref(i__ + 1, i__), &c__1, &w_ref(i__
+ 1, i__), &c__1);
}
/* L20: */
}
}
return 0;
/* End of DLATRD */
} /* dlatrd_ */
/* Subroutine */ int dlapll_(integer *n, doublereal *x, integer *incx,
doublereal *y, integer *incy, doublereal *ssmin)
{
/* System generated locals */
integer i__1;
/* Local variables */
doublereal c__, a11, a12, a22, tau;
doublereal ssmax;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* Given two column vectors X and Y, let */
/* A = ( X Y ). */
/* The subroutine first computes the QR factorization of A = Q*R, */
/* and then computes the SVD of the 2-by-2 upper triangular matrix R. */
/* The smaller singular value of R is returned in SSMIN, which is used */
/* as the measurement of the linear dependency of the vectors X and Y. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The length of the vectors X and Y. */
/* X (input/output) DOUBLE PRECISION array, */
/* dimension (1+(N-1)*INCX) */
/* On entry, X contains the N-vector X. */
/* On exit, X is overwritten. */
/* INCX (input) INTEGER */
/* The increment between successive elements of X. INCX > 0. */
/* Y (input/output) DOUBLE PRECISION array, */
/* dimension (1+(N-1)*INCY) */
/* On entry, Y contains the N-vector Y. */
/* On exit, Y is overwritten. */
/* INCY (input) INTEGER */
/* The increment between successive elements of Y. INCY > 0. */
/* SSMIN (output) DOUBLE PRECISION */
/* The smallest singular value of the N-by-2 matrix A = ( X Y ). */
/* ===================================================================== */
/* Quick return if possible */
/* Parameter adjustments */
--y;
--x;
/* Function Body */
if (*n <= 1) {
*ssmin = 0.;
return 0;
}
/* Compute the QR factorization of the N-by-2 matrix ( X Y ) */
dlarfg_(n, &x[1], &x[*incx + 1], incx, &tau);
a11 = x[1];
x[1] = 1.;
c__ = -tau * ddot_(n, &x[1], incx, &y[1], incy);
daxpy_(n, &c__, &x[1], incx, &y[1], incy);
i__1 = *n - 1;
dlarfg_(&i__1, &y[*incy + 1], &y[(*incy << 1) + 1], incy, &tau);
a12 = y[1];
a22 = y[*incy + 1];
/* Compute the SVD of 2-by-2 Upper triangular matrix. */
dlas2_(&a11, &a12, &a22, ssmin, &ssmax);
return 0;
/* End of DLAPLL */
} /* dlapll_ */
/* Subroutine */ int dgehd2_(integer *n, integer *ilo, integer *ihi,
doublereal *a, integer *lda, doublereal *tau, doublereal *work,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__;
doublereal aii;
extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *), dlarfg_(integer *, doublereal *,
doublereal *, integer *, doublereal *), xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGEHD2 reduces a real general matrix A to upper Hessenberg form H by */
/* an orthogonal similarity transformation: Q' * A * Q = H . */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that A 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; otherwise they should be */
/* set to 1 and N respectively. See Further Details. */
/* 1 <= ILO <= IHI <= max(1,N). */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the n by n general matrix to be reduced. */
/* On exit, the upper triangle and the first subdiagonal of A */
/* are overwritten with the upper Hessenberg matrix H, and the */
/* elements below the first subdiagonal, with the array TAU, */
/* represent the orthogonal matrix Q as a product of elementary */
/* reflectors. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of (ihi-ilo) elementary */
/* reflectors */
/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */
/* exit in A(i+2:ihi,i), and tau in TAU(i). */
/* The contents of A are illustrated by the following example, with */
/* n = 7, ilo = 2 and ihi = 6: */
/* on entry, on exit, */
/* ( a a a a a a a ) ( a a h h h h a ) */
/* ( a a a a a a ) ( a h h h h a ) */
/* ( a a a a a a ) ( h h h h h h ) */
/* ( a a a a a a ) ( v2 h h h h h ) */
/* ( a a a a a a ) ( v2 v3 h h h h ) */
/* ( a a a a a a ) ( v2 v3 v4 h h h ) */
/* ( a ) ( a ) */
/* where a denotes an element of the original matrix A, h denotes a */
/* modified element of the upper Hessenberg matrix H, and vi denotes an */
/* element of the vector defining H(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -2;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEHD2", &i__1);
return 0;
}
i__1 = *ihi - 1;
for (i__ = *ilo; i__ <= i__1; ++i__) {
/* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) */
i__2 = *ihi - i__;
/* Computing MIN */
i__3 = i__ + 2;
dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *n)+ i__ *
a_dim1], &c__1, &tau[i__]);
aii = a[i__ + 1 + i__ * a_dim1];
a[i__ + 1 + i__ * a_dim1] = 1.;
/* Apply H(i) to A(1:ihi,i+1:ihi) from the right */
i__2 = *ihi - i__;
dlarf_("Right", ihi, &i__2, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
i__], &a[(i__ + 1) * a_dim1 + 1], lda, &work[1]);
/* Apply H(i) to A(i+1:ihi,i+1:n) from the left */
i__2 = *ihi - i__;
i__3 = *n - i__;
dlarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
i__], &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1]);
a[i__ + 1 + i__ * a_dim1] = aii;
/* L10: */
}
return 0;
/* End of DGEHD2 */
} /* dgehd2_ */
/* Subroutine */ int dgelq2_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *tau, doublereal *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
static integer i__, k;
static doublereal aii;
extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, ftnlen), dlarfg_(integer *, doublereal *,
doublereal *, integer *, doublereal *), xerbla_(char *, integer *,
ftnlen);
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* February 29, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGELQ2 computes an LQ factorization of a real m by n matrix A: */
/* A = L * 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. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the m by n matrix A. */
/* On exit, the elements on and below the diagonal of the array */
/* contain the m by min(m,n) lower trapezoidal matrix L (L is */
/* lower triangular if m <= n); the elements above the diagonal, */
/* with the array TAU, represent the orthogonal matrix Q as a */
/* product of elementary reflectors (see Further Details). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (M) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of elementary reflectors */
/* Q = H(k) . . . H(2) H(1), where k = min(m,n). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), */
/* and tau in TAU(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGELQ2", &i__1, (ftnlen)6);
return 0;
}
k = min(*m,*n);
i__1 = k;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) to annihilate A(i,i+1:n) */
i__2 = *n - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3,*n) * a_dim1]
, lda, &tau[i__]);
if (i__ < *m) {
/* Apply H(i) to A(i+1:m,i:n) from the right */
aii = a[i__ + i__ * a_dim1];
a[i__ + i__ * a_dim1] = 1.;
i__2 = *m - i__;
i__3 = *n - i__ + 1;
dlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[
i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1], (ftnlen)
5);
a[i__ + i__ * a_dim1] = aii;
}
/* L10: */
}
return 0;
/* End of DGELQ2 */
} /* dgelq2_ */
/* Subroutine */ int dgeql2_(integer *m, integer *n, doublereal *a, integer *
lda, doublereal *tau, doublereal *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
integer i__, k;
doublereal aii;
extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *), dlarfg_(integer *, doublereal *,
doublereal *, integer *, doublereal *), 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 */
/* ======= */
/* DGEQL2 computes a QL factorization of a real m by n matrix A: */
/* A = Q * L. */
/* 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/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the m by n matrix A. */
/* On exit, if m >= n, the lower triangle of the subarray */
/* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L; */
/* if m <= n, the elements on and below the (n-m)-th */
/* superdiagonal contain the m by n lower trapezoidal matrix L; */
/* the remaining elements, with the array TAU, represent the */
/* orthogonal matrix Q as a product of elementary reflectors */
/* (see Further Details). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of elementary reflectors */
/* Q = H(k) . . . H(2) H(1), where k = min(m,n). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in */
/* A(1:m-k+i-1,n-k+i), and tau in TAU(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEQL2", &i__1);
return 0;
}
k = min(*m,*n);
for (i__ = k; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) to annihilate */
/* A(1:m-k+i-1,n-k+i) */
i__1 = *m - k + i__;
dlarfg_(&i__1, &a[*m - k + i__ + (*n - k + i__) * a_dim1], &a[(*n - k
+ i__) * a_dim1 + 1], &c__1, &tau[i__]);
/* Apply H(i) to A(1:m-k+i,1:n-k+i-1) from the left */
aii = a[*m - k + i__ + (*n - k + i__) * a_dim1];
a[*m - k + i__ + (*n - k + i__) * a_dim1] = 1.;
i__1 = *m - k + i__;
i__2 = *n - k + i__ - 1;
dlarf_("Left", &i__1, &i__2, &a[(*n - k + i__) * a_dim1 + 1], &c__1, &
tau[i__], &a[a_offset], lda, &work[1]);
a[*m - k + i__ + (*n - k + i__) * a_dim1] = aii;
/* L10: */
}
return 0;
/* End of DGEQL2 */
} /* dgeql2_ */
/* Subroutine */ int dlaexc_(logical *wantq, integer *n, doublereal *t,
integer *ldt, doublereal *q, integer *ldq, integer *j1, integer *n1,
integer *n2, doublereal *work, integer *info)
{
/* System generated locals */
integer q_dim1, q_offset, t_dim1, t_offset, i__1;
doublereal d__1, d__2, d__3;
/* Local variables */
doublereal d__[16] /* was [4][4] */;
integer k;
doublereal u[3], x[4] /* was [2][2] */;
integer j2, j3, j4;
doublereal u1[3], u2[3];
integer nd;
doublereal cs, t11, t22, t33, sn, wi1, wi2, wr1, wr2, eps, tau, tau1,
tau2;
integer ierr;
doublereal temp;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
doublereal scale, dnorm, xnorm;
extern /* Subroutine */ int dlanv2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), dlasy2_(
logical *, logical *, integer *, integer *, integer *, doublereal
*, integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *), dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), dlarfx_(char *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *);
doublereal thresh, smlnum;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in */
/* an upper quasi-triangular matrix T by an orthogonal similarity */
/* transformation. */
/* T must be in Schur canonical form, that is, block upper triangular */
/* with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block */
/* has its diagonal elemnts equal and its off-diagonal elements of */
/* opposite sign. */
/* Arguments */
/* ========= */
/* WANTQ (input) LOGICAL */
/* = .TRUE. : accumulate the transformation in the matrix Q; */
/* = .FALSE.: do not accumulate the transformation. */
/* N (input) INTEGER */
/* The order of the matrix T. N >= 0. */
/* T (input/output) DOUBLE PRECISION array, dimension (LDT,N) */
/* On entry, the upper quasi-triangular matrix T, in Schur */
/* canonical form. */
/* On exit, the updated matrix T, again in Schur canonical form. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= max(1,N). */
/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */
/* On entry, if WANTQ is .TRUE., the orthogonal matrix Q. */
/* On exit, if WANTQ is .TRUE., the updated matrix Q. */
/* If WANTQ is .FALSE., Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. */
/* LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N. */
/* J1 (input) INTEGER */
/* The index of the first row of the first block T11. */
/* N1 (input) INTEGER */
/* The order of the first block T11. N1 = 0, 1 or 2. */
/* N2 (input) INTEGER */
/* The order of the second block T22. N2 = 0, 1 or 2. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* = 1: the transformed matrix T would be too far from Schur */
/* form; the blocks are not swapped and T and Q are */
/* unchanged. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--work;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0 || *n1 == 0 || *n2 == 0) {
return 0;
}
if (*j1 + *n1 > *n) {
return 0;
}
j2 = *j1 + 1;
j3 = *j1 + 2;
j4 = *j1 + 3;
if (*n1 == 1 && *n2 == 1) {
/* Swap two 1-by-1 blocks. */
t11 = t[*j1 + *j1 * t_dim1];
t22 = t[j2 + j2 * t_dim1];
/* Determine the transformation to perform the interchange. */
d__1 = t22 - t11;
dlartg_(&t[*j1 + j2 * t_dim1], &d__1, &cs, &sn, &temp);
/* Apply transformation to the matrix T. */
if (j3 <= *n) {
i__1 = *n - *j1 - 1;
drot_(&i__1, &t[*j1 + j3 * t_dim1], ldt, &t[j2 + j3 * t_dim1],
ldt, &cs, &sn);
}
i__1 = *j1 - 1;
drot_(&i__1, &t[*j1 * t_dim1 + 1], &c__1, &t[j2 * t_dim1 + 1], &c__1,
&cs, &sn);
t[*j1 + *j1 * t_dim1] = t22;
t[j2 + j2 * t_dim1] = t11;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
drot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[j2 * q_dim1 + 1], &c__1,
&cs, &sn);
}
} else {
/* Swapping involves at least one 2-by-2 block. */
/* Copy the diagonal block of order N1+N2 to the local array D */
/* and compute its norm. */
nd = *n1 + *n2;
dlacpy_("Full", &nd, &nd, &t[*j1 + *j1 * t_dim1], ldt, d__, &c__4);
dnorm = dlange_("Max", &nd, &nd, d__, &c__4, &work[1]);
/* Compute machine-dependent threshold for test for accepting */
/* swap. */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
/* Computing MAX */
d__1 = eps * 10. * dnorm;
thresh = max(d__1,smlnum);
/* Solve T11*X - X*T22 = scale*T12 for X. */
dlasy2_(&c_false, &c_false, &c_n1, n1, n2, d__, &c__4, &d__[*n1 + 1 +
(*n1 + 1 << 2) - 5], &c__4, &d__[(*n1 + 1 << 2) - 4], &c__4, &
scale, x, &c__2, &xnorm, &ierr);
/* Swap the adjacent diagonal blocks. */
k = *n1 + *n1 + *n2 - 3;
switch (k) {
case 1: goto L10;
case 2: goto L20;
case 3: goto L30;
}
L10:
/* N1 = 1, N2 = 2: generate elementary reflector H so that: */
/* ( scale, X11, X12 ) H = ( 0, 0, * ) */
u[0] = scale;
u[1] = x[0];
u[2] = x[2];
dlarfg_(&c__3, &u[2], u, &c__1, &tau);
u[2] = 1.;
t11 = t[*j1 + *j1 * t_dim1];
/* Perform swap provisionally on diagonal block in D. */
dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
/* Test whether to reject swap. */
/* Computing MAX */
d__2 = abs(d__[2]), d__3 = abs(d__[6]), d__2 = max(d__2,d__3), d__3 =
(d__1 = d__[10] - t11, abs(d__1));
if (max(d__2,d__3) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
i__1 = *n - *j1 + 1;
dlarfx_("L", &c__3, &i__1, u, &tau, &t[*j1 + *j1 * t_dim1], ldt, &
work[1]);
dlarfx_("R", &j2, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1]);
t[j3 + *j1 * t_dim1] = 0.;
t[j3 + j2 * t_dim1] = 0.;
t[j3 + j3 * t_dim1] = t11;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
dlarfx_("R", n, &c__3, u, &tau, &q[*j1 * q_dim1 + 1], ldq, &work[
1]);
}
goto L40;
L20:
/* N1 = 2, N2 = 1: generate elementary reflector H so that: */
/* H ( -X11 ) = ( * ) */
/* ( -X21 ) = ( 0 ) */
/* ( scale ) = ( 0 ) */
u[0] = -x[0];
u[1] = -x[1];
u[2] = scale;
dlarfg_(&c__3, u, &u[1], &c__1, &tau);
u[0] = 1.;
t33 = t[j3 + j3 * t_dim1];
/* Perform swap provisionally on diagonal block in D. */
dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
/* Test whether to reject swap. */
/* Computing MAX */
d__2 = abs(d__[1]), d__3 = abs(d__[2]), d__2 = max(d__2,d__3), d__3 =
(d__1 = d__[0] - t33, abs(d__1));
if (max(d__2,d__3) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
dlarfx_("R", &j3, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1]);
i__1 = *n - *j1;
dlarfx_("L", &c__3, &i__1, u, &tau, &t[*j1 + j2 * t_dim1], ldt, &work[
1]);
t[*j1 + *j1 * t_dim1] = t33;
t[j2 + *j1 * t_dim1] = 0.;
t[j3 + *j1 * t_dim1] = 0.;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
dlarfx_("R", n, &c__3, u, &tau, &q[*j1 * q_dim1 + 1], ldq, &work[
1]);
}
goto L40;
L30:
/* N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so */
/* that: */
/* H(2) H(1) ( -X11 -X12 ) = ( * * ) */
/* ( -X21 -X22 ) ( 0 * ) */
/* ( scale 0 ) ( 0 0 ) */
/* ( 0 scale ) ( 0 0 ) */
u1[0] = -x[0];
u1[1] = -x[1];
u1[2] = scale;
dlarfg_(&c__3, u1, &u1[1], &c__1, &tau1);
u1[0] = 1.;
temp = -tau1 * (x[2] + u1[1] * x[3]);
u2[0] = -temp * u1[1] - x[3];
u2[1] = -temp * u1[2];
u2[2] = scale;
dlarfg_(&c__3, u2, &u2[1], &c__1, &tau2);
u2[0] = 1.;
/* Perform swap provisionally on diagonal block in D. */
dlarfx_("L", &c__3, &c__4, u1, &tau1, d__, &c__4, &work[1])
;
dlarfx_("R", &c__4, &c__3, u1, &tau1, d__, &c__4, &work[1])
;
dlarfx_("L", &c__3, &c__4, u2, &tau2, &d__[1], &c__4, &work[1]);
dlarfx_("R", &c__4, &c__3, u2, &tau2, &d__[4], &c__4, &work[1]);
/* Test whether to reject swap. */
/* Computing MAX */
d__1 = abs(d__[2]), d__2 = abs(d__[6]), d__1 = max(d__1,d__2), d__2 =
abs(d__[3]), d__1 = max(d__1,d__2), d__2 = abs(d__[7]);
if (max(d__1,d__2) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
i__1 = *n - *j1 + 1;
dlarfx_("L", &c__3, &i__1, u1, &tau1, &t[*j1 + *j1 * t_dim1], ldt, &
work[1]);
dlarfx_("R", &j4, &c__3, u1, &tau1, &t[*j1 * t_dim1 + 1], ldt, &work[
1]);
i__1 = *n - *j1 + 1;
dlarfx_("L", &c__3, &i__1, u2, &tau2, &t[j2 + *j1 * t_dim1], ldt, &
work[1]);
dlarfx_("R", &j4, &c__3, u2, &tau2, &t[j2 * t_dim1 + 1], ldt, &work[1]
);
t[j3 + *j1 * t_dim1] = 0.;
t[j3 + j2 * t_dim1] = 0.;
t[j4 + *j1 * t_dim1] = 0.;
t[j4 + j2 * t_dim1] = 0.;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
dlarfx_("R", n, &c__3, u1, &tau1, &q[*j1 * q_dim1 + 1], ldq, &
work[1]);
dlarfx_("R", n, &c__3, u2, &tau2, &q[j2 * q_dim1 + 1], ldq, &work[
1]);
}
L40:
if (*n2 == 2) {
/* Standardize new 2-by-2 block T11 */
dlanv2_(&t[*j1 + *j1 * t_dim1], &t[*j1 + j2 * t_dim1], &t[j2 + *
j1 * t_dim1], &t[j2 + j2 * t_dim1], &wr1, &wi1, &wr2, &
wi2, &cs, &sn);
i__1 = *n - *j1 - 1;
drot_(&i__1, &t[*j1 + (*j1 + 2) * t_dim1], ldt, &t[j2 + (*j1 + 2)
* t_dim1], ldt, &cs, &sn);
i__1 = *j1 - 1;
drot_(&i__1, &t[*j1 * t_dim1 + 1], &c__1, &t[j2 * t_dim1 + 1], &
c__1, &cs, &sn);
if (*wantq) {
drot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[j2 * q_dim1 + 1], &
c__1, &cs, &sn);
}
}
if (*n1 == 2) {
/* Standardize new 2-by-2 block T22 */
j3 = *j1 + *n2;
j4 = j3 + 1;
dlanv2_(&t[j3 + j3 * t_dim1], &t[j3 + j4 * t_dim1], &t[j4 + j3 *
t_dim1], &t[j4 + j4 * t_dim1], &wr1, &wi1, &wr2, &wi2, &
cs, &sn);
if (j3 + 2 <= *n) {
i__1 = *n - j3 - 1;
drot_(&i__1, &t[j3 + (j3 + 2) * t_dim1], ldt, &t[j4 + (j3 + 2)
* t_dim1], ldt, &cs, &sn);
}
i__1 = j3 - 1;
drot_(&i__1, &t[j3 * t_dim1 + 1], &c__1, &t[j4 * t_dim1 + 1], &
c__1, &cs, &sn);
if (*wantq) {
drot_(n, &q[j3 * q_dim1 + 1], &c__1, &q[j4 * q_dim1 + 1], &
c__1, &cs, &sn);
}
}
}
return 0;
/* Exit with INFO = 1 if swap was rejected. */
L50:
*info = 1;
return 0;
/* End of DLAEXC */
} /* dlaexc_ */
