/* Subroutine */
int dlags2_(logical *upper, doublereal *a1, doublereal *a2, doublereal *a3, doublereal *b1, doublereal *b2, doublereal *b3, doublereal *csu, doublereal *snu, doublereal *csv, doublereal *snv, doublereal *csq, doublereal *snq)
{
/* System generated locals */
doublereal d__1;
/* Local variables */
doublereal a, b, c__, d__, r__, s1, s2, ua11, ua12, ua21, ua22, vb11, vb12, vb21, vb22, csl, csr, snl, snr, aua11, aua12, aua21, aua22, avb11, avb12, avb21, avb22, ua11r, ua22r, vb11r, vb22r;
extern /* Subroutine */
int dlasv2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *), dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *);
/* -- LAPACK auxiliary 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 .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
if (*upper)
{
/* Input matrices A and B are upper triangular matrices */
/* Form matrix C = A*adj(B) = ( a b ) */
/* ( 0 d ) */
a = *a1 * *b3;
d__ = *a3 * *b1;
b = *a2 * *b1 - *a1 * *b2;
/* The SVD of real 2-by-2 triangular C */
/* ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 ) */
/* ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T ) */
dlasv2_(&a, &b, &d__, &s1, &s2, &snr, &csr, &snl, &csl);
if (f2c_abs(csl) >= f2c_abs(snl) || f2c_abs(csr) >= f2c_abs(snr))
{
/* Compute the (1,1) and (1,2) elements of U**T *A and V**T *B, */
/* and (1,2) element of |U|**T *|A| and |V|**T *|B|. */
ua11r = csl * *a1;
ua12 = csl * *a2 + snl * *a3;
vb11r = csr * *b1;
vb12 = csr * *b2 + snr * *b3;
aua12 = f2c_abs(csl) * f2c_abs(*a2) + f2c_abs(snl) * f2c_abs(*a3);
avb12 = f2c_abs(csr) * f2c_abs(*b2) + f2c_abs(snr) * f2c_abs(*b3);
/* zero (1,2) elements of U**T *A and V**T *B */
if (f2c_abs(ua11r) + f2c_abs(ua12) != 0.)
{
if (aua12 / (f2c_abs(ua11r) + f2c_abs(ua12)) <= avb12 / (f2c_abs(vb11r) + f2c_abs(vb12)))
{
d__1 = -ua11r;
dlartg_(&d__1, &ua12, csq, snq, &r__);
}
else
{
d__1 = -vb11r;
dlartg_(&d__1, &vb12, csq, snq, &r__);
}
}
else
{
d__1 = -vb11r;
dlartg_(&d__1, &vb12, csq, snq, &r__);
}
*csu = csl;
*snu = -snl;
*csv = csr;
*snv = -snr;
}
else
{
/* Compute the (2,1) and (2,2) elements of U**T *A and V**T *B, */
/* and (2,2) element of |U|**T *|A| and |V|**T *|B|. */
ua21 = -snl * *a1;
ua22 = -snl * *a2 + csl * *a3;
vb21 = -snr * *b1;
vb22 = -snr * *b2 + csr * *b3;
aua22 = f2c_abs(snl) * f2c_abs(*a2) + f2c_abs(csl) * f2c_abs(*a3);
avb22 = f2c_abs(snr) * f2c_abs(*b2) + f2c_abs(csr) * f2c_abs(*b3);
/* zero (2,2) elements of U**T*A and V**T*B, and then swap. */
if (f2c_abs(ua21) + f2c_abs(ua22) != 0.)
{
if (aua22 / (f2c_abs(ua21) + f2c_abs(ua22)) <= avb22 / (f2c_abs(vb21) + f2c_abs(vb22)))
{
d__1 = -ua21;
dlartg_(&d__1, &ua22, csq, snq, &r__);
}
else
{
d__1 = -vb21;
dlartg_(&d__1, &vb22, csq, snq, &r__);
}
}
else
{
d__1 = -vb21;
dlartg_(&d__1, &vb22, csq, snq, &r__);
}
*csu = snl;
*snu = csl;
*csv = snr;
*snv = csr;
}
}
else
{
/* Input matrices A and B are lower triangular matrices */
/* Form matrix C = A*adj(B) = ( a 0 ) */
/* ( c d ) */
a = *a1 * *b3;
d__ = *a3 * *b1;
c__ = *a2 * *b3 - *a3 * *b2;
/* The SVD of real 2-by-2 triangular C */
/* ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 ) */
/* ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T ) */
dlasv2_(&a, &c__, &d__, &s1, &s2, &snr, &csr, &snl, &csl);
if (f2c_abs(csr) >= f2c_abs(snr) || f2c_abs(csl) >= f2c_abs(snl))
{
/* Compute the (2,1) and (2,2) elements of U**T *A and V**T *B, */
/* and (2,1) element of |U|**T *|A| and |V|**T *|B|. */
ua21 = -snr * *a1 + csr * *a2;
ua22r = csr * *a3;
vb21 = -snl * *b1 + csl * *b2;
vb22r = csl * *b3;
aua21 = f2c_abs(snr) * f2c_abs(*a1) + f2c_abs(csr) * f2c_abs(*a2);
avb21 = f2c_abs(snl) * f2c_abs(*b1) + f2c_abs(csl) * f2c_abs(*b2);
/* zero (2,1) elements of U**T *A and V**T *B. */
if (f2c_abs(ua21) + f2c_abs(ua22r) != 0.)
{
if (aua21 / (f2c_abs(ua21) + f2c_abs(ua22r)) <= avb21 / (f2c_abs(vb21) + f2c_abs(vb22r)))
{
dlartg_(&ua22r, &ua21, csq, snq, &r__);
}
else
{
dlartg_(&vb22r, &vb21, csq, snq, &r__);
}
}
else
{
dlartg_(&vb22r, &vb21, csq, snq, &r__);
}
*csu = csr;
*snu = -snr;
*csv = csl;
*snv = -snl;
}
else
{
/* Compute the (1,1) and (1,2) elements of U**T *A and V**T *B, */
/* and (1,1) element of |U|**T *|A| and |V|**T *|B|. */
ua11 = csr * *a1 + snr * *a2;
ua12 = snr * *a3;
vb11 = csl * *b1 + snl * *b2;
vb12 = snl * *b3;
aua11 = f2c_abs(csr) * f2c_abs(*a1) + f2c_abs(snr) * f2c_abs(*a2);
avb11 = f2c_abs(csl) * f2c_abs(*b1) + f2c_abs(snl) * f2c_abs(*b2);
/* zero (1,1) elements of U**T*A and V**T*B, and then swap. */
if (f2c_abs(ua11) + f2c_abs(ua12) != 0.)
{
if (aua11 / (f2c_abs(ua11) + f2c_abs(ua12)) <= avb11 / (f2c_abs(vb11) + f2c_abs(vb12)))
{
dlartg_(&ua12, &ua11, csq, snq, &r__);
}
else
{
dlartg_(&vb12, &vb11, csq, snq, &r__);
}
}
else
{
dlartg_(&vb12, &vb11, csq, snq, &r__);
}
*csu = snr;
*snu = csr;
*csv = snl;
*snv = csl;
}
}
return 0;
/* End of DLAGS2 */
}
/* Subroutine */ int dlags2_(logical *upper, doublereal *a1, doublereal *a2,
doublereal *a3, doublereal *b1, doublereal *b2, doublereal *b3,
doublereal *csu, doublereal *snu, doublereal *csv, doublereal *snv,
doublereal *csq, doublereal *snq)
{
/* System generated locals */
doublereal d__1;
/* Local variables */
doublereal a, b, c__, d__, r__, s1, s2, ua11, ua12, ua21, ua22, vb11,
vb12, vb21, vb22, csl, csr, snl, snr, aua11, aua12, aua21, aua22,
avb11, avb12, avb21, avb22, ua11r, ua22r, vb11r, vb22r;
extern /* Subroutine */ int dlasv2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *), dlartg_(doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *);
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such */
/* that if ( UPPER ) then */
/* U'*A*Q = U'*( A1 A2 )*Q = ( x 0 ) */
/* ( 0 A3 ) ( x x ) */
/* and */
/* V'*B*Q = V'*( B1 B2 )*Q = ( x 0 ) */
/* ( 0 B3 ) ( x x ) */
/* or if ( .NOT.UPPER ) then */
/* U'*A*Q = U'*( A1 0 )*Q = ( x x ) */
/* ( A2 A3 ) ( 0 x ) */
/* and */
/* V'*B*Q = V'*( B1 0 )*Q = ( x x ) */
/* ( B2 B3 ) ( 0 x ) */
/* The rows of the transformed A and B are parallel, where */
/* U = ( CSU SNU ), V = ( CSV SNV ), Q = ( CSQ SNQ ) */
/* ( -SNU CSU ) ( -SNV CSV ) ( -SNQ CSQ ) */
/* Z' denotes the transpose of Z. */
/* Arguments */
/* ========= */
/* UPPER (input) LOGICAL */
/* = .TRUE.: the input matrices A and B are upper triangular. */
/* = .FALSE.: the input matrices A and B are lower triangular. */
/* A1 (input) DOUBLE PRECISION */
/* A2 (input) DOUBLE PRECISION */
/* A3 (input) DOUBLE PRECISION */
/* On entry, A1, A2 and A3 are elements of the input 2-by-2 */
/* upper (lower) triangular matrix A. */
/* B1 (input) DOUBLE PRECISION */
/* B2 (input) DOUBLE PRECISION */
/* B3 (input) DOUBLE PRECISION */
/* On entry, B1, B2 and B3 are elements of the input 2-by-2 */
/* upper (lower) triangular matrix B. */
/* CSU (output) DOUBLE PRECISION */
/* SNU (output) DOUBLE PRECISION */
/* The desired orthogonal matrix U. */
/* CSV (output) DOUBLE PRECISION */
/* SNV (output) DOUBLE PRECISION */
/* The desired orthogonal matrix V. */
/* CSQ (output) DOUBLE PRECISION */
/* SNQ (output) DOUBLE PRECISION */
/* The desired orthogonal matrix Q. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
if (*upper) {
/* Input matrices A and B are upper triangular matrices */
/* Form matrix C = A*adj(B) = ( a b ) */
/* ( 0 d ) */
a = *a1 * *b3;
d__ = *a3 * *b1;
b = *a2 * *b1 - *a1 * *b2;
/* The SVD of real 2-by-2 triangular C */
/* ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 ) */
/* ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T ) */
dlasv2_(&a, &b, &d__, &s1, &s2, &snr, &csr, &snl, &csl);
if (abs(csl) >= abs(snl) || abs(csr) >= abs(snr)) {
/* Compute the (1,1) and (1,2) elements of U'*A and V'*B, */
/* and (1,2) element of |U|'*|A| and |V|'*|B|. */
ua11r = csl * *a1;
ua12 = csl * *a2 + snl * *a3;
vb11r = csr * *b1;
vb12 = csr * *b2 + snr * *b3;
aua12 = abs(csl) * abs(*a2) + abs(snl) * abs(*a3);
avb12 = abs(csr) * abs(*b2) + abs(snr) * abs(*b3);
/* zero (1,2) elements of U'*A and V'*B */
if (abs(ua11r) + abs(ua12) != 0.) {
if (aua12 / (abs(ua11r) + abs(ua12)) <= avb12 / (abs(vb11r) +
abs(vb12))) {
d__1 = -ua11r;
dlartg_(&d__1, &ua12, csq, snq, &r__);
} else {
d__1 = -vb11r;
dlartg_(&d__1, &vb12, csq, snq, &r__);
}
} else {
d__1 = -vb11r;
dlartg_(&d__1, &vb12, csq, snq, &r__);
}
*csu = csl;
*snu = -snl;
*csv = csr;
*snv = -snr;
} else {
/* Compute the (2,1) and (2,2) elements of U'*A and V'*B, */
/* and (2,2) element of |U|'*|A| and |V|'*|B|. */
ua21 = -snl * *a1;
ua22 = -snl * *a2 + csl * *a3;
vb21 = -snr * *b1;
vb22 = -snr * *b2 + csr * *b3;
aua22 = abs(snl) * abs(*a2) + abs(csl) * abs(*a3);
avb22 = abs(snr) * abs(*b2) + abs(csr) * abs(*b3);
/* zero (2,2) elements of U'*A and V'*B, and then swap. */
if (abs(ua21) + abs(ua22) != 0.) {
if (aua22 / (abs(ua21) + abs(ua22)) <= avb22 / (abs(vb21) +
abs(vb22))) {
d__1 = -ua21;
dlartg_(&d__1, &ua22, csq, snq, &r__);
} else {
d__1 = -vb21;
dlartg_(&d__1, &vb22, csq, snq, &r__);
}
} else {
d__1 = -vb21;
dlartg_(&d__1, &vb22, csq, snq, &r__);
}
*csu = snl;
*snu = csl;
*csv = snr;
*snv = csr;
}
} else {
/* Input matrices A and B are lower triangular matrices */
/* Form matrix C = A*adj(B) = ( a 0 ) */
/* ( c d ) */
a = *a1 * *b3;
d__ = *a3 * *b1;
c__ = *a2 * *b3 - *a3 * *b2;
/* The SVD of real 2-by-2 triangular C */
/* ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 ) */
/* ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T ) */
dlasv2_(&a, &c__, &d__, &s1, &s2, &snr, &csr, &snl, &csl);
if (abs(csr) >= abs(snr) || abs(csl) >= abs(snl)) {
/* Compute the (2,1) and (2,2) elements of U'*A and V'*B, */
/* and (2,1) element of |U|'*|A| and |V|'*|B|. */
ua21 = -snr * *a1 + csr * *a2;
ua22r = csr * *a3;
vb21 = -snl * *b1 + csl * *b2;
vb22r = csl * *b3;
aua21 = abs(snr) * abs(*a1) + abs(csr) * abs(*a2);
avb21 = abs(snl) * abs(*b1) + abs(csl) * abs(*b2);
/* zero (2,1) elements of U'*A and V'*B. */
if (abs(ua21) + abs(ua22r) != 0.) {
if (aua21 / (abs(ua21) + abs(ua22r)) <= avb21 / (abs(vb21) +
abs(vb22r))) {
dlartg_(&ua22r, &ua21, csq, snq, &r__);
} else {
dlartg_(&vb22r, &vb21, csq, snq, &r__);
}
} else {
dlartg_(&vb22r, &vb21, csq, snq, &r__);
}
*csu = csr;
*snu = -snr;
*csv = csl;
*snv = -snl;
} else {
/* Compute the (1,1) and (1,2) elements of U'*A and V'*B, */
/* and (1,1) element of |U|'*|A| and |V|'*|B|. */
ua11 = csr * *a1 + snr * *a2;
ua12 = snr * *a3;
vb11 = csl * *b1 + snl * *b2;
vb12 = snl * *b3;
aua11 = abs(csr) * abs(*a1) + abs(snr) * abs(*a2);
avb11 = abs(csl) * abs(*b1) + abs(snl) * abs(*b2);
/* zero (1,1) elements of U'*A and V'*B, and then swap. */
if (abs(ua11) + abs(ua12) != 0.) {
if (aua11 / (abs(ua11) + abs(ua12)) <= avb11 / (abs(vb11) +
abs(vb12))) {
dlartg_(&ua12, &ua11, csq, snq, &r__);
} else {
dlartg_(&vb12, &vb11, csq, snq, &r__);
}
} else {
dlartg_(&vb12, &vb11, csq, snq, &r__);
}
*csu = snr;
*snu = csr;
*csv = snl;
*snv = csl;
}
}
return 0;
/* End of DLAGS2 */
} /* dlags2_ */
/* Subroutine */ int zbdsqr_(char *uplo, integer *n, integer *ncvt, integer *
nru, integer *ncc, doublereal *d__, doublereal *e, doublecomplex *vt,
integer *ldvt, doublecomplex *u, integer *ldu, doublecomplex *c__,
integer *ldc, doublereal *rwork, integer *info)
{
/* System generated locals */
integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
i__2;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *), sqrt(doublereal), d_sign(
doublereal *, doublereal *);
/* Local variables */
static doublereal abse;
static integer idir;
static doublereal abss;
static integer oldm;
static doublereal cosl;
static integer isub, iter;
static doublereal unfl, sinl, cosr, smin, smax, sinr;
extern /* Subroutine */ int dlas2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
static doublereal f, g, h__;
static integer i__, j, m;
static doublereal r__;
extern logical lsame_(char *, char *);
static doublereal oldcs;
static integer oldll;
static doublereal shift, sigmn, oldsn;
static integer maxit;
static doublereal sminl, sigmx;
static logical lower;
extern /* Subroutine */ int zlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublecomplex *, integer *), zdrot_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *)
, zswap_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *), dlasq1_(integer *, doublereal *, doublereal *,
doublereal *, integer *), dlasv2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
static doublereal cs;
static integer ll;
extern doublereal dlamch_(char *);
static doublereal sn, mu;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *), xerbla_(char *,
integer *), zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
static doublereal sminoa, thresh;
static logical rotate;
static doublereal sminlo;
static integer nm1;
static doublereal tolmul;
static integer nm12, nm13, lll;
static doublereal eps, sll, tol;
#define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1
#define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)]
#define u_subscr(a_1,a_2) (a_2)*u_dim1 + a_1
#define u_ref(a_1,a_2) u[u_subscr(a_1,a_2)]
#define vt_subscr(a_1,a_2) (a_2)*vt_dim1 + a_1
#define vt_ref(a_1,a_2) vt[vt_subscr(a_1,a_2)]
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1999
Purpose
=======
ZBDSQR computes the singular value decomposition (SVD) of a real
N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P'
denotes the transpose of P), where S is a diagonal matrix with
non-negative diagonal elements (the singular values of B), and Q
and P are orthogonal matrices.
The routine computes S, and optionally computes U * Q, P' * VT,
or Q' * C, for given complex input matrices U, VT, and C.
See "Computing Small Singular Values of Bidiagonal Matrices With
Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
no. 5, pp. 873-912, Sept 1990) and
"Accurate singular values and differential qd algorithms," by
B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
Department, University of California at Berkeley, July 1992
for a detailed description of the algorithm.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': B is upper bidiagonal;
= 'L': B is lower bidiagonal.
N (input) INTEGER
The order of the matrix B. N >= 0.
NCVT (input) INTEGER
The number of columns of the matrix VT. NCVT >= 0.
NRU (input) INTEGER
The number of rows of the matrix U. NRU >= 0.
NCC (input) INTEGER
The number of columns of the matrix C. NCC >= 0.
D (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the n diagonal elements of the bidiagonal matrix B.
On exit, if INFO=0, the singular values of B in decreasing
order.
E (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the elements of E contain the
offdiagonal elements of of the bidiagonal matrix whose SVD
is desired. On normal exit (INFO = 0), E is destroyed.
If the algorithm does not converge (INFO > 0), D and E
will contain the diagonal and superdiagonal elements of a
bidiagonal matrix orthogonally equivalent to the one given
as input. E(N) is used for workspace.
VT (input/output) COMPLEX*16 array, dimension (LDVT, NCVT)
On entry, an N-by-NCVT matrix VT.
On exit, VT is overwritten by P' * VT.
VT is not referenced if NCVT = 0.
LDVT (input) INTEGER
The leading dimension of the array VT.
LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
U (input/output) COMPLEX*16 array, dimension (LDU, N)
On entry, an NRU-by-N matrix U.
On exit, U is overwritten by U * Q.
U is not referenced if NRU = 0.
LDU (input) INTEGER
The leading dimension of the array U. LDU >= max(1,NRU).
C (input/output) COMPLEX*16 array, dimension (LDC, NCC)
On entry, an N-by-NCC matrix C.
On exit, C is overwritten by Q' * C.
C is not referenced if NCC = 0.
LDC (input) INTEGER
The leading dimension of the array C.
LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
RWORK (workspace) DOUBLE PRECISION array, dimension (4*N)
INFO (output) INTEGER
= 0: successful exit
< 0: If INFO = -i, the i-th argument had an illegal value
> 0: the algorithm did not converge; D and E contain the
elements of a bidiagonal matrix which is orthogonally
similar to the input matrix B; if INFO = i, i
elements of E have not converged to zero.
Internal Parameters
===================
TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))
TOLMUL controls the convergence criterion of the QR loop.
If it is positive, TOLMUL*EPS is the desired relative
precision in the computed singular values.
If it is negative, abs(TOLMUL*EPS*sigma_max) is the
desired absolute accuracy in the computed singular
values (corresponds to relative accuracy
abs(TOLMUL*EPS) in the largest singular value.
abs(TOLMUL) should be between 1 and 1/EPS, and preferably
between 10 (for fast convergence) and .1/EPS
(for there to be some accuracy in the results).
Default is to lose at either one eighth or 2 of the
available decimal digits in each computed singular value
(whichever is smaller).
MAXITR INTEGER, default = 6
MAXITR controls the maximum number of passes of the
algorithm through its inner loop. The algorithms stops
(and so fails to converge) if the number of passes
through the inner loop exceeds MAXITR*N**2.
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
--e;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1 * 1;
vt -= vt_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--rwork;
/* Function Body */
*info = 0;
lower = lsame_(uplo, "L");
if (! lsame_(uplo, "U") && ! lower) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ncvt < 0) {
*info = -3;
} else if (*nru < 0) {
*info = -4;
} else if (*ncc < 0) {
*info = -5;
} else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1,*n)) {
*info = -9;
} else if (*ldu < max(1,*nru)) {
*info = -11;
} else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1,*n)) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZBDSQR", &i__1);
return 0;
}
if (*n == 0) {
return 0;
}
if (*n == 1) {
goto L160;
}
/* ROTATE is true if any singular vectors desired, false otherwise */
rotate = *ncvt > 0 || *nru > 0 || *ncc > 0;
/* If no singular vectors desired, use qd algorithm */
if (! rotate) {
dlasq1_(n, &d__[1], &e[1], &rwork[1], info);
return 0;
}
nm1 = *n - 1;
nm12 = nm1 + nm1;
nm13 = nm12 + nm1;
idir = 0;
/* Get machine constants */
eps = dlamch_("Epsilon");
unfl = dlamch_("Safe minimum");
/* If matrix lower bidiagonal, rotate to be upper bidiagonal
by applying Givens rotations on the left */
if (lower) {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
rwork[i__] = cs;
rwork[nm1 + i__] = sn;
/* L10: */
}
/* Update singular vectors if desired */
if (*nru > 0) {
zlasr_("R", "V", "F", nru, n, &rwork[1], &rwork[*n], &u[u_offset],
ldu);
}
if (*ncc > 0) {
zlasr_("L", "V", "F", n, ncc, &rwork[1], &rwork[*n], &c__[
c_offset], ldc);
}
}
/* Compute singular values to relative accuracy TOL
(By setting TOL to be negative, algorithm will compute
singular values to absolute accuracy ABS(TOL)*norm(input matrix))
Computing MAX
Computing MIN */
d__3 = 100., d__4 = pow_dd(&eps, &c_b15);
d__1 = 10., d__2 = min(d__3,d__4);
tolmul = max(d__1,d__2);
tol = tolmul * eps;
/* Compute approximate maximum, minimum singular values */
smax = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = smax, d__3 = (d__1 = d__[i__], abs(d__1));
smax = max(d__2,d__3);
/* L20: */
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = smax, d__3 = (d__1 = e[i__], abs(d__1));
smax = max(d__2,d__3);
/* L30: */
}
sminl = 0.;
if (tol >= 0.) {
/* Relative accuracy desired */
sminoa = abs(d__[1]);
if (sminoa == 0.) {
goto L50;
}
mu = sminoa;
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
mu = (d__2 = d__[i__], abs(d__2)) * (mu / (mu + (d__1 = e[i__ - 1]
, abs(d__1))));
sminoa = min(sminoa,mu);
if (sminoa == 0.) {
goto L50;
}
/* L40: */
}
L50:
sminoa /= sqrt((doublereal) (*n));
/* Computing MAX */
d__1 = tol * sminoa, d__2 = *n * 6 * *n * unfl;
thresh = max(d__1,d__2);
} else {
/* Absolute accuracy desired
Computing MAX */
d__1 = abs(tol) * smax, d__2 = *n * 6 * *n * unfl;
thresh = max(d__1,d__2);
}
/* Prepare for main iteration loop for the singular values
(MAXIT is the maximum number of passes through the inner
loop permitted before nonconvergence signalled.) */
maxit = *n * 6 * *n;
iter = 0;
oldll = -1;
oldm = -1;
/* M points to last element of unconverged part of matrix */
m = *n;
/* Begin main iteration loop */
L60:
/* Check for convergence or exceeding iteration count */
if (m <= 1) {
goto L160;
}
if (iter > maxit) {
goto L200;
}
/* Find diagonal block of matrix to work on */
if (tol < 0. && (d__1 = d__[m], abs(d__1)) <= thresh) {
d__[m] = 0.;
}
smax = (d__1 = d__[m], abs(d__1));
smin = smax;
i__1 = m - 1;
for (lll = 1; lll <= i__1; ++lll) {
ll = m - lll;
abss = (d__1 = d__[ll], abs(d__1));
abse = (d__1 = e[ll], abs(d__1));
if (tol < 0. && abss <= thresh) {
d__[ll] = 0.;
}
if (abse <= thresh) {
goto L80;
}
smin = min(smin,abss);
/* Computing MAX */
d__1 = max(smax,abss);
smax = max(d__1,abse);
/* L70: */
}
ll = 0;
goto L90;
L80:
e[ll] = 0.;
/* Matrix splits since E(LL) = 0 */
if (ll == m - 1) {
/* Convergence of bottom singular value, return to top of loop */
--m;
goto L60;
}
L90:
++ll;
/* E(LL) through E(M-1) are nonzero, E(LL-1) is zero */
if (ll == m - 1) {
/* 2 by 2 block, handle separately */
dlasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr,
&sinl, &cosl);
d__[m - 1] = sigmx;
e[m - 1] = 0.;
d__[m] = sigmn;
/* Compute singular vectors, if desired */
if (*ncvt > 0) {
zdrot_(ncvt, &vt_ref(m - 1, 1), ldvt, &vt_ref(m, 1), ldvt, &cosr,
&sinr);
}
if (*nru > 0) {
zdrot_(nru, &u_ref(1, m - 1), &c__1, &u_ref(1, m), &c__1, &cosl, &
sinl);
}
if (*ncc > 0) {
zdrot_(ncc, &c___ref(m - 1, 1), ldc, &c___ref(m, 1), ldc, &cosl, &
sinl);
}
m += -2;
goto L60;
}
/* If working on new submatrix, choose shift direction
(from larger end diagonal element towards smaller) */
if (ll > oldm || m < oldll) {
if ((d__1 = d__[ll], abs(d__1)) >= (d__2 = d__[m], abs(d__2))) {
/* Chase bulge from top (big end) to bottom (small end) */
idir = 1;
} else {
/* Chase bulge from bottom (big end) to top (small end) */
idir = 2;
}
}
/* Apply convergence tests */
if (idir == 1) {
/* Run convergence test in forward direction
First apply standard test to bottom of matrix */
if ((d__2 = e[m - 1], abs(d__2)) <= abs(tol) * (d__1 = d__[m], abs(
d__1)) || tol < 0. && (d__3 = e[m - 1], abs(d__3)) <= thresh)
{
e[m - 1] = 0.;
goto L60;
}
if (tol >= 0.) {
/* If relative accuracy desired,
apply convergence criterion forward */
mu = (d__1 = d__[ll], abs(d__1));
sminl = mu;
i__1 = m - 1;
for (lll = ll; lll <= i__1; ++lll) {
if ((d__1 = e[lll], abs(d__1)) <= tol * mu) {
e[lll] = 0.;
goto L60;
}
sminlo = sminl;
mu = (d__2 = d__[lll + 1], abs(d__2)) * (mu / (mu + (d__1 = e[
lll], abs(d__1))));
sminl = min(sminl,mu);
/* L100: */
}
}
} else {
/* Run convergence test in backward direction
First apply standard test to top of matrix */
if ((d__2 = e[ll], abs(d__2)) <= abs(tol) * (d__1 = d__[ll], abs(d__1)
) || tol < 0. && (d__3 = e[ll], abs(d__3)) <= thresh) {
e[ll] = 0.;
goto L60;
}
if (tol >= 0.) {
/* If relative accuracy desired,
apply convergence criterion backward */
mu = (d__1 = d__[m], abs(d__1));
sminl = mu;
i__1 = ll;
for (lll = m - 1; lll >= i__1; --lll) {
if ((d__1 = e[lll], abs(d__1)) <= tol * mu) {
e[lll] = 0.;
goto L60;
}
sminlo = sminl;
mu = (d__2 = d__[lll], abs(d__2)) * (mu / (mu + (d__1 = e[lll]
, abs(d__1))));
sminl = min(sminl,mu);
/* L110: */
}
}
}
oldll = ll;
oldm = m;
/* Compute shift. First, test if shifting would ruin relative
accuracy, and if so set the shift to zero.
Computing MAX */
d__1 = eps, d__2 = tol * .01;
if (tol >= 0. && *n * tol * (sminl / smax) <= max(d__1,d__2)) {
/* Use a zero shift to avoid loss of relative accuracy */
shift = 0.;
} else {
/* Compute the shift from 2-by-2 block at end of matrix */
if (idir == 1) {
sll = (d__1 = d__[ll], abs(d__1));
dlas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__);
} else {
sll = (d__1 = d__[m], abs(d__1));
dlas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__);
}
/* Test if shift negligible, and if so set to zero */
if (sll > 0.) {
/* Computing 2nd power */
d__1 = shift / sll;
if (d__1 * d__1 < eps) {
shift = 0.;
}
}
}
/* Increment iteration count */
iter = iter + m - ll;
/* If SHIFT = 0, do simplified QR iteration */
if (shift == 0.) {
if (idir == 1) {
/* Chase bulge from top to bottom
Save cosines and sines for later singular vector updates */
cs = 1.;
oldcs = 1.;
i__1 = m - 1;
for (i__ = ll; i__ <= i__1; ++i__) {
d__1 = d__[i__] * cs;
dlartg_(&d__1, &e[i__], &cs, &sn, &r__);
if (i__ > ll) {
e[i__ - 1] = oldsn * r__;
}
d__1 = oldcs * r__;
d__2 = d__[i__ + 1] * sn;
dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
rwork[i__ - ll + 1] = cs;
rwork[i__ - ll + 1 + nm1] = sn;
rwork[i__ - ll + 1 + nm12] = oldcs;
rwork[i__ - ll + 1 + nm13] = oldsn;
/* L120: */
}
h__ = d__[m] * cs;
d__[m] = h__ * oldcs;
e[m - 1] = h__ * oldsn;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "F", &i__1, ncvt, &rwork[1], &rwork[*n], &
vt_ref(ll, 1), ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
zlasr_("R", "V", "F", nru, &i__1, &rwork[nm12 + 1], &rwork[
nm13 + 1], &u_ref(1, ll), ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "F", &i__1, ncc, &rwork[nm12 + 1], &rwork[
nm13 + 1], &c___ref(ll, 1), ldc);
}
/* Test convergence */
if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
e[m - 1] = 0.;
}
} else {
/* Chase bulge from bottom to top
Save cosines and sines for later singular vector updates */
cs = 1.;
oldcs = 1.;
i__1 = ll + 1;
for (i__ = m; i__ >= i__1; --i__) {
d__1 = d__[i__] * cs;
dlartg_(&d__1, &e[i__ - 1], &cs, &sn, &r__);
if (i__ < m) {
e[i__] = oldsn * r__;
}
d__1 = oldcs * r__;
d__2 = d__[i__ - 1] * sn;
dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
rwork[i__ - ll] = cs;
rwork[i__ - ll + nm1] = -sn;
rwork[i__ - ll + nm12] = oldcs;
rwork[i__ - ll + nm13] = -oldsn;
/* L130: */
}
h__ = d__[ll] * cs;
d__[ll] = h__ * oldcs;
e[ll] = h__ * oldsn;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "B", &i__1, ncvt, &rwork[nm12 + 1], &rwork[
nm13 + 1], &vt_ref(ll, 1), ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
zlasr_("R", "V", "B", nru, &i__1, &rwork[1], &rwork[*n], &
u_ref(1, ll), ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "B", &i__1, ncc, &rwork[1], &rwork[*n], &
c___ref(ll, 1), ldc);
}
/* Test convergence */
if ((d__1 = e[ll], abs(d__1)) <= thresh) {
e[ll] = 0.;
}
}
} else {
/* Use nonzero shift */
if (idir == 1) {
/* Chase bulge from top to bottom
Save cosines and sines for later singular vector updates */
f = ((d__1 = d__[ll], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[
ll]) + shift / d__[ll]);
g = e[ll];
i__1 = m - 1;
for (i__ = ll; i__ <= i__1; ++i__) {
dlartg_(&f, &g, &cosr, &sinr, &r__);
if (i__ > ll) {
e[i__ - 1] = r__;
}
f = cosr * d__[i__] + sinr * e[i__];
e[i__] = cosr * e[i__] - sinr * d__[i__];
g = sinr * d__[i__ + 1];
d__[i__ + 1] = cosr * d__[i__ + 1];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[i__] = r__;
f = cosl * e[i__] + sinl * d__[i__ + 1];
d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__];
if (i__ < m - 1) {
g = sinl * e[i__ + 1];
e[i__ + 1] = cosl * e[i__ + 1];
}
rwork[i__ - ll + 1] = cosr;
rwork[i__ - ll + 1 + nm1] = sinr;
rwork[i__ - ll + 1 + nm12] = cosl;
rwork[i__ - ll + 1 + nm13] = sinl;
/* L140: */
}
e[m - 1] = f;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "F", &i__1, ncvt, &rwork[1], &rwork[*n], &
vt_ref(ll, 1), ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
zlasr_("R", "V", "F", nru, &i__1, &rwork[nm12 + 1], &rwork[
nm13 + 1], &u_ref(1, ll), ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "F", &i__1, ncc, &rwork[nm12 + 1], &rwork[
nm13 + 1], &c___ref(ll, 1), ldc);
}
/* Test convergence */
if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
e[m - 1] = 0.;
}
} else {
/* Chase bulge from bottom to top
Save cosines and sines for later singular vector updates */
f = ((d__1 = d__[m], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[m]
) + shift / d__[m]);
g = e[m - 1];
i__1 = ll + 1;
for (i__ = m; i__ >= i__1; --i__) {
dlartg_(&f, &g, &cosr, &sinr, &r__);
if (i__ < m) {
e[i__] = r__;
}
f = cosr * d__[i__] + sinr * e[i__ - 1];
e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__];
g = sinr * d__[i__ - 1];
d__[i__ - 1] = cosr * d__[i__ - 1];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[i__] = r__;
f = cosl * e[i__ - 1] + sinl * d__[i__ - 1];
d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1];
if (i__ > ll + 1) {
g = sinl * e[i__ - 2];
e[i__ - 2] = cosl * e[i__ - 2];
}
rwork[i__ - ll] = cosr;
rwork[i__ - ll + nm1] = -sinr;
rwork[i__ - ll + nm12] = cosl;
rwork[i__ - ll + nm13] = -sinl;
/* L150: */
}
e[ll] = f;
/* Test convergence */
if ((d__1 = e[ll], abs(d__1)) <= thresh) {
e[ll] = 0.;
}
/* Update singular vectors if desired */
if (*ncvt > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "B", &i__1, ncvt, &rwork[nm12 + 1], &rwork[
nm13 + 1], &vt_ref(ll, 1), ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
zlasr_("R", "V", "B", nru, &i__1, &rwork[1], &rwork[*n], &
u_ref(1, ll), ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
zlasr_("L", "V", "B", &i__1, ncc, &rwork[1], &rwork[*n], &
c___ref(ll, 1), ldc);
}
}
}
/* QR iteration finished, go back and check convergence */
goto L60;
/* All singular values converged, so make them positive */
L160:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] < 0.) {
d__[i__] = -d__[i__];
/* Change sign of singular vectors, if desired */
if (*ncvt > 0) {
zdscal_(ncvt, &c_b72, &vt_ref(i__, 1), ldvt);
}
}
/* L170: */
}
/* Sort the singular values into decreasing order (insertion sort on
singular values, but only one transposition per singular vector) */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Scan for smallest D(I) */
isub = 1;
smin = d__[1];
i__2 = *n + 1 - i__;
for (j = 2; j <= i__2; ++j) {
if (d__[j] <= smin) {
isub = j;
smin = d__[j];
}
/* L180: */
}
if (isub != *n + 1 - i__) {
/* Swap singular values and vectors */
d__[isub] = d__[*n + 1 - i__];
d__[*n + 1 - i__] = smin;
if (*ncvt > 0) {
zswap_(ncvt, &vt_ref(isub, 1), ldvt, &vt_ref(*n + 1 - i__, 1),
ldvt);
}
if (*nru > 0) {
zswap_(nru, &u_ref(1, isub), &c__1, &u_ref(1, *n + 1 - i__), &
c__1);
}
if (*ncc > 0) {
zswap_(ncc, &c___ref(isub, 1), ldc, &c___ref(*n + 1 - i__, 1),
ldc);
}
}
/* L190: */
}
goto L220;
/* Maximum number of iterations exceeded, failure to converge */
L200:
*info = 0;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.) {
++(*info);
}
/* L210: */
}
L220:
return 0;
/* End of ZBDSQR */
} /* zbdsqr_ */
/* Subroutine */ int dbdsqr_(char *uplo, integer *n, integer *ncvt, integer *
nru, integer *ncc, doublereal *d__, doublereal *e, doublereal *vt,
integer *ldvt, doublereal *u, integer *ldu, doublereal *c__, integer *
ldc, doublereal *work, integer *info)
{
/* System generated locals */
integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
i__2;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *), sqrt(doublereal), d_sign(
doublereal *, doublereal *);
/* Local variables */
doublereal f, g, h__;
integer i__, j, m;
doublereal r__, cs;
integer ll;
doublereal sn, mu;
integer nm1, nm12, nm13, lll;
doublereal eps, sll, tol, abse;
integer idir;
doublereal abss;
integer oldm;
doublereal cosl;
integer isub, iter;
doublereal unfl, sinl, cosr, smin, smax, sinr;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *), dlas2_(
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
doublereal oldcs;
extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *);
integer oldll;
doublereal shift, sigmn, oldsn;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *);
integer maxit;
doublereal sminl, sigmx;
logical lower;
extern /* Subroutine */ int dlasq1_(integer *, doublereal *, doublereal *,
doublereal *, integer *), dlasv2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *), xerbla_(char *,
integer *);
doublereal sminoa, thresh;
logical rotate;
doublereal tolmul;
/* -- LAPACK routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DBDSQR computes the singular values and, optionally, the right and/or */
/* left singular vectors from the singular value decomposition (SVD) of */
/* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit */
/* zero-shift QR algorithm. The SVD of B has the form */
/* B = Q * S * P**T */
/* where S is the diagonal matrix of singular values, Q is an orthogonal */
/* matrix of left singular vectors, and P is an orthogonal matrix of */
/* right singular vectors. If left singular vectors are requested, this */
/* subroutine actually returns U*Q instead of Q, and, if right singular */
/* vectors are requested, this subroutine returns P**T*VT instead of */
/* P**T, for given real input matrices U and VT. When U and VT are the */
/* orthogonal matrices that reduce a general matrix A to bidiagonal */
/* form: A = U*B*VT, as computed by DGEBRD, then */
/* A = (U*Q) * S * (P**T*VT) */
/* is the SVD of A. Optionally, the subroutine may also compute Q**T*C */
/* for a given real input matrix C. */
/* See "Computing Small Singular Values of Bidiagonal Matrices With */
/* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, */
/* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, */
/* no. 5, pp. 873-912, Sept 1990) and */
/* "Accurate singular values and differential qd algorithms," by */
/* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics */
/* Department, University of California at Berkeley, July 1992 */
/* for a detailed description of the algorithm. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': B is upper bidiagonal; */
/* = 'L': B is lower bidiagonal. */
/* N (input) INTEGER */
/* The order of the matrix B. N >= 0. */
/* NCVT (input) INTEGER */
/* The number of columns of the matrix VT. NCVT >= 0. */
/* NRU (input) INTEGER */
/* The number of rows of the matrix U. NRU >= 0. */
/* NCC (input) INTEGER */
/* The number of columns of the matrix C. NCC >= 0. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the n diagonal elements of the bidiagonal matrix B. */
/* On exit, if INFO=0, the singular values of B in decreasing */
/* order. */
/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
/* On entry, the N-1 offdiagonal elements of the bidiagonal */
/* matrix B. */
/* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E */
/* will contain the diagonal and superdiagonal elements of a */
/* bidiagonal matrix orthogonally equivalent to the one given */
/* as input. */
/* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) */
/* On entry, an N-by-NCVT matrix VT. */
/* On exit, VT is overwritten by P**T * VT. */
/* Not referenced if NCVT = 0. */
/* LDVT (input) INTEGER */
/* The leading dimension of the array VT. */
/* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. */
/* U (input/output) DOUBLE PRECISION array, dimension (LDU, N) */
/* On entry, an NRU-by-N matrix U. */
/* On exit, U is overwritten by U * Q. */
/* Not referenced if NRU = 0. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= max(1,NRU). */
/* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) */
/* On entry, an N-by-NCC matrix C. */
/* On exit, C is overwritten by Q**T * C. */
/* Not referenced if NCC = 0. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. */
/* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
/* if NCVT = NRU = NCC = 0, (max(1, 4*N)) otherwise */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: If INFO = -i, the i-th argument had an illegal value */
/* > 0: the algorithm did not converge; D and E contain the */
/* elements of a bidiagonal matrix which is orthogonally */
/* similar to the input matrix B; if INFO = i, i */
/* elements of E have not converged to zero. */
/* Internal Parameters */
/* =================== */
/* TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8))) */
/* TOLMUL controls the convergence criterion of the QR loop. */
/* If it is positive, TOLMUL*EPS is the desired relative */
/* precision in the computed singular values. */
/* If it is negative, abs(TOLMUL*EPS*sigma_max) is the */
/* desired absolute accuracy in the computed singular */
/* values (corresponds to relative accuracy */
/* abs(TOLMUL*EPS) in the largest singular value. */
/* abs(TOLMUL) should be between 1 and 1/EPS, and preferably */
/* between 10 (for fast convergence) and .1/EPS */
/* (for there to be some accuracy in the results). */
/* Default is to lose at either one eighth or 2 of the */
/* available decimal digits in each computed singular value */
/* (whichever is smaller). */
/* MAXITR INTEGER, default = 6 */
/* MAXITR controls the maximum number of passes of the */
/* algorithm through its inner loop. The algorithms stops */
/* (and so fails to converge) if the number of passes */
/* through the inner loop exceeds MAXITR*N**2. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
lower = lsame_(uplo, "L");
if (! lsame_(uplo, "U") && ! lower) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ncvt < 0) {
*info = -3;
} else if (*nru < 0) {
*info = -4;
} else if (*ncc < 0) {
*info = -5;
} else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1,*n)) {
*info = -9;
} else if (*ldu < max(1,*nru)) {
*info = -11;
} else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1,*n)) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DBDSQR", &i__1);
return 0;
}
if (*n == 0) {
return 0;
}
if (*n == 1) {
goto L160;
}
/* ROTATE is true if any singular vectors desired, false otherwise */
rotate = *ncvt > 0 || *nru > 0 || *ncc > 0;
/* If no singular vectors desired, use qd algorithm */
if (! rotate) {
dlasq1_(n, &d__[1], &e[1], &work[1], info);
return 0;
}
nm1 = *n - 1;
nm12 = nm1 + nm1;
nm13 = nm12 + nm1;
idir = 0;
/* Get machine constants */
eps = dlamch_("Epsilon");
unfl = dlamch_("Safe minimum");
/* If matrix lower bidiagonal, rotate to be upper bidiagonal */
/* by applying Givens rotations on the left */
if (lower) {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
work[i__] = cs;
work[nm1 + i__] = sn;
/* L10: */
}
/* Update singular vectors if desired */
if (*nru > 0) {
dlasr_("R", "V", "F", nru, n, &work[1], &work[*n], &u[u_offset],
ldu);
}
if (*ncc > 0) {
dlasr_("L", "V", "F", n, ncc, &work[1], &work[*n], &c__[c_offset],
ldc);
}
}
/* Compute singular values to relative accuracy TOL */
/* (By setting TOL to be negative, algorithm will compute */
/* singular values to absolute accuracy ABS(TOL)*norm(input matrix)) */
/* Computing MAX */
/* Computing MIN */
d__3 = 100., d__4 = pow_dd(&eps, &c_b15);
d__1 = 10., d__2 = min(d__3,d__4);
tolmul = max(d__1,d__2);
tol = tolmul * eps;
/* Compute approximate maximum, minimum singular values */
smax = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = smax, d__3 = (d__1 = d__[i__], abs(d__1));
smax = max(d__2,d__3);
/* L20: */
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = smax, d__3 = (d__1 = e[i__], abs(d__1));
smax = max(d__2,d__3);
/* L30: */
}
sminl = 0.;
if (tol >= 0.) {
/* Relative accuracy desired */
sminoa = abs(d__[1]);
if (sminoa == 0.) {
goto L50;
}
mu = sminoa;
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
mu = (d__2 = d__[i__], abs(d__2)) * (mu / (mu + (d__1 = e[i__ - 1]
, abs(d__1))));
sminoa = min(sminoa,mu);
if (sminoa == 0.) {
goto L50;
}
/* L40: */
}
L50:
sminoa /= sqrt((doublereal) (*n));
/* Computing MAX */
d__1 = tol * sminoa, d__2 = *n * 6 * *n * unfl;
thresh = max(d__1,d__2);
} else {
/* Absolute accuracy desired */
/* Computing MAX */
d__1 = abs(tol) * smax, d__2 = *n * 6 * *n * unfl;
thresh = max(d__1,d__2);
}
/* Prepare for main iteration loop for the singular values */
/* (MAXIT is the maximum number of passes through the inner */
/* loop permitted before nonconvergence signalled.) */
maxit = *n * 6 * *n;
iter = 0;
oldll = -1;
oldm = -1;
/* M points to last element of unconverged part of matrix */
m = *n;
/* Begin main iteration loop */
L60:
/* Check for convergence or exceeding iteration count */
if (m <= 1) {
goto L160;
}
if (iter > maxit) {
goto L200;
}
/* Find diagonal block of matrix to work on */
if (tol < 0. && (d__1 = d__[m], abs(d__1)) <= thresh) {
d__[m] = 0.;
}
smax = (d__1 = d__[m], abs(d__1));
smin = smax;
i__1 = m - 1;
for (lll = 1; lll <= i__1; ++lll) {
ll = m - lll;
abss = (d__1 = d__[ll], abs(d__1));
abse = (d__1 = e[ll], abs(d__1));
if (tol < 0. && abss <= thresh) {
d__[ll] = 0.;
}
if (abse <= thresh) {
goto L80;
}
smin = min(smin,abss);
/* Computing MAX */
d__1 = max(smax,abss);
smax = max(d__1,abse);
/* L70: */
}
ll = 0;
goto L90;
L80:
e[ll] = 0.;
/* Matrix splits since E(LL) = 0 */
if (ll == m - 1) {
/* Convergence of bottom singular value, return to top of loop */
--m;
goto L60;
}
L90:
++ll;
/* E(LL) through E(M-1) are nonzero, E(LL-1) is zero */
if (ll == m - 1) {
/* 2 by 2 block, handle separately */
dlasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr,
&sinl, &cosl);
d__[m - 1] = sigmx;
e[m - 1] = 0.;
d__[m] = sigmn;
/* Compute singular vectors, if desired */
if (*ncvt > 0) {
drot_(ncvt, &vt[m - 1 + vt_dim1], ldvt, &vt[m + vt_dim1], ldvt, &
cosr, &sinr);
}
if (*nru > 0) {
drot_(nru, &u[(m - 1) * u_dim1 + 1], &c__1, &u[m * u_dim1 + 1], &
c__1, &cosl, &sinl);
}
if (*ncc > 0) {
drot_(ncc, &c__[m - 1 + c_dim1], ldc, &c__[m + c_dim1], ldc, &
cosl, &sinl);
}
m += -2;
goto L60;
}
/* If working on new submatrix, choose shift direction */
/* (from larger end diagonal element towards smaller) */
if (ll > oldm || m < oldll) {
if ((d__1 = d__[ll], abs(d__1)) >= (d__2 = d__[m], abs(d__2))) {
/* Chase bulge from top (big end) to bottom (small end) */
idir = 1;
} else {
/* Chase bulge from bottom (big end) to top (small end) */
idir = 2;
}
}
/* Apply convergence tests */
if (idir == 1) {
/* Run convergence test in forward direction */
/* First apply standard test to bottom of matrix */
if ((d__2 = e[m - 1], abs(d__2)) <= abs(tol) * (d__1 = d__[m], abs(
d__1)) || tol < 0. && (d__3 = e[m - 1], abs(d__3)) <= thresh)
{
e[m - 1] = 0.;
goto L60;
}
if (tol >= 0.) {
/* If relative accuracy desired, */
/* apply convergence criterion forward */
mu = (d__1 = d__[ll], abs(d__1));
sminl = mu;
i__1 = m - 1;
for (lll = ll; lll <= i__1; ++lll) {
if ((d__1 = e[lll], abs(d__1)) <= tol * mu) {
e[lll] = 0.;
goto L60;
}
mu = (d__2 = d__[lll + 1], abs(d__2)) * (mu / (mu + (d__1 = e[
lll], abs(d__1))));
sminl = min(sminl,mu);
/* L100: */
}
}
} else {
/* Run convergence test in backward direction */
/* First apply standard test to top of matrix */
if ((d__2 = e[ll], abs(d__2)) <= abs(tol) * (d__1 = d__[ll], abs(d__1)
) || tol < 0. && (d__3 = e[ll], abs(d__3)) <= thresh) {
e[ll] = 0.;
goto L60;
}
if (tol >= 0.) {
/* If relative accuracy desired, */
/* apply convergence criterion backward */
mu = (d__1 = d__[m], abs(d__1));
sminl = mu;
i__1 = ll;
for (lll = m - 1; lll >= i__1; --lll) {
if ((d__1 = e[lll], abs(d__1)) <= tol * mu) {
e[lll] = 0.;
goto L60;
}
mu = (d__2 = d__[lll], abs(d__2)) * (mu / (mu + (d__1 = e[lll]
, abs(d__1))));
sminl = min(sminl,mu);
/* L110: */
}
}
}
oldll = ll;
oldm = m;
/* Compute shift. First, test if shifting would ruin relative */
/* accuracy, and if so set the shift to zero. */
/* Computing MAX */
d__1 = eps, d__2 = tol * .01;
if (tol >= 0. && *n * tol * (sminl / smax) <= max(d__1,d__2)) {
/* Use a zero shift to avoid loss of relative accuracy */
shift = 0.;
} else {
/* Compute the shift from 2-by-2 block at end of matrix */
if (idir == 1) {
sll = (d__1 = d__[ll], abs(d__1));
dlas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__);
} else {
sll = (d__1 = d__[m], abs(d__1));
dlas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__);
}
/* Test if shift negligible, and if so set to zero */
if (sll > 0.) {
/* Computing 2nd power */
d__1 = shift / sll;
if (d__1 * d__1 < eps) {
shift = 0.;
}
}
}
/* Increment iteration count */
iter = iter + m - ll;
/* If SHIFT = 0, do simplified QR iteration */
if (shift == 0.) {
if (idir == 1) {
/* Chase bulge from top to bottom */
/* Save cosines and sines for later singular vector updates */
cs = 1.;
oldcs = 1.;
i__1 = m - 1;
for (i__ = ll; i__ <= i__1; ++i__) {
d__1 = d__[i__] * cs;
dlartg_(&d__1, &e[i__], &cs, &sn, &r__);
if (i__ > ll) {
e[i__ - 1] = oldsn * r__;
}
d__1 = oldcs * r__;
d__2 = d__[i__ + 1] * sn;
dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
work[i__ - ll + 1] = cs;
work[i__ - ll + 1 + nm1] = sn;
work[i__ - ll + 1 + nm12] = oldcs;
work[i__ - ll + 1 + nm13] = oldsn;
/* L120: */
}
h__ = d__[m] * cs;
d__[m] = h__ * oldcs;
e[m - 1] = h__ * oldsn;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[
ll + vt_dim1], ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
dlasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13
+ 1], &u[ll * u_dim1 + 1], ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13
+ 1], &c__[ll + c_dim1], ldc);
}
/* Test convergence */
if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
e[m - 1] = 0.;
}
} else {
/* Chase bulge from bottom to top */
/* Save cosines and sines for later singular vector updates */
cs = 1.;
oldcs = 1.;
i__1 = ll + 1;
for (i__ = m; i__ >= i__1; --i__) {
d__1 = d__[i__] * cs;
dlartg_(&d__1, &e[i__ - 1], &cs, &sn, &r__);
if (i__ < m) {
e[i__] = oldsn * r__;
}
d__1 = oldcs * r__;
d__2 = d__[i__ - 1] * sn;
dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
work[i__ - ll] = cs;
work[i__ - ll + nm1] = -sn;
work[i__ - ll + nm12] = oldcs;
work[i__ - ll + nm13] = -oldsn;
/* L130: */
}
h__ = d__[ll] * cs;
d__[ll] = h__ * oldcs;
e[ll] = h__ * oldsn;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[
nm13 + 1], &vt[ll + vt_dim1], ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
dlasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll *
u_dim1 + 1], ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &c__[
ll + c_dim1], ldc);
}
/* Test convergence */
if ((d__1 = e[ll], abs(d__1)) <= thresh) {
e[ll] = 0.;
}
}
} else {
/* Use nonzero shift */
if (idir == 1) {
/* Chase bulge from top to bottom */
/* Save cosines and sines for later singular vector updates */
f = ((d__1 = d__[ll], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[
ll]) + shift / d__[ll]);
g = e[ll];
i__1 = m - 1;
for (i__ = ll; i__ <= i__1; ++i__) {
dlartg_(&f, &g, &cosr, &sinr, &r__);
if (i__ > ll) {
e[i__ - 1] = r__;
}
f = cosr * d__[i__] + sinr * e[i__];
e[i__] = cosr * e[i__] - sinr * d__[i__];
g = sinr * d__[i__ + 1];
d__[i__ + 1] = cosr * d__[i__ + 1];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[i__] = r__;
f = cosl * e[i__] + sinl * d__[i__ + 1];
d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__];
if (i__ < m - 1) {
g = sinl * e[i__ + 1];
e[i__ + 1] = cosl * e[i__ + 1];
}
work[i__ - ll + 1] = cosr;
work[i__ - ll + 1 + nm1] = sinr;
work[i__ - ll + 1 + nm12] = cosl;
work[i__ - ll + 1 + nm13] = sinl;
/* L140: */
}
e[m - 1] = f;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[
ll + vt_dim1], ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
dlasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13
+ 1], &u[ll * u_dim1 + 1], ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13
+ 1], &c__[ll + c_dim1], ldc);
}
/* Test convergence */
if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
e[m - 1] = 0.;
}
} else {
/* Chase bulge from bottom to top */
/* Save cosines and sines for later singular vector updates */
f = ((d__1 = d__[m], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[m]
) + shift / d__[m]);
g = e[m - 1];
i__1 = ll + 1;
for (i__ = m; i__ >= i__1; --i__) {
dlartg_(&f, &g, &cosr, &sinr, &r__);
if (i__ < m) {
e[i__] = r__;
}
f = cosr * d__[i__] + sinr * e[i__ - 1];
e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__];
g = sinr * d__[i__ - 1];
d__[i__ - 1] = cosr * d__[i__ - 1];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[i__] = r__;
f = cosl * e[i__ - 1] + sinl * d__[i__ - 1];
d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1];
if (i__ > ll + 1) {
g = sinl * e[i__ - 2];
e[i__ - 2] = cosl * e[i__ - 2];
}
work[i__ - ll] = cosr;
work[i__ - ll + nm1] = -sinr;
work[i__ - ll + nm12] = cosl;
work[i__ - ll + nm13] = -sinl;
/* L150: */
}
e[ll] = f;
/* Test convergence */
if ((d__1 = e[ll], abs(d__1)) <= thresh) {
e[ll] = 0.;
}
/* Update singular vectors if desired */
if (*ncvt > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[
nm13 + 1], &vt[ll + vt_dim1], ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
dlasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll *
u_dim1 + 1], ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &c__[
ll + c_dim1], ldc);
}
}
}
/* QR iteration finished, go back and check convergence */
goto L60;
/* All singular values converged, so make them positive */
L160:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] < 0.) {
d__[i__] = -d__[i__];
/* Change sign of singular vectors, if desired */
if (*ncvt > 0) {
dscal_(ncvt, &c_b72, &vt[i__ + vt_dim1], ldvt);
}
}
/* L170: */
}
/* Sort the singular values into decreasing order (insertion sort on */
/* singular values, but only one transposition per singular vector) */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Scan for smallest D(I) */
isub = 1;
smin = d__[1];
i__2 = *n + 1 - i__;
for (j = 2; j <= i__2; ++j) {
if (d__[j] <= smin) {
isub = j;
smin = d__[j];
}
/* L180: */
}
if (isub != *n + 1 - i__) {
/* Swap singular values and vectors */
d__[isub] = d__[*n + 1 - i__];
d__[*n + 1 - i__] = smin;
if (*ncvt > 0) {
dswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[*n + 1 - i__ +
vt_dim1], ldvt);
}
if (*nru > 0) {
dswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[(*n + 1 - i__) *
u_dim1 + 1], &c__1);
}
if (*ncc > 0) {
dswap_(ncc, &c__[isub + c_dim1], ldc, &c__[*n + 1 - i__ +
c_dim1], ldc);
}
}
/* L190: */
}
goto L220;
/* Maximum number of iterations exceeded, failure to converge */
L200:
*info = 0;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.) {
++(*info);
}
/* L210: */
}
L220:
return 0;
/* End of DBDSQR */
} /* dbdsqr_ */
/* Subroutine */ int dlagv2_(doublereal *a, integer *lda, doublereal *b,
integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *
beta, doublereal *csl, doublereal *snl, doublereal *csr, doublereal *
snr)
{
/* -- 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
=======
DLAGV2 computes the Generalized Schur factorization of a real 2-by-2
matrix pencil (A,B) where B is upper triangular. This routine
computes orthogonal (rotation) matrices given by CSL, SNL and CSR,
SNR such that
1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0
types), then
[ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]
[ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]
[ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]
[ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ],
2) if the pencil (A,B) has a pair of complex conjugate eigenvalues,
then
[ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]
[ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]
[ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]
[ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ]
where b11 >= b22 > 0.
Arguments
=========
A (input/output) DOUBLE PRECISION array, dimension (LDA, 2)
On entry, the 2 x 2 matrix A.
On exit, A is overwritten by the ``A-part'' of the
generalized Schur form.
LDA (input) INTEGER
THe leading dimension of the array A. LDA >= 2.
B (input/output) DOUBLE PRECISION array, dimension (LDB, 2)
On entry, the upper triangular 2 x 2 matrix B.
On exit, B is overwritten by the ``B-part'' of the
generalized Schur form.
LDB (input) INTEGER
THe leading dimension of the array B. LDB >= 2.
ALPHAR (output) DOUBLE PRECISION array, dimension (2)
ALPHAI (output) DOUBLE PRECISION array, dimension (2)
BETA (output) DOUBLE PRECISION array, dimension (2)
(ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the
pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may
be zero.
CSL (output) DOUBLE PRECISION
The cosine of the left rotation matrix.
SNL (output) DOUBLE PRECISION
The sine of the left rotation matrix.
CSR (output) DOUBLE PRECISION
The cosine of the right rotation matrix.
SNR (output) DOUBLE PRECISION
The sine of the right rotation matrix.
Further Details
===============
Based on contributions by
Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__2 = 2;
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
/* Local variables */
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *), dlag2_(
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
static doublereal r__, t, anorm, bnorm, h1, h2, h3, scale1, scale2;
extern /* Subroutine */ int dlasv2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
extern doublereal dlapy2_(doublereal *, doublereal *);
static doublereal ascale, bscale;
extern doublereal dlamch_(char *);
static doublereal wi, qq, rr, safmin;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
static doublereal wr1, wr2, ulp;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--alphar;
--alphai;
--beta;
/* Function Body */
safmin = dlamch_("S");
ulp = dlamch_("P");
/* Scale A
Computing MAX */
d__5 = (d__1 = a_ref(1, 1), abs(d__1)) + (d__2 = a_ref(2, 1), abs(d__2)),
d__6 = (d__3 = a_ref(1, 2), abs(d__3)) + (d__4 = a_ref(2, 2), abs(
d__4)), d__5 = max(d__5,d__6);
anorm = max(d__5,safmin);
ascale = 1. / anorm;
a_ref(1, 1) = ascale * a_ref(1, 1);
a_ref(1, 2) = ascale * a_ref(1, 2);
a_ref(2, 1) = ascale * a_ref(2, 1);
a_ref(2, 2) = ascale * a_ref(2, 2);
/* Scale B
Computing MAX */
d__4 = (d__3 = b_ref(1, 1), abs(d__3)), d__5 = (d__1 = b_ref(1, 2), abs(
d__1)) + (d__2 = b_ref(2, 2), abs(d__2)), d__4 = max(d__4,d__5);
bnorm = max(d__4,safmin);
bscale = 1. / bnorm;
b_ref(1, 1) = bscale * b_ref(1, 1);
b_ref(1, 2) = bscale * b_ref(1, 2);
b_ref(2, 2) = bscale * b_ref(2, 2);
/* Check if A can be deflated */
if ((d__1 = a_ref(2, 1), abs(d__1)) <= ulp) {
*csl = 1.;
*snl = 0.;
*csr = 1.;
*snr = 0.;
a_ref(2, 1) = 0.;
b_ref(2, 1) = 0.;
/* Check if B is singular */
} else if ((d__1 = b_ref(1, 1), abs(d__1)) <= ulp) {
dlartg_(&a_ref(1, 1), &a_ref(2, 1), csl, snl, &r__);
*csr = 1.;
*snr = 0.;
drot_(&c__2, &a_ref(1, 1), lda, &a_ref(2, 1), lda, csl, snl);
drot_(&c__2, &b_ref(1, 1), ldb, &b_ref(2, 1), ldb, csl, snl);
a_ref(2, 1) = 0.;
b_ref(1, 1) = 0.;
b_ref(2, 1) = 0.;
} else if ((d__1 = b_ref(2, 2), abs(d__1)) <= ulp) {
dlartg_(&a_ref(2, 2), &a_ref(2, 1), csr, snr, &t);
*snr = -(*snr);
drot_(&c__2, &a_ref(1, 1), &c__1, &a_ref(1, 2), &c__1, csr, snr);
drot_(&c__2, &b_ref(1, 1), &c__1, &b_ref(1, 2), &c__1, csr, snr);
*csl = 1.;
*snl = 0.;
a_ref(2, 1) = 0.;
b_ref(2, 1) = 0.;
b_ref(2, 2) = 0.;
} else {
/* B is nonsingular, first compute the eigenvalues of (A,B) */
dlag2_(&a[a_offset], lda, &b[b_offset], ldb, &safmin, &scale1, &
scale2, &wr1, &wr2, &wi);
if (wi == 0.) {
/* two real eigenvalues, compute s*A-w*B */
h1 = scale1 * a_ref(1, 1) - wr1 * b_ref(1, 1);
h2 = scale1 * a_ref(1, 2) - wr1 * b_ref(1, 2);
h3 = scale1 * a_ref(2, 2) - wr1 * b_ref(2, 2);
rr = dlapy2_(&h1, &h2);
d__1 = scale1 * a_ref(2, 1);
qq = dlapy2_(&d__1, &h3);
if (rr > qq) {
/* find right rotation matrix to zero 1,1 element of
(sA - wB) */
dlartg_(&h2, &h1, csr, snr, &t);
} else {
/* find right rotation matrix to zero 2,1 element of
(sA - wB) */
d__1 = scale1 * a_ref(2, 1);
dlartg_(&h3, &d__1, csr, snr, &t);
}
*snr = -(*snr);
drot_(&c__2, &a_ref(1, 1), &c__1, &a_ref(1, 2), &c__1, csr, snr);
drot_(&c__2, &b_ref(1, 1), &c__1, &b_ref(1, 2), &c__1, csr, snr);
/* compute inf norms of A and B
Computing MAX */
d__5 = (d__1 = a_ref(1, 1), abs(d__1)) + (d__2 = a_ref(1, 2), abs(
d__2)), d__6 = (d__3 = a_ref(2, 1), abs(d__3)) + (d__4 =
a_ref(2, 2), abs(d__4));
h1 = max(d__5,d__6);
/* Computing MAX */
d__5 = (d__1 = b_ref(1, 1), abs(d__1)) + (d__2 = b_ref(1, 2), abs(
d__2)), d__6 = (d__3 = b_ref(2, 1), abs(d__3)) + (d__4 =
b_ref(2, 2), abs(d__4));
h2 = max(d__5,d__6);
if (scale1 * h1 >= abs(wr1) * h2) {
/* find left rotation matrix Q to zero out B(2,1) */
dlartg_(&b_ref(1, 1), &b_ref(2, 1), csl, snl, &r__);
} else {
/* find left rotation matrix Q to zero out A(2,1) */
dlartg_(&a_ref(1, 1), &a_ref(2, 1), csl, snl, &r__);
}
drot_(&c__2, &a_ref(1, 1), lda, &a_ref(2, 1), lda, csl, snl);
drot_(&c__2, &b_ref(1, 1), ldb, &b_ref(2, 1), ldb, csl, snl);
a_ref(2, 1) = 0.;
b_ref(2, 1) = 0.;
} else {
/* a pair of complex conjugate eigenvalues
first compute the SVD of the matrix B */
dlasv2_(&b_ref(1, 1), &b_ref(1, 2), &b_ref(2, 2), &r__, &t, snr,
csr, snl, csl);
/* Form (A,B) := Q(A,B)Z' where Q is left rotation matrix and
Z is right rotation matrix computed from DLASV2 */
drot_(&c__2, &a_ref(1, 1), lda, &a_ref(2, 1), lda, csl, snl);
drot_(&c__2, &b_ref(1, 1), ldb, &b_ref(2, 1), ldb, csl, snl);
drot_(&c__2, &a_ref(1, 1), &c__1, &a_ref(1, 2), &c__1, csr, snr);
drot_(&c__2, &b_ref(1, 1), &c__1, &b_ref(1, 2), &c__1, csr, snr);
b_ref(2, 1) = 0.;
b_ref(1, 2) = 0.;
}
}
/* Unscaling */
a_ref(1, 1) = anorm * a_ref(1, 1);
a_ref(2, 1) = anorm * a_ref(2, 1);
a_ref(1, 2) = anorm * a_ref(1, 2);
a_ref(2, 2) = anorm * a_ref(2, 2);
b_ref(1, 1) = bnorm * b_ref(1, 1);
b_ref(2, 1) = bnorm * b_ref(2, 1);
b_ref(1, 2) = bnorm * b_ref(1, 2);
b_ref(2, 2) = bnorm * b_ref(2, 2);
if (wi == 0.) {
alphar[1] = a_ref(1, 1);
alphar[2] = a_ref(2, 2);
alphai[1] = 0.;
alphai[2] = 0.;
beta[1] = b_ref(1, 1);
beta[2] = b_ref(2, 2);
} else {
alphar[1] = anorm * wr1 / scale1 / bnorm;
alphai[1] = anorm * wi / scale1 / bnorm;
alphar[2] = alphar[1];
alphai[2] = -alphai[1];
beta[1] = 1.;
beta[2] = 1.;
}
/* L10: */
return 0;
/* End of DLAGV2 */
} /* dlagv2_ */
int zlags2_(int *upper, double *a1, doublecomplex *
a2, double *a3, double *b1, doublecomplex *b2, double *b3,
double *csu, doublecomplex *snu, double *csv, doublecomplex *
snv, double *csq, doublecomplex *snq)
{
/* System generated locals */
double d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8;
doublecomplex z__1, z__2, z__3, z__4, z__5;
/* Builtin functions */
double z_abs(doublecomplex *), d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
double a;
doublecomplex b, c__;
double d__;
doublecomplex r__, d1;
double s1, s2, fb, fc;
doublecomplex ua11, ua12, ua21, ua22, vb11, vb12, vb21, vb22;
double csl, csr, snl, snr, aua11, aua12, aua21, aua22, avb12, avb11,
avb21, avb22, ua11r, ua22r, vb11r, vb22r;
extern int dlasv2_(double *, double *,
double *, double *, double *, double *,
double *, double *, double *), zlartg_(doublecomplex *
, doublecomplex *, double *, doublecomplex *, doublecomplex *)
;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAGS2 computes 2-by-2 unitary matrices U, V and Q, such */
/* that if ( UPPER ) then */
/* U'*A*Q = U'*( A1 A2 )*Q = ( x 0 ) */
/* ( 0 A3 ) ( x x ) */
/* and */
/* V'*B*Q = V'*( B1 B2 )*Q = ( x 0 ) */
/* ( 0 B3 ) ( x x ) */
/* or if ( .NOT.UPPER ) then */
/* U'*A*Q = U'*( A1 0 )*Q = ( x x ) */
/* ( A2 A3 ) ( 0 x ) */
/* and */
/* V'*B*Q = V'*( B1 0 )*Q = ( x x ) */
/* ( B2 B3 ) ( 0 x ) */
/* where */
/* U = ( CSU SNU ), V = ( CSV SNV ), */
/* ( -CONJG(SNU) CSU ) ( -CONJG(SNV) CSV ) */
/* Q = ( CSQ SNQ ) */
/* ( -CONJG(SNQ) CSQ ) */
/* Z' denotes the conjugate transpose of Z. */
/* The rows of the transformed A and B are parallel. Moreover, if the */
/* input 2-by-2 matrix A is not zero, then the transformed (1,1) entry */
/* of A is not zero. If the input matrices A and B are both not zero, */
/* then the transformed (2,2) element of B is not zero, except when the */
/* first rows of input A and B are parallel and the second rows are */
/* zero. */
/* Arguments */
/* ========= */
/* UPPER (input) LOGICAL */
/* = .TRUE.: the input matrices A and B are upper triangular. */
/* = .FALSE.: the input matrices A and B are lower triangular. */
/* A1 (input) DOUBLE PRECISION */
/* A2 (input) COMPLEX*16 */
/* A3 (input) DOUBLE PRECISION */
/* On entry, A1, A2 and A3 are elements of the input 2-by-2 */
/* upper (lower) triangular matrix A. */
/* B1 (input) DOUBLE PRECISION */
/* B2 (input) COMPLEX*16 */
/* B3 (input) DOUBLE PRECISION */
/* On entry, B1, B2 and B3 are elements of the input 2-by-2 */
/* upper (lower) triangular matrix B. */
/* CSU (output) DOUBLE PRECISION */
/* SNU (output) COMPLEX*16 */
/* The desired unitary matrix U. */
/* CSV (output) DOUBLE PRECISION */
/* SNV (output) COMPLEX*16 */
/* The desired unitary matrix V. */
/* CSQ (output) DOUBLE PRECISION */
/* SNQ (output) COMPLEX*16 */
/* The desired unitary matrix Q. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
if (*upper) {
/* Input matrices A and B are upper triangular matrices */
/* Form matrix C = A*adj(B) = ( a b ) */
/* ( 0 d ) */
a = *a1 * *b3;
d__ = *a3 * *b1;
z__2.r = *b1 * a2->r, z__2.i = *b1 * a2->i;
z__3.r = *a1 * b2->r, z__3.i = *a1 * b2->i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
b.r = z__1.r, b.i = z__1.i;
fb = z_abs(&b);
/* Transform complex 2-by-2 matrix C to float matrix by unitary */
/* diagonal matrix diag(1,D1). */
d1.r = 1., d1.i = 0.;
if (fb != 0.) {
z__1.r = b.r / fb, z__1.i = b.i / fb;
d1.r = z__1.r, d1.i = z__1.i;
}
/* The SVD of float 2 by 2 triangular C */
/* ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 ) */
/* ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T ) */
dlasv2_(&a, &fb, &d__, &s1, &s2, &snr, &csr, &snl, &csl);
if (ABS(csl) >= ABS(snl) || ABS(csr) >= ABS(snr)) {
/* Compute the (1,1) and (1,2) elements of U'*A and V'*B, */
/* and (1,2) element of |U|'*|A| and |V|'*|B|. */
ua11r = csl * *a1;
z__2.r = csl * a2->r, z__2.i = csl * a2->i;
z__4.r = snl * d1.r, z__4.i = snl * d1.i;
z__3.r = *a3 * z__4.r, z__3.i = *a3 * z__4.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ua12.r = z__1.r, ua12.i = z__1.i;
vb11r = csr * *b1;
z__2.r = csr * b2->r, z__2.i = csr * b2->i;
z__4.r = snr * d1.r, z__4.i = snr * d1.i;
z__3.r = *b3 * z__4.r, z__3.i = *b3 * z__4.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
vb12.r = z__1.r, vb12.i = z__1.i;
aua12 = ABS(csl) * ((d__1 = a2->r, ABS(d__1)) + (d__2 = d_imag(a2)
, ABS(d__2))) + ABS(snl) * ABS(*a3);
avb12 = ABS(csr) * ((d__1 = b2->r, ABS(d__1)) + (d__2 = d_imag(b2)
, ABS(d__2))) + ABS(snr) * ABS(*b3);
/* zero (1,2) elements of U'*A and V'*B */
if (ABS(ua11r) + ((d__1 = ua12.r, ABS(d__1)) + (d__2 = d_imag(&
ua12), ABS(d__2))) == 0.) {
z__2.r = vb11r, z__2.i = 0.;
z__1.r = -z__2.r, z__1.i = -z__2.i;
d_cnjg(&z__3, &vb12);
zlartg_(&z__1, &z__3, csq, snq, &r__);
} else if (ABS(vb11r) + ((d__1 = vb12.r, ABS(d__1)) + (d__2 =
d_imag(&vb12), ABS(d__2))) == 0.) {
z__2.r = ua11r, z__2.i = 0.;
z__1.r = -z__2.r, z__1.i = -z__2.i;
d_cnjg(&z__3, &ua12);
zlartg_(&z__1, &z__3, csq, snq, &r__);
} else if (aua12 / (ABS(ua11r) + ((d__1 = ua12.r, ABS(d__1)) + (
d__2 = d_imag(&ua12), ABS(d__2)))) <= avb12 / (ABS(vb11r)
+ ((d__3 = vb12.r, ABS(d__3)) + (d__4 = d_imag(&vb12),
ABS(d__4))))) {
z__2.r = ua11r, z__2.i = 0.;
z__1.r = -z__2.r, z__1.i = -z__2.i;
d_cnjg(&z__3, &ua12);
zlartg_(&z__1, &z__3, csq, snq, &r__);
} else {
z__2.r = vb11r, z__2.i = 0.;
z__1.r = -z__2.r, z__1.i = -z__2.i;
d_cnjg(&z__3, &vb12);
zlartg_(&z__1, &z__3, csq, snq, &r__);
}
*csu = csl;
z__2.r = -d1.r, z__2.i = -d1.i;
z__1.r = snl * z__2.r, z__1.i = snl * z__2.i;
snu->r = z__1.r, snu->i = z__1.i;
*csv = csr;
z__2.r = -d1.r, z__2.i = -d1.i;
z__1.r = snr * z__2.r, z__1.i = snr * z__2.i;
snv->r = z__1.r, snv->i = z__1.i;
} else {
/* Compute the (2,1) and (2,2) elements of U'*A and V'*B, */
/* and (2,2) element of |U|'*|A| and |V|'*|B|. */
d_cnjg(&z__4, &d1);
z__3.r = -z__4.r, z__3.i = -z__4.i;
z__2.r = snl * z__3.r, z__2.i = snl * z__3.i;
z__1.r = *a1 * z__2.r, z__1.i = *a1 * z__2.i;
ua21.r = z__1.r, ua21.i = z__1.i;
d_cnjg(&z__5, &d1);
z__4.r = -z__5.r, z__4.i = -z__5.i;
z__3.r = snl * z__4.r, z__3.i = snl * z__4.i;
z__2.r = z__3.r * a2->r - z__3.i * a2->i, z__2.i = z__3.r * a2->i
+ z__3.i * a2->r;
d__1 = csl * *a3;
z__1.r = z__2.r + d__1, z__1.i = z__2.i;
ua22.r = z__1.r, ua22.i = z__1.i;
d_cnjg(&z__4, &d1);
z__3.r = -z__4.r, z__3.i = -z__4.i;
z__2.r = snr * z__3.r, z__2.i = snr * z__3.i;
z__1.r = *b1 * z__2.r, z__1.i = *b1 * z__2.i;
vb21.r = z__1.r, vb21.i = z__1.i;
d_cnjg(&z__5, &d1);
z__4.r = -z__5.r, z__4.i = -z__5.i;
z__3.r = snr * z__4.r, z__3.i = snr * z__4.i;
z__2.r = z__3.r * b2->r - z__3.i * b2->i, z__2.i = z__3.r * b2->i
+ z__3.i * b2->r;
d__1 = csr * *b3;
z__1.r = z__2.r + d__1, z__1.i = z__2.i;
vb22.r = z__1.r, vb22.i = z__1.i;
aua22 = ABS(snl) * ((d__1 = a2->r, ABS(d__1)) + (d__2 = d_imag(a2)
, ABS(d__2))) + ABS(csl) * ABS(*a3);
avb22 = ABS(snr) * ((d__1 = b2->r, ABS(d__1)) + (d__2 = d_imag(b2)
, ABS(d__2))) + ABS(csr) * ABS(*b3);
/* zero (2,2) elements of U'*A and V'*B, and then swap. */
if ((d__1 = ua21.r, ABS(d__1)) + (d__2 = d_imag(&ua21), ABS(d__2))
+ ((d__3 = ua22.r, ABS(d__3)) + (d__4 = d_imag(&ua22),
ABS(d__4))) == 0.) {
d_cnjg(&z__2, &vb21);
z__1.r = -z__2.r, z__1.i = -z__2.i;
d_cnjg(&z__3, &vb22);
zlartg_(&z__1, &z__3, csq, snq, &r__);
} else if ((d__1 = vb21.r, ABS(d__1)) + (d__2 = d_imag(&vb21),
ABS(d__2)) + z_abs(&vb22) == 0.) {
d_cnjg(&z__2, &ua21);
z__1.r = -z__2.r, z__1.i = -z__2.i;
d_cnjg(&z__3, &ua22);
zlartg_(&z__1, &z__3, csq, snq, &r__);
} else if (aua22 / ((d__1 = ua21.r, ABS(d__1)) + (d__2 = d_imag(&
ua21), ABS(d__2)) + ((d__3 = ua22.r, ABS(d__3)) + (d__4 =
d_imag(&ua22), ABS(d__4)))) <= avb22 / ((d__5 = vb21.r,
ABS(d__5)) + (d__6 = d_imag(&vb21), ABS(d__6)) + ((d__7 =
vb22.r, ABS(d__7)) + (d__8 = d_imag(&vb22), ABS(d__8)))))
{
d_cnjg(&z__2, &ua21);
z__1.r = -z__2.r, z__1.i = -z__2.i;
d_cnjg(&z__3, &ua22);
zlartg_(&z__1, &z__3, csq, snq, &r__);
} else {
d_cnjg(&z__2, &vb21);
z__1.r = -z__2.r, z__1.i = -z__2.i;
d_cnjg(&z__3, &vb22);
zlartg_(&z__1, &z__3, csq, snq, &r__);
}
*csu = snl;
z__1.r = csl * d1.r, z__1.i = csl * d1.i;
snu->r = z__1.r, snu->i = z__1.i;
*csv = snr;
z__1.r = csr * d1.r, z__1.i = csr * d1.i;
snv->r = z__1.r, snv->i = z__1.i;
}
} else {
/* Input matrices A and B are lower triangular matrices */
/* Form matrix C = A*adj(B) = ( a 0 ) */
/* ( c d ) */
a = *a1 * *b3;
d__ = *a3 * *b1;
z__2.r = *b3 * a2->r, z__2.i = *b3 * a2->i;
z__3.r = *a3 * b2->r, z__3.i = *a3 * b2->i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
c__.r = z__1.r, c__.i = z__1.i;
fc = z_abs(&c__);
/* Transform complex 2-by-2 matrix C to float matrix by unitary */
/* diagonal matrix diag(d1,1). */
d1.r = 1., d1.i = 0.;
if (fc != 0.) {
z__1.r = c__.r / fc, z__1.i = c__.i / fc;
d1.r = z__1.r, d1.i = z__1.i;
}
/* The SVD of float 2 by 2 triangular C */
/* ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 ) */
/* ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T ) */
dlasv2_(&a, &fc, &d__, &s1, &s2, &snr, &csr, &snl, &csl);
if (ABS(csr) >= ABS(snr) || ABS(csl) >= ABS(snl)) {
/* Compute the (2,1) and (2,2) elements of U'*A and V'*B, */
/* and (2,1) element of |U|'*|A| and |V|'*|B|. */
z__4.r = -d1.r, z__4.i = -d1.i;
z__3.r = snr * z__4.r, z__3.i = snr * z__4.i;
z__2.r = *a1 * z__3.r, z__2.i = *a1 * z__3.i;
z__5.r = csr * a2->r, z__5.i = csr * a2->i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
ua21.r = z__1.r, ua21.i = z__1.i;
ua22r = csr * *a3;
z__4.r = -d1.r, z__4.i = -d1.i;
z__3.r = snl * z__4.r, z__3.i = snl * z__4.i;
z__2.r = *b1 * z__3.r, z__2.i = *b1 * z__3.i;
z__5.r = csl * b2->r, z__5.i = csl * b2->i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
vb21.r = z__1.r, vb21.i = z__1.i;
vb22r = csl * *b3;
aua21 = ABS(snr) * ABS(*a1) + ABS(csr) * ((d__1 = a2->r, ABS(d__1)
) + (d__2 = d_imag(a2), ABS(d__2)));
avb21 = ABS(snl) * ABS(*b1) + ABS(csl) * ((d__1 = b2->r, ABS(d__1)
) + (d__2 = d_imag(b2), ABS(d__2)));
/* zero (2,1) elements of U'*A and V'*B. */
if ((d__1 = ua21.r, ABS(d__1)) + (d__2 = d_imag(&ua21), ABS(d__2))
+ ABS(ua22r) == 0.) {
z__1.r = vb22r, z__1.i = 0.;
zlartg_(&z__1, &vb21, csq, snq, &r__);
} else if ((d__1 = vb21.r, ABS(d__1)) + (d__2 = d_imag(&vb21),
ABS(d__2)) + ABS(vb22r) == 0.) {
z__1.r = ua22r, z__1.i = 0.;
zlartg_(&z__1, &ua21, csq, snq, &r__);
} else if (aua21 / ((d__1 = ua21.r, ABS(d__1)) + (d__2 = d_imag(&
ua21), ABS(d__2)) + ABS(ua22r)) <= avb21 / ((d__3 =
vb21.r, ABS(d__3)) + (d__4 = d_imag(&vb21), ABS(d__4)) +
ABS(vb22r))) {
z__1.r = ua22r, z__1.i = 0.;
zlartg_(&z__1, &ua21, csq, snq, &r__);
} else {
z__1.r = vb22r, z__1.i = 0.;
zlartg_(&z__1, &vb21, csq, snq, &r__);
}
*csu = csr;
d_cnjg(&z__3, &d1);
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = snr * z__2.r, z__1.i = snr * z__2.i;
snu->r = z__1.r, snu->i = z__1.i;
*csv = csl;
d_cnjg(&z__3, &d1);
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = snl * z__2.r, z__1.i = snl * z__2.i;
snv->r = z__1.r, snv->i = z__1.i;
} else {
/* Compute the (1,1) and (1,2) elements of U'*A and V'*B, */
/* and (1,1) element of |U|'*|A| and |V|'*|B|. */
d__1 = csr * *a1;
d_cnjg(&z__4, &d1);
z__3.r = snr * z__4.r, z__3.i = snr * z__4.i;
z__2.r = z__3.r * a2->r - z__3.i * a2->i, z__2.i = z__3.r * a2->i
+ z__3.i * a2->r;
z__1.r = d__1 + z__2.r, z__1.i = z__2.i;
ua11.r = z__1.r, ua11.i = z__1.i;
d_cnjg(&z__3, &d1);
z__2.r = snr * z__3.r, z__2.i = snr * z__3.i;
z__1.r = *a3 * z__2.r, z__1.i = *a3 * z__2.i;
ua12.r = z__1.r, ua12.i = z__1.i;
d__1 = csl * *b1;
d_cnjg(&z__4, &d1);
z__3.r = snl * z__4.r, z__3.i = snl * z__4.i;
z__2.r = z__3.r * b2->r - z__3.i * b2->i, z__2.i = z__3.r * b2->i
+ z__3.i * b2->r;
z__1.r = d__1 + z__2.r, z__1.i = z__2.i;
vb11.r = z__1.r, vb11.i = z__1.i;
d_cnjg(&z__3, &d1);
z__2.r = snl * z__3.r, z__2.i = snl * z__3.i;
z__1.r = *b3 * z__2.r, z__1.i = *b3 * z__2.i;
vb12.r = z__1.r, vb12.i = z__1.i;
aua11 = ABS(csr) * ABS(*a1) + ABS(snr) * ((d__1 = a2->r, ABS(d__1)
) + (d__2 = d_imag(a2), ABS(d__2)));
avb11 = ABS(csl) * ABS(*b1) + ABS(snl) * ((d__1 = b2->r, ABS(d__1)
) + (d__2 = d_imag(b2), ABS(d__2)));
/* zero (1,1) elements of U'*A and V'*B, and then swap. */
if ((d__1 = ua11.r, ABS(d__1)) + (d__2 = d_imag(&ua11), ABS(d__2))
+ ((d__3 = ua12.r, ABS(d__3)) + (d__4 = d_imag(&ua12),
ABS(d__4))) == 0.) {
zlartg_(&vb12, &vb11, csq, snq, &r__);
} else if ((d__1 = vb11.r, ABS(d__1)) + (d__2 = d_imag(&vb11),
ABS(d__2)) + ((d__3 = vb12.r, ABS(d__3)) + (d__4 = d_imag(
&vb12), ABS(d__4))) == 0.) {
zlartg_(&ua12, &ua11, csq, snq, &r__);
} else if (aua11 / ((d__1 = ua11.r, ABS(d__1)) + (d__2 = d_imag(&
ua11), ABS(d__2)) + ((d__3 = ua12.r, ABS(d__3)) + (d__4 =
d_imag(&ua12), ABS(d__4)))) <= avb11 / ((d__5 = vb11.r,
ABS(d__5)) + (d__6 = d_imag(&vb11), ABS(d__6)) + ((d__7 =
vb12.r, ABS(d__7)) + (d__8 = d_imag(&vb12), ABS(d__8)))))
{
zlartg_(&ua12, &ua11, csq, snq, &r__);
} else {
zlartg_(&vb12, &vb11, csq, snq, &r__);
}
*csu = snr;
d_cnjg(&z__2, &d1);
z__1.r = csr * z__2.r, z__1.i = csr * z__2.i;
snu->r = z__1.r, snu->i = z__1.i;
*csv = snl;
d_cnjg(&z__2, &d1);
z__1.r = csl * z__2.r, z__1.i = csl * z__2.i;
snv->r = z__1.r, snv->i = z__1.i;
}
}
return 0;
/* End of ZLAGS2 */
} /* zlags2_ */
/* Subroutine */ int dlags2_(logical *upper, doublereal *a1, doublereal *a2,
doublereal *a3, doublereal *b1, doublereal *b2, doublereal *b3,
doublereal *csu, doublereal *snu, doublereal *csv, doublereal *snv,
doublereal *csq, doublereal *snq)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such
that if ( UPPER ) then
U'*A*Q = U'*( A1 A2 )*Q = ( x 0 )
( 0 A3 ) ( x x )
and
V'*B*Q = V'*( B1 B2 )*Q = ( x 0 )
( 0 B3 ) ( x x )
or if ( .NOT.UPPER ) then
U'*A*Q = U'*( A1 0 )*Q = ( x x )
( A2 A3 ) ( 0 x )
and
V'*B*Q = V'*( B1 0 )*Q = ( x x )
( B2 B3 ) ( 0 x )
The rows of the transformed A and B are parallel, where
U = ( CSU SNU ), V = ( CSV SNV ), Q = ( CSQ SNQ )
( -SNU CSU ) ( -SNV CSV ) ( -SNQ CSQ )
Z' denotes the transpose of Z.
Arguments
=========
UPPER (input) LOGICAL
= .TRUE.: the input matrices A and B are upper triangular.
= .FALSE.: the input matrices A and B are lower triangular.
A1 (input) DOUBLE PRECISION
A2 (input) DOUBLE PRECISION
A3 (input) DOUBLE PRECISION
On entry, A1, A2 and A3 are elements of the input 2-by-2
upper (lower) triangular matrix A.
B1 (input) DOUBLE PRECISION
B2 (input) DOUBLE PRECISION
B3 (input) DOUBLE PRECISION
On entry, B1, B2 and B3 are elements of the input 2-by-2
upper (lower) triangular matrix B.
CSU (output) DOUBLE PRECISION
SNU (output) DOUBLE PRECISION
The desired orthogonal matrix U.
CSV (output) DOUBLE PRECISION
SNV (output) DOUBLE PRECISION
The desired orthogonal matrix V.
CSQ (output) DOUBLE PRECISION
SNQ (output) DOUBLE PRECISION
The desired orthogonal matrix Q.
===================================================================== */
/* System generated locals */
doublereal d__1;
/* Local variables */
static doublereal aua11, aua12, aua21, aua22, avb11, avb12, avb21, avb22,
ua11r, ua22r, vb11r, vb22r, a, b, c__, d__, r__, s1, s2;
extern /* Subroutine */ int dlasv2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *), dlartg_(doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *);
static doublereal ua11, ua12, ua21, ua22, vb11, vb12, vb21, vb22, csl,
csr, snl, snr;
if (*upper) {
/* Input matrices A and B are upper triangular matrices
Form matrix C = A*adj(B) = ( a b )
( 0 d ) */
a = *a1 * *b3;
d__ = *a3 * *b1;
b = *a2 * *b1 - *a1 * *b2;
/* The SVD of real 2-by-2 triangular C
( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 )
( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T ) */
dlasv2_(&a, &b, &d__, &s1, &s2, &snr, &csr, &snl, &csl);
if (abs(csl) >= abs(snl) || abs(csr) >= abs(snr)) {
/* Compute the (1,1) and (1,2) elements of U'*A and V'*B,
and (1,2) element of |U|'*|A| and |V|'*|B|. */
ua11r = csl * *a1;
ua12 = csl * *a2 + snl * *a3;
vb11r = csr * *b1;
vb12 = csr * *b2 + snr * *b3;
aua12 = abs(csl) * abs(*a2) + abs(snl) * abs(*a3);
avb12 = abs(csr) * abs(*b2) + abs(snr) * abs(*b3);
/* zero (1,2) elements of U'*A and V'*B */
if (abs(ua11r) + abs(ua12) != 0.) {
if (aua12 / (abs(ua11r) + abs(ua12)) <= avb12 / (abs(vb11r) +
abs(vb12))) {
d__1 = -ua11r;
dlartg_(&d__1, &ua12, csq, snq, &r__);
} else {
d__1 = -vb11r;
dlartg_(&d__1, &vb12, csq, snq, &r__);
}
} else {
d__1 = -vb11r;
dlartg_(&d__1, &vb12, csq, snq, &r__);
}
*csu = csl;
*snu = -snl;
*csv = csr;
*snv = -snr;
} else {
/* Compute the (2,1) and (2,2) elements of U'*A and V'*B,
and (2,2) element of |U|'*|A| and |V|'*|B|. */
ua21 = -snl * *a1;
ua22 = -snl * *a2 + csl * *a3;
vb21 = -snr * *b1;
vb22 = -snr * *b2 + csr * *b3;
aua22 = abs(snl) * abs(*a2) + abs(csl) * abs(*a3);
avb22 = abs(snr) * abs(*b2) + abs(csr) * abs(*b3);
/* zero (2,2) elements of U'*A and V'*B, and then swap. */
if (abs(ua21) + abs(ua22) != 0.) {
if (aua22 / (abs(ua21) + abs(ua22)) <= avb22 / (abs(vb21) +
abs(vb22))) {
d__1 = -ua21;
dlartg_(&d__1, &ua22, csq, snq, &r__);
} else {
d__1 = -vb21;
dlartg_(&d__1, &vb22, csq, snq, &r__);
}
} else {
d__1 = -vb21;
dlartg_(&d__1, &vb22, csq, snq, &r__);
}
*csu = snl;
*snu = csl;
*csv = snr;
*snv = csr;
}
} else {
/* Input matrices A and B are lower triangular matrices
Form matrix C = A*adj(B) = ( a 0 )
( c d ) */
a = *a1 * *b3;
d__ = *a3 * *b1;
c__ = *a2 * *b3 - *a3 * *b2;
/* The SVD of real 2-by-2 triangular C
( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 )
( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T ) */
dlasv2_(&a, &c__, &d__, &s1, &s2, &snr, &csr, &snl, &csl);
if (abs(csr) >= abs(snr) || abs(csl) >= abs(snl)) {
/* Compute the (2,1) and (2,2) elements of U'*A and V'*B,
and (2,1) element of |U|'*|A| and |V|'*|B|. */
ua21 = -snr * *a1 + csr * *a2;
ua22r = csr * *a3;
vb21 = -snl * *b1 + csl * *b2;
vb22r = csl * *b3;
aua21 = abs(snr) * abs(*a1) + abs(csr) * abs(*a2);
avb21 = abs(snl) * abs(*b1) + abs(csl) * abs(*b2);
/* zero (2,1) elements of U'*A and V'*B. */
if (abs(ua21) + abs(ua22r) != 0.) {
if (aua21 / (abs(ua21) + abs(ua22r)) <= avb21 / (abs(vb21) +
abs(vb22r))) {
dlartg_(&ua22r, &ua21, csq, snq, &r__);
} else {
dlartg_(&vb22r, &vb21, csq, snq, &r__);
}
} else {
dlartg_(&vb22r, &vb21, csq, snq, &r__);
}
*csu = csr;
*snu = -snr;
*csv = csl;
*snv = -snl;
} else {
/* Compute the (1,1) and (1,2) elements of U'*A and V'*B,
and (1,1) element of |U|'*|A| and |V|'*|B|. */
ua11 = csr * *a1 + snr * *a2;
ua12 = snr * *a3;
vb11 = csl * *b1 + snl * *b2;
vb12 = snl * *b3;
aua11 = abs(csr) * abs(*a1) + abs(snr) * abs(*a2);
avb11 = abs(csl) * abs(*b1) + abs(snl) * abs(*b2);
/* zero (1,1) elements of U'*A and V'*B, and then swap. */
if (abs(ua11) + abs(ua12) != 0.) {
if (aua11 / (abs(ua11) + abs(ua12)) <= avb11 / (abs(vb11) +
abs(vb12))) {
dlartg_(&ua12, &ua11, csq, snq, &r__);
} else {
dlartg_(&vb12, &vb11, csq, snq, &r__);
}
} else {
dlartg_(&vb12, &vb11, csq, snq, &r__);
}
*csu = snr;
*snu = csr;
*csv = snl;
*snv = csl;
}
}
return 0;
/* End of DLAGS2 */
} /* dlags2_ */
/* Subroutine */ int dlagv2_(doublereal *a, integer *lda, doublereal *b,
integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *
beta, doublereal *csl, doublereal *snl, doublereal *csr, doublereal *
snr)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
/* Local variables */
doublereal r__, t, h1, h2, h3, wi, qq, rr, wr1, wr2, ulp;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *), dlag2_(
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
doublereal anorm, bnorm, scale1, scale2;
extern /* Subroutine */ int dlasv2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
extern doublereal dlapy2_(doublereal *, doublereal *);
doublereal ascale, bscale;
extern doublereal dlamch_(char *);
doublereal safmin;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAGV2 computes the Generalized Schur factorization of a real 2-by-2 */
/* matrix pencil (A,B) where B is upper triangular. This routine */
/* computes orthogonal (rotation) matrices given by CSL, SNL and CSR, */
/* SNR such that */
/* 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0 */
/* types), then */
/* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] */
/* [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] */
/* [ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ] */
/* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ], */
/* 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues, */
/* then */
/* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] */
/* [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] */
/* [ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ] */
/* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ] */
/* where b11 >= b22 > 0. */
/* Arguments */
/* ========= */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA, 2) */
/* On entry, the 2 x 2 matrix A. */
/* On exit, A is overwritten by the ``A-part'' of the */
/* generalized Schur form. */
/* LDA (input) INTEGER */
/* THe leading dimension of the array A. LDA >= 2. */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB, 2) */
/* On entry, the upper triangular 2 x 2 matrix B. */
/* On exit, B is overwritten by the ``B-part'' of the */
/* generalized Schur form. */
/* LDB (input) INTEGER */
/* THe leading dimension of the array B. LDB >= 2. */
/* ALPHAR (output) DOUBLE PRECISION array, dimension (2) */
/* ALPHAI (output) DOUBLE PRECISION array, dimension (2) */
/* BETA (output) DOUBLE PRECISION array, dimension (2) */
/* (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the */
/* pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may */
/* be zero. */
/* CSL (output) DOUBLE PRECISION */
/* The cosine of the left rotation matrix. */
/* SNL (output) DOUBLE PRECISION */
/* The sine of the left rotation matrix. */
/* CSR (output) DOUBLE PRECISION */
/* The cosine of the right rotation matrix. */
/* SNR (output) DOUBLE PRECISION */
/* The sine of the right rotation matrix. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--alphar;
--alphai;
--beta;
/* Function Body */
safmin = dlamch_("S");
ulp = dlamch_("P");
/* Scale A */
/* Computing MAX */
d__5 = (d__1 = a[a_dim1 + 1], abs(d__1)) + (d__2 = a[a_dim1 + 2], abs(
d__2)), d__6 = (d__3 = a[(a_dim1 << 1) + 1], abs(d__3)) + (d__4 =
a[(a_dim1 << 1) + 2], abs(d__4)), d__5 = max(d__5,d__6);
anorm = max(d__5,safmin);
ascale = 1. / anorm;
a[a_dim1 + 1] = ascale * a[a_dim1 + 1];
a[(a_dim1 << 1) + 1] = ascale * a[(a_dim1 << 1) + 1];
a[a_dim1 + 2] = ascale * a[a_dim1 + 2];
a[(a_dim1 << 1) + 2] = ascale * a[(a_dim1 << 1) + 2];
/* Scale B */
/* Computing MAX */
d__4 = (d__3 = b[b_dim1 + 1], abs(d__3)), d__5 = (d__1 = b[(b_dim1 << 1)
+ 1], abs(d__1)) + (d__2 = b[(b_dim1 << 1) + 2], abs(d__2)), d__4
= max(d__4,d__5);
bnorm = max(d__4,safmin);
bscale = 1. / bnorm;
b[b_dim1 + 1] = bscale * b[b_dim1 + 1];
b[(b_dim1 << 1) + 1] = bscale * b[(b_dim1 << 1) + 1];
b[(b_dim1 << 1) + 2] = bscale * b[(b_dim1 << 1) + 2];
/* Check if A can be deflated */
if ((d__1 = a[a_dim1 + 2], abs(d__1)) <= ulp) {
*csl = 1.;
*snl = 0.;
*csr = 1.;
*snr = 0.;
a[a_dim1 + 2] = 0.;
b[b_dim1 + 2] = 0.;
/* Check if B is singular */
} else if ((d__1 = b[b_dim1 + 1], abs(d__1)) <= ulp) {
dlartg_(&a[a_dim1 + 1], &a[a_dim1 + 2], csl, snl, &r__);
*csr = 1.;
*snr = 0.;
drot_(&c__2, &a[a_dim1 + 1], lda, &a[a_dim1 + 2], lda, csl, snl);
drot_(&c__2, &b[b_dim1 + 1], ldb, &b[b_dim1 + 2], ldb, csl, snl);
a[a_dim1 + 2] = 0.;
b[b_dim1 + 1] = 0.;
b[b_dim1 + 2] = 0.;
} else if ((d__1 = b[(b_dim1 << 1) + 2], abs(d__1)) <= ulp) {
dlartg_(&a[(a_dim1 << 1) + 2], &a[a_dim1 + 2], csr, snr, &t);
*snr = -(*snr);
drot_(&c__2, &a[a_dim1 + 1], &c__1, &a[(a_dim1 << 1) + 1], &c__1, csr,
snr);
drot_(&c__2, &b[b_dim1 + 1], &c__1, &b[(b_dim1 << 1) + 1], &c__1, csr,
snr);
*csl = 1.;
*snl = 0.;
a[a_dim1 + 2] = 0.;
b[b_dim1 + 2] = 0.;
b[(b_dim1 << 1) + 2] = 0.;
} else {
/* B is nonsingular, first compute the eigenvalues of (A,B) */
dlag2_(&a[a_offset], lda, &b[b_offset], ldb, &safmin, &scale1, &
scale2, &wr1, &wr2, &wi);
if (wi == 0.) {
/* two real eigenvalues, compute s*A-w*B */
h1 = scale1 * a[a_dim1 + 1] - wr1 * b[b_dim1 + 1];
h2 = scale1 * a[(a_dim1 << 1) + 1] - wr1 * b[(b_dim1 << 1) + 1];
h3 = scale1 * a[(a_dim1 << 1) + 2] - wr1 * b[(b_dim1 << 1) + 2];
rr = dlapy2_(&h1, &h2);
d__1 = scale1 * a[a_dim1 + 2];
qq = dlapy2_(&d__1, &h3);
if (rr > qq) {
/* find right rotation matrix to zero 1,1 element of */
/* (sA - wB) */
dlartg_(&h2, &h1, csr, snr, &t);
} else {
/* find right rotation matrix to zero 2,1 element of */
/* (sA - wB) */
d__1 = scale1 * a[a_dim1 + 2];
dlartg_(&h3, &d__1, csr, snr, &t);
}
*snr = -(*snr);
drot_(&c__2, &a[a_dim1 + 1], &c__1, &a[(a_dim1 << 1) + 1], &c__1,
csr, snr);
drot_(&c__2, &b[b_dim1 + 1], &c__1, &b[(b_dim1 << 1) + 1], &c__1,
csr, snr);
/* compute inf norms of A and B */
/* Computing MAX */
d__5 = (d__1 = a[a_dim1 + 1], abs(d__1)) + (d__2 = a[(a_dim1 << 1)
+ 1], abs(d__2)), d__6 = (d__3 = a[a_dim1 + 2], abs(d__3)
) + (d__4 = a[(a_dim1 << 1) + 2], abs(d__4));
h1 = max(d__5,d__6);
/* Computing MAX */
d__5 = (d__1 = b[b_dim1 + 1], abs(d__1)) + (d__2 = b[(b_dim1 << 1)
+ 1], abs(d__2)), d__6 = (d__3 = b[b_dim1 + 2], abs(d__3)
) + (d__4 = b[(b_dim1 << 1) + 2], abs(d__4));
h2 = max(d__5,d__6);
if (scale1 * h1 >= abs(wr1) * h2) {
/* find left rotation matrix Q to zero out B(2,1) */
dlartg_(&b[b_dim1 + 1], &b[b_dim1 + 2], csl, snl, &r__);
} else {
/* find left rotation matrix Q to zero out A(2,1) */
dlartg_(&a[a_dim1 + 1], &a[a_dim1 + 2], csl, snl, &r__);
}
drot_(&c__2, &a[a_dim1 + 1], lda, &a[a_dim1 + 2], lda, csl, snl);
drot_(&c__2, &b[b_dim1 + 1], ldb, &b[b_dim1 + 2], ldb, csl, snl);
a[a_dim1 + 2] = 0.;
b[b_dim1 + 2] = 0.;
} else {
/* a pair of complex conjugate eigenvalues */
/* first compute the SVD of the matrix B */
dlasv2_(&b[b_dim1 + 1], &b[(b_dim1 << 1) + 1], &b[(b_dim1 << 1) +
2], &r__, &t, snr, csr, snl, csl);
/* Form (A,B) := Q(A,B)Z' where Q is left rotation matrix and */
/* Z is right rotation matrix computed from DLASV2 */
drot_(&c__2, &a[a_dim1 + 1], lda, &a[a_dim1 + 2], lda, csl, snl);
drot_(&c__2, &b[b_dim1 + 1], ldb, &b[b_dim1 + 2], ldb, csl, snl);
drot_(&c__2, &a[a_dim1 + 1], &c__1, &a[(a_dim1 << 1) + 1], &c__1,
csr, snr);
drot_(&c__2, &b[b_dim1 + 1], &c__1, &b[(b_dim1 << 1) + 1], &c__1,
csr, snr);
b[b_dim1 + 2] = 0.;
b[(b_dim1 << 1) + 1] = 0.;
}
}
/* Unscaling */
a[a_dim1 + 1] = anorm * a[a_dim1 + 1];
a[a_dim1 + 2] = anorm * a[a_dim1 + 2];
a[(a_dim1 << 1) + 1] = anorm * a[(a_dim1 << 1) + 1];
a[(a_dim1 << 1) + 2] = anorm * a[(a_dim1 << 1) + 2];
b[b_dim1 + 1] = bnorm * b[b_dim1 + 1];
b[b_dim1 + 2] = bnorm * b[b_dim1 + 2];
b[(b_dim1 << 1) + 1] = bnorm * b[(b_dim1 << 1) + 1];
b[(b_dim1 << 1) + 2] = bnorm * b[(b_dim1 << 1) + 2];
if (wi == 0.) {
alphar[1] = a[a_dim1 + 1];
alphar[2] = a[(a_dim1 << 1) + 2];
alphai[1] = 0.;
alphai[2] = 0.;
beta[1] = b[b_dim1 + 1];
beta[2] = b[(b_dim1 << 1) + 2];
} else {
alphar[1] = anorm * wr1 / scale1 / bnorm;
alphai[1] = anorm * wi / scale1 / bnorm;
alphar[2] = alphar[1];
alphai[2] = -alphai[1];
beta[1] = 1.;
beta[2] = 1.;
}
return 0;
/* End of DLAGV2 */
} /* dlagv2_ */
