/* Detection of onsets in (or slightly preceding) the futuremost frame of speech. */
static void onset(lpc10_encode_state_t *s,
float *pebuf,
int32_t osbuf[],
int32_t *osptr,
int32_t oslen,
int32_t sbufl,
int32_t sbufh,
int32_t lframe)
{
int32_t i;
float r1;
float l2sum2;
pebuf -= sbufl;
if (s->hyst)
s->lasti -= lframe;
for (i = sbufh - lframe + 1; i <= sbufh; i++)
{
/* Compute FPC; Use old FPC on divide by zero; Clamp FPC to +/- 1. */
s->n = (pebuf[i]*pebuf[i - 1] + s->n*63.0f)/64.0f;
/* Computing 2nd power */
r1 = pebuf[i - 1];
s->d__ = (r1*r1 + s->d__*63.0f)/64.0f;
if (s->d__ != 0.0f)
{
if (fabsf(s->n) > s->d__)
s->fpc = r_sign(1.0f, s->n);
else
s->fpc = s->n/s->d__;
}
/* Filter FPC */
l2sum2 = s->l2buf[s->l2ptr1 - 1];
s->l2sum1 = s->l2sum1 - s->l2buf[s->l2ptr2 - 1] + s->fpc;
s->l2buf[s->l2ptr2 - 1] = s->l2sum1;
s->l2buf[s->l2ptr1 - 1] = s->fpc;
s->l2ptr1 = (s->l2ptr1 & 0xF) + 1;
s->l2ptr2 = (s->l2ptr2 & 0xF) + 1;
if (fabsf(s->l2sum1 - l2sum2) > 1.7f)
{
if (!s->hyst)
{
/* Ignore if buffer full */
if (*osptr <= oslen)
{
osbuf[*osptr - 1] = i - 9;
(*osptr)++;
}
s->hyst = TRUE;
}
s->lasti = i;
/* After one onset detection, at least OSHYST sample times must go */
/* by before another is allowed to occur. */
}
else if (s->hyst && i - s->lasti >= 10)
{
s->hyst = FALSE;
}
}
}
/* Subroutine */ int PASTEF77(s,rotg)(real *sa, real *sb, real *c__, real *s)
{
/* System generated locals */
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal), r_sign(real *, real *);
/* Local variables */
real r__, scale, z__, roe;
/* construct givens plane rotation. */
/* jack dongarra, linpack, 3/11/78. */
roe = *sb;
if (abs(*sa) > abs(*sb)) {
roe = *sa;
}
scale = abs(*sa) + abs(*sb);
if (scale != 0.f) {
goto L10;
}
*c__ = 1.f;
*s = 0.f;
r__ = 0.f;
z__ = 0.f;
goto L20;
L10:
/* Computing 2nd power */
r__1 = *sa / scale;
/* Computing 2nd power */
r__2 = *sb / scale;
r__ = scale * sqrt(r__1 * r__1 + r__2 * r__2);
r__ = r_sign(&sc_b4, &roe) * r__;
*c__ = *sa / r__;
*s = *sb / r__;
z__ = 1.f;
if (abs(*sa) > abs(*sb)) {
z__ = *s;
}
if (abs(*sb) >= abs(*sa) && *c__ != 0.f) {
z__ = 1.f / *c__;
}
L20:
*sa = r__;
*sb = z__;
return 0;
} /* srotg_ */
/*< S >*/
/* Subroutine */ int onset_0_(int n__, real *pebuf, integer *osbuf, integer *
osptr, integer *oslen, integer *sbufl, integer *sbufh, integer *
lframe)
{
/* Initialized data */
static real n = 0.f;
static real d__ = 1.f;
static real l2buf[16] = { 0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,
0.f,0.f,0.f,0.f };
static real l2sum1 = 0.f;
static integer l2ptr1 = 1;
static integer l2ptr2 = 9;
static logical hyst = FALSE_;
/* System generated locals */
integer i__1;
/* Builtin functions */
double r_sign(real *, real *);
/* Local variables */
integer i__;
static integer lasti;
real l2sum2;
static real fpc;
/*< INCLUDE 'config.fh' >*/
/*< INTEGER OSLEN, SBUFL, SBUFH, LFRAME >*/
/* Arguments */
/* $Log: onset.c,v $
/* Revision 1.2 2001-01-25 23:45:49 jpoehlmann
/* Version 1.7c. Identical with files on the ftp Server ftp.franken.de.
/* (+ 1 patch in cli.c, wich is on the server too)
/* Not compiled now
/* */
/* Revision 1.3 1996/03/29 22:03:47 jaf */
/* Removed definitions for any constants that were no longer used. */
/* Revision 1.2 1996/03/26 19:34:33 jaf */
/* Added comments indicating which constants are not needed in an */
/* application that uses the LPC-10 coder. */
/* Revision 1.1 1996/02/07 14:43:51 jaf */
/* Initial revision */
/* LPC Configuration parameters: */
/* Frame size, Prediction order, Pitch period */
/*< parameter (MAXFRM = 180, MAXORD = 10, MAXPIT = 156) >*/
/*< REAL PEBUF(SBUFL:SBUFH) >*/
/*< INTEGER OSBUF(OSLEN), OSPTR >*/
/* Parameters/constants */
/* Parameters for onset detection algorithm: */
/* L2 Threshold for filtered slope of FPC (function of L2WID!) */
/* L2LAG Lag due to both filters which compute filtered slope of FPC */
/* L2WID Width of the filter which computes the slope of FPC */
/* OSHYST The number of samples of slope(FPC) which must be below */
/* the threshold before a new onset may be declared. */
/*< INTEGER L2LAG, L2WID, OSHYST, TEMP >*/
/*< REAL L2 >*/
/*< PARAMETER (L2=1.7, L2LAG=9, L2WID=16, OSHYST=10) >*/
/*< PARAMETER (TEMP=1+L2WID/2) >*/
/* Local variables that need not be saved */
/*< INTEGER I >*/
/*< REAL L2SUM2 >*/
/* Local state */
/* Variables */
/* N, D Numerator and denominator of prediction filters */
/* FPC Current prediction coefs */
/* L2BUF, L2SUM1, L2SUM2 State of slope filter */
/* The only "significant" change I've made is to change L2SUM2 out
*/
/* of the list of local variables that need to be saved, since it */
/* didn't need to be. */
/* L2SUM1 need not be, but avoiding saving it would require a small
*/
/* change to the body of the code. See comments below for an */
/* example of how the code could be changed to avoid saving L2SUM1.
*/
/* FPC and LASTI are saved from one invocation to the next, but */
/* they are not given initial values. This is acceptable, because
*/
/* FPC will be assigned a value the first time that this function */
/* is called after D is initialized to 1, since the formula to */
/* change D will not change it to 0 in one step, and the IF (D */
/* .NE. 0) statement will execute its THEN part, initializing FPC.
*/
/* LASTI's value will not be used until HYST is .TRUE., and */
/* whenever HYST is changed from its initial value of .FALSE., */
/* LASTI is assigned a value. */
/* In a C version of this coder, it would be nice if all of these */
/* saved things, in this and all other subroutines, could be stored
*/
/* in a single struct lpc10_coder_state_t, initialized with a call
*/
/* to a function like lpc10_init(&lpc10_coder_state). In this way,
*/
/* a program that used these functions could conveniently alternate
*/
/* coding more than one distinct audio stream. */
/*< REAL N, D, FPC >*/
/*< REAL L2BUF(L2WID), L2SUM1 >*/
/*< INTEGER L2PTR1, L2PTR2, LASTI >*/
/*< LOGICAL HYST >*/
/*< DATA N/0./, D/1./ >*/
/* Parameter adjustments */
if (osbuf) {
--osbuf;
}
if (pebuf) {
pebuf -= *sbufl;
}
/* Function Body */
switch(n__) {
case 1: goto L_initonset;
}
/*< DATA L2BUF/L2WID*0./, L2SUM1/0./ >*/
/*< DATA L2PTR1/1/, L2PTR2/TEMP/ >*/
/*< DATA HYST/.FALSE./ >*/
/*< SAVE N, D, FPC >*/
/*< SAVE L2BUF, L2SUM1 >*/
/*< SAVE L2PTR1, L2PTR2, LASTI >*/
/*< SAVE HYST >*/
/* The following line subtracted a hard-coded "180" from LASTI, */
/* instead of using a variable like LFRAME or a constant like */
/* MAXFRM. I changed it to LFRAME, for "generality". */
/*< IF (HYST) LASTI = LASTI - LFRAME >*/
if (hyst) {
lasti -= *lframe;
}
/*< DO I = SBUFH-LFRAME+1, SBUFH >*/
i__1 = *sbufh;
for (i__ = *sbufh - *lframe + 1; i__ <= i__1; ++i__) {
/* Compute FPC; Use old FPC on divide by zero; Clamp FPC to +/- 1.
*/
/*< N=(PEBUF(I)*PEBUF(I-1)+63.*N) / 64. >*/
n = (pebuf[i__] * pebuf[i__ - 1] + n * 63.f) / 64.f;
/*< D=(PEBUF(I-1)**2+63.*D) / 64. >*/
/* Computing 2nd power */
d__ = (pebuf[i__-1] * pebuf[i__-1] + d__ * 63.f) / 64.f;
/*< IF (D .NE. 0.) THEN >*/
if (d__ != 0.f) {
/*< IF (ABS(N) .GT. D) THEN >*/
if (abs(n) > d__) {
/*< FPC = SIGN (1., N) >*/
fpc = (real) r_sign(&c_b2, &n);
/*< ELSE >*/
} else {
/*< FPC=N/D >*/
fpc = n / d__;
/*< END IF >*/
}
/*< END IF >*/
}
/* Filter FPC */
/* In order to allow L2SUM1 not to be saved from one invocation
of */
/* this subroutine to the next, one could change the sequence of
*/
/* assignments below, up to the IF statement, to the following.
In */
/* addition, the initial value of L2PTR2 should be changed to */
/* L2WID/2 instead of L2WID/2+1. */
/* L2SUM1 = L2BUF(L2PTR2) */
/* L2PTR2 = MOD(L2PTR2,L2WID)+1 */
/* L2SUM1 = L2SUM1 - L2BUF(L2PTR2) + FPC */
/* L2BUF(L2PTR2) = L2SUM1 */
/* * The following lines didn't change from the original: */
/* L2SUM2 = L2BUF(L2PTR1) */
/* L2BUF(L2PTR1) = FPC */
/* L2PTR1 = MOD(L2PTR1,L2WID)+1 */
/*< L2SUM2 = L2BUF(L2PTR1) >*/
l2sum2 = l2buf[l2ptr1 - 1];
/*< L2SUM1 = L2SUM1 - L2BUF(L2PTR2) + FPC >*/
l2sum1 = l2sum1 - l2buf[l2ptr2 - 1] + fpc;
/*< L2BUF(L2PTR2) = L2SUM1 >*/
l2buf[l2ptr2 - 1] = l2sum1;
/*< L2BUF(L2PTR1) = FPC >*/
l2buf[l2ptr1 - 1] = fpc;
/*< L2PTR1 = MOD(L2PTR1,L2WID)+1 >*/
l2ptr1 = l2ptr1 % 16 + 1;
/*< L2PTR2 = MOD(L2PTR2,L2WID)+1 >*/
l2ptr2 = l2ptr2 % 16 + 1;
/*< IF (ABS(L2SUM1-L2SUM2) .GT. L2) THEN >*/
if (abs(l2sum1 - l2sum2) > 1.7f) {
/*< IF (.NOT. HYST) THEN >*/
if (! hyst) {
/* Ignore if buffer full */
/*< IF (OSPTR .LE. OSLEN) THEN >*/
if (*osptr <= *oslen) {
/*< OSBUF (OSPTR) = I - L2LAG >*/
osbuf[*osptr] = i__ - 9;
/*< OSPTR = OSPTR + 1 >*/
++(*osptr);
/*< END IF >*/
}
/*< HYST = .TRUE. >*/
hyst = TRUE_;
/*< END IF >*/
}
/*< LASTI = I >*/
lasti = i__;
/* After one onset detection, at least OSHYST sample times m
ust go */
/* by before another is allowed to occur. */
/*< ELSE IF (HYST .AND. I - LASTI .GE. OSHYST) THEN >*/
} else if (hyst && i__ - lasti >= 10) {
/*< HYST = .FALSE. >*/
hyst = FALSE_;
/*< END IF >*/
}
/*< END DO >*/
}
/*< RETURN >*/
return 0;
/*< ENTRY INITONSET () >*/
L_initonset:
/*< N = 0. >*/
n = 0.f;
/*< D = 1. >*/
d__ = 1.f;
/*< DO I = 1, L2WID >*/
for (i__ = 1; i__ <= 16; ++i__) {
/*< L2BUF(I) = 0. >*/
l2buf[i__ - 1] = 0.f;
/*< END DO >*/
}
/*< L2SUM1 = 0. >*/
l2sum1 = 0.f;
/*< L2PTR1 = 1 >*/
l2ptr1 = 1;
/*< L2PTR2 = TEMP >*/
l2ptr2 = 9;
/*< HYST = .FALSE. >*/
hyst = FALSE_;
/*< RETURN >*/
return 0;
/*< END >*/
} /* onset_ */
/* Subroutine */ int ssteqr_(char *compz, integer *n, real *d__, real *e,
real *z__, integer *ldz, real *work, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
real r__1, r__2;
/* Local variables */
real b, c__, f, g;
integer i__, j, k, l, m;
real p, r__, s;
integer l1, ii, mm, lm1, mm1, nm1;
real rt1, rt2, eps;
integer lsv;
real tst, eps2;
integer lend, jtot;
real anorm;
integer lendm1, lendp1;
integer iscale;
real safmin;
real safmax;
integer lendsv;
real ssfmin;
integer nmaxit, icompz;
real ssfmax;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SSTEQR computes all eigenvalues and, optionally, eigenvectors of a */
/* symmetric tridiagonal matrix using the implicit QL or QR method. */
/* The eigenvectors of a full or band symmetric matrix can also be found */
/* if SSYTRD or SSPTRD or SSBTRD has been used to reduce this matrix to */
/* tridiagonal form. */
/* Arguments */
/* ========= */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only. */
/* = 'V': Compute eigenvalues and eigenvectors of the original */
/* symmetric matrix. On entry, Z must contain the */
/* orthogonal matrix used to reduce the original matrix */
/* to tridiagonal form. */
/* = 'I': Compute eigenvalues and eigenvectors of the */
/* tridiagonal matrix. Z is initialized to the identity */
/* matrix. */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* D (input/output) REAL array, dimension (N) */
/* On entry, the diagonal elements of the tridiagonal matrix. */
/* On exit, if INFO = 0, the eigenvalues in ascending order. */
/* E (input/output) REAL array, dimension (N-1) */
/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
/* matrix. */
/* On exit, E has been destroyed. */
/* Z (input/output) REAL array, dimension (LDZ, N) */
/* On entry, if COMPZ = 'V', then Z contains the orthogonal */
/* matrix used in the reduction to tridiagonal form. */
/* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */
/* orthonormal eigenvectors of the original symmetric matrix, */
/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */
/* of the symmetric tridiagonal matrix. */
/* If COMPZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* eigenvectors are desired, then LDZ >= max(1,N). */
/* WORK (workspace) REAL array, dimension (max(1,2*N-2)) */
/* If COMPZ = 'N', then WORK is not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: the algorithm has failed to find all the eigenvalues in */
/* a total of 30*N iterations; if INFO = i, then i */
/* elements of E have not converged to zero; on exit, D */
/* and E contain the elements of a symmetric tridiagonal */
/* matrix which is orthogonally similar to the original */
/* matrix. */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
*info = 0;
if (lsame_(compz, "N")) {
icompz = 0;
} else if (lsame_(compz, "V")) {
icompz = 1;
} else if (lsame_(compz, "I")) {
icompz = 2;
} else {
icompz = -1;
}
if (icompz < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSTEQR", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz == 2) {
z__[z_dim1 + 1] = 1.f;
}
return 0;
}
/* Determine the unit roundoff and over/underflow thresholds. */
eps = slamch_("E");
/* Computing 2nd power */
r__1 = eps;
eps2 = r__1 * r__1;
safmin = slamch_("S");
safmax = 1.f / safmin;
ssfmax = sqrt(safmax) / 3.f;
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues and eigenvectors of the tridiagonal */
/* matrix. */
if (icompz == 2) {
slaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz);
}
nmaxit = *n * 30;
jtot = 0;
/* Determine where the matrix splits and choose QL or QR iteration */
/* for each block, according to whether top or bottom diagonal */
/* element is smaller. */
l1 = 1;
nm1 = *n - 1;
L10:
if (l1 > *n) {
goto L160;
}
if (l1 > 1) {
e[l1 - 1] = 0.f;
}
if (l1 <= nm1) {
i__1 = nm1;
for (m = l1; m <= i__1; ++m) {
tst = (r__1 = e[m], dabs(r__1));
if (tst == 0.f) {
goto L30;
}
if (tst <= sqrt((r__1 = d__[m], dabs(r__1))) * sqrt((r__2 = d__[m
+ 1], dabs(r__2))) * eps) {
e[m] = 0.f;
goto L30;
}
}
}
m = *n;
L30:
l = l1;
lsv = l;
lend = m;
lendsv = lend;
l1 = m + 1;
if (lend == l) {
goto L10;
}
/* Scale submatrix in rows and columns L to LEND */
i__1 = lend - l + 1;
anorm = slanst_("I", &i__1, &d__[l], &e[l]);
iscale = 0;
if (anorm == 0.f) {
goto L10;
}
if (anorm > ssfmax) {
iscale = 1;
i__1 = lend - l + 1;
slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
info);
} else if (anorm < ssfmin) {
iscale = 2;
i__1 = lend - l + 1;
slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
info);
}
/* Choose between QL and QR iteration */
if ((r__1 = d__[lend], dabs(r__1)) < (r__2 = d__[l], dabs(r__2))) {
lend = lsv;
l = lendsv;
}
if (lend > l) {
/* QL Iteration */
/* Look for small subdiagonal element. */
L40:
if (l != lend) {
lendm1 = lend - 1;
i__1 = lendm1;
for (m = l; m <= i__1; ++m) {
/* Computing 2nd power */
r__2 = (r__1 = e[m], dabs(r__1));
tst = r__2 * r__2;
if (tst <= eps2 * (r__1 = d__[m], dabs(r__1)) * (r__2 = d__[m
+ 1], dabs(r__2)) + safmin) {
goto L60;
}
}
}
m = lend;
L60:
if (m < lend) {
e[m] = 0.f;
}
p = d__[l];
if (m == l) {
goto L80;
}
/* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2 */
/* to compute its eigensystem. */
if (m == l + 1) {
if (icompz > 0) {
slaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
work[l] = c__;
work[*n - 1 + l] = s;
slasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], &
z__[l * z_dim1 + 1], ldz);
} else {
slae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
}
d__[l] = rt1;
d__[l + 1] = rt2;
e[l] = 0.f;
l += 2;
if (l <= lend) {
goto L40;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l + 1] - p) / (e[l] * 2.f);
r__ = slapy2_(&g, &c_b10);
g = d__[m] - p + e[l] / (g + r_sign(&r__, &g));
s = 1.f;
c__ = 1.f;
p = 0.f;
/* Inner loop */
mm1 = m - 1;
i__1 = l;
for (i__ = mm1; i__ >= i__1; --i__) {
f = s * e[i__];
b = c__ * e[i__];
slartg_(&g, &f, &c__, &s, &r__);
if (i__ != m - 1) {
e[i__ + 1] = r__;
}
g = d__[i__ + 1] - p;
r__ = (d__[i__] - g) * s + c__ * 2.f * b;
p = s * r__;
d__[i__ + 1] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
work[i__] = c__;
work[*n - 1 + i__] = -s;
}
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = m - l + 1;
slasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l
* z_dim1 + 1], ldz);
}
d__[l] -= p;
e[l] = g;
goto L40;
/* Eigenvalue found. */
L80:
d__[l] = p;
++l;
if (l <= lend) {
goto L40;
}
goto L140;
} else {
/* QR Iteration */
/* Look for small superdiagonal element. */
L90:
if (l != lend) {
lendp1 = lend + 1;
i__1 = lendp1;
for (m = l; m >= i__1; --m) {
/* Computing 2nd power */
r__2 = (r__1 = e[m - 1], dabs(r__1));
tst = r__2 * r__2;
if (tst <= eps2 * (r__1 = d__[m], dabs(r__1)) * (r__2 = d__[m
- 1], dabs(r__2)) + safmin) {
goto L110;
}
}
}
m = lend;
L110:
if (m > lend) {
e[m - 1] = 0.f;
}
p = d__[l];
if (m == l) {
goto L130;
}
/* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2 */
/* to compute its eigensystem. */
if (m == l - 1) {
if (icompz > 0) {
slaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s)
;
work[m] = c__;
work[*n - 1 + m] = s;
slasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], &
z__[(l - 1) * z_dim1 + 1], ldz);
} else {
slae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
}
d__[l - 1] = rt1;
d__[l] = rt2;
e[l - 1] = 0.f;
l += -2;
if (l >= lend) {
goto L90;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l - 1] - p) / (e[l - 1] * 2.f);
r__ = slapy2_(&g, &c_b10);
g = d__[m] - p + e[l - 1] / (g + r_sign(&r__, &g));
s = 1.f;
c__ = 1.f;
p = 0.f;
/* Inner loop */
lm1 = l - 1;
i__1 = lm1;
for (i__ = m; i__ <= i__1; ++i__) {
f = s * e[i__];
b = c__ * e[i__];
slartg_(&g, &f, &c__, &s, &r__);
if (i__ != m) {
e[i__ - 1] = r__;
}
g = d__[i__] - p;
r__ = (d__[i__ + 1] - g) * s + c__ * 2.f * b;
p = s * r__;
d__[i__] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
work[i__] = c__;
work[*n - 1 + i__] = s;
}
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = l - m + 1;
slasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m
* z_dim1 + 1], ldz);
}
d__[l] -= p;
e[lm1] = g;
goto L90;
/* Eigenvalue found. */
L130:
d__[l] = p;
--l;
if (l >= lend) {
goto L90;
}
goto L140;
}
/* Undo scaling if necessary */
L140:
if (iscale == 1) {
i__1 = lendsv - lsv + 1;
slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
i__1 = lendsv - lsv;
slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n,
info);
} else if (iscale == 2) {
i__1 = lendsv - lsv + 1;
slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
i__1 = lendsv - lsv;
slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n,
info);
}
/* Check for no convergence to an eigenvalue after a total */
/* of N*MAXIT iterations. */
if (jtot < nmaxit) {
goto L10;
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.f) {
++(*info);
}
}
goto L190;
/* Order eigenvalues and eigenvectors. */
L160:
if (icompz == 0) {
/* Use Quick Sort */
slasrt_("I", n, &d__[1], info);
} else {
/* Use Selection Sort to minimize swaps of eigenvectors */
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
i__ = ii - 1;
k = i__;
p = d__[i__];
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
if (d__[j] < p) {
k = j;
p = d__[j];
}
}
if (k != i__) {
d__[k] = d__[i__];
d__[i__] = p;
sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1],
&c__1);
}
}
}
L190:
return 0;
/* End of SSTEQR */
} /* ssteqr_ */
/* Subroutine */
int cla_heamv_(integer *uplo, integer *n, real *alpha, complex *a, integer *lda, complex *x, integer *incx, real *beta, real *y, integer *incy)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1, r__2;
/* Builtin functions */
double r_imag(complex *), r_sign(real *, real *);
/* Local variables */
integer i__, j;
logical symb_zero__;
integer iy, jx, kx, ky, info;
real temp, safe1;
extern real slamch_(char *);
extern /* Subroutine */
int xerbla_(char *, integer *);
extern integer ilauplo_(char *);
/* -- 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 .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function Definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--x;
--y;
/* Function Body */
info = 0;
if (*uplo != ilauplo_("U") && *uplo != ilauplo_("L") )
{
info = 1;
}
else if (*n < 0)
{
info = 2;
}
else if (*lda < max(1,*n))
{
info = 5;
}
else if (*incx == 0)
{
info = 7;
}
else if (*incy == 0)
{
info = 10;
}
if (info != 0)
{
xerbla_("CHEMV ", &info);
return 0;
}
/* Quick return if possible. */
if (*n == 0 || *alpha == 0.f && *beta == 1.f)
{
return 0;
}
/* Set up the start points in X and Y. */
if (*incx > 0)
{
kx = 1;
}
else
{
kx = 1 - (*n - 1) * *incx;
}
if (*incy > 0)
{
ky = 1;
}
else
{
ky = 1 - (*n - 1) * *incy;
}
/* Set SAFE1 essentially to be the underflow threshold times the */
/* number of additions in each row. */
safe1 = slamch_("Safe minimum");
safe1 = (*n + 1) * safe1;
/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */
/* The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to */
/* the inexact flag. Still doesn't help change the iteration order */
/* to per-column. */
iy = ky;
if (*incx == 1)
{
if (*uplo == ilauplo_("U"))
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
if (*beta == 0.f)
{
symb_zero__ = TRUE_;
y[iy] = 0.f;
}
else if (y[iy] == 0.f)
{
symb_zero__ = TRUE_;
}
else
{
symb_zero__ = FALSE_;
y[iy] = *beta * (r__1 = y[iy], abs(r__1));
}
if (*alpha != 0.f)
{
i__2 = i__;
for (j = 1;
j <= i__2;
++j)
{
i__3 = j + i__ * a_dim1;
temp = (r__1 = a[i__3].r, abs(r__1)) + (r__2 = r_imag( &a[j + i__ * a_dim1]), abs(r__2));
i__3 = j;
symb_zero__ = symb_zero__ && (x[i__3].r == 0.f && x[ i__3].i == 0.f || temp == 0.f);
i__3 = j;
y[iy] += *alpha * ((r__1 = x[i__3].r, abs(r__1)) + ( r__2 = r_imag(&x[j]), abs(r__2))) * temp;
}
i__2 = *n;
for (j = i__ + 1;
j <= i__2;
++j)
{
i__3 = i__ + j * a_dim1;
temp = (r__1 = a[i__3].r, abs(r__1)) + (r__2 = r_imag( &a[i__ + j * a_dim1]), abs(r__2));
i__3 = j;
symb_zero__ = symb_zero__ && (x[i__3].r == 0.f && x[ i__3].i == 0.f || temp == 0.f);
i__3 = j;
y[iy] += *alpha * ((r__1 = x[i__3].r, abs(r__1)) + ( r__2 = r_imag(&x[j]), abs(r__2))) * temp;
}
}
if (! symb_zero__)
{
y[iy] += r_sign(&safe1, &y[iy]);
}
iy += *incy;
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
if (*beta == 0.f)
{
symb_zero__ = TRUE_;
y[iy] = 0.f;
}
else if (y[iy] == 0.f)
{
symb_zero__ = TRUE_;
}
else
{
symb_zero__ = FALSE_;
y[iy] = *beta * (r__1 = y[iy], abs(r__1));
}
if (*alpha != 0.f)
{
i__2 = i__;
for (j = 1;
j <= i__2;
++j)
{
i__3 = i__ + j * a_dim1;
temp = (r__1 = a[i__3].r, abs(r__1)) + (r__2 = r_imag( &a[i__ + j * a_dim1]), abs(r__2));
i__3 = j;
symb_zero__ = symb_zero__ && (x[i__3].r == 0.f && x[ i__3].i == 0.f || temp == 0.f);
i__3 = j;
y[iy] += *alpha * ((r__1 = x[i__3].r, abs(r__1)) + ( r__2 = r_imag(&x[j]), abs(r__2))) * temp;
}
i__2 = *n;
for (j = i__ + 1;
j <= i__2;
++j)
{
i__3 = j + i__ * a_dim1;
temp = (r__1 = a[i__3].r, abs(r__1)) + (r__2 = r_imag( &a[j + i__ * a_dim1]), abs(r__2));
i__3 = j;
symb_zero__ = symb_zero__ && (x[i__3].r == 0.f && x[ i__3].i == 0.f || temp == 0.f);
i__3 = j;
y[iy] += *alpha * ((r__1 = x[i__3].r, abs(r__1)) + ( r__2 = r_imag(&x[j]), abs(r__2))) * temp;
}
}
if (! symb_zero__)
{
y[iy] += r_sign(&safe1, &y[iy]);
}
iy += *incy;
}
}
}
else
{
if (*uplo == ilauplo_("U"))
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
if (*beta == 0.f)
{
symb_zero__ = TRUE_;
y[iy] = 0.f;
}
else if (y[iy] == 0.f)
{
symb_zero__ = TRUE_;
}
else
{
symb_zero__ = FALSE_;
y[iy] = *beta * (r__1 = y[iy], abs(r__1));
}
jx = kx;
if (*alpha != 0.f)
{
i__2 = i__;
for (j = 1;
j <= i__2;
++j)
{
i__3 = j + i__ * a_dim1;
temp = (r__1 = a[i__3].r, abs(r__1)) + (r__2 = r_imag( &a[j + i__ * a_dim1]), abs(r__2));
i__3 = j;
symb_zero__ = symb_zero__ && (x[i__3].r == 0.f && x[ i__3].i == 0.f || temp == 0.f);
i__3 = jx;
y[iy] += *alpha * ((r__1 = x[i__3].r, abs(r__1)) + ( r__2 = r_imag(&x[jx]), abs(r__2))) * temp;
jx += *incx;
}
i__2 = *n;
for (j = i__ + 1;
j <= i__2;
++j)
{
i__3 = i__ + j * a_dim1;
temp = (r__1 = a[i__3].r, abs(r__1)) + (r__2 = r_imag( &a[i__ + j * a_dim1]), abs(r__2));
i__3 = j;
symb_zero__ = symb_zero__ && (x[i__3].r == 0.f && x[ i__3].i == 0.f || temp == 0.f);
i__3 = jx;
y[iy] += *alpha * ((r__1 = x[i__3].r, abs(r__1)) + ( r__2 = r_imag(&x[jx]), abs(r__2))) * temp;
jx += *incx;
}
}
if (! symb_zero__)
{
y[iy] += r_sign(&safe1, &y[iy]);
}
iy += *incy;
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
if (*beta == 0.f)
{
symb_zero__ = TRUE_;
y[iy] = 0.f;
}
else if (y[iy] == 0.f)
{
symb_zero__ = TRUE_;
}
else
{
symb_zero__ = FALSE_;
y[iy] = *beta * (r__1 = y[iy], abs(r__1));
}
jx = kx;
if (*alpha != 0.f)
{
i__2 = i__;
for (j = 1;
j <= i__2;
++j)
{
i__3 = i__ + j * a_dim1;
temp = (r__1 = a[i__3].r, abs(r__1)) + (r__2 = r_imag( &a[i__ + j * a_dim1]), abs(r__2));
i__3 = j;
symb_zero__ = symb_zero__ && (x[i__3].r == 0.f && x[ i__3].i == 0.f || temp == 0.f);
i__3 = jx;
y[iy] += *alpha * ((r__1 = x[i__3].r, abs(r__1)) + ( r__2 = r_imag(&x[jx]), abs(r__2))) * temp;
jx += *incx;
}
i__2 = *n;
for (j = i__ + 1;
j <= i__2;
++j)
{
i__3 = j + i__ * a_dim1;
temp = (r__1 = a[i__3].r, abs(r__1)) + (r__2 = r_imag( &a[j + i__ * a_dim1]), abs(r__2));
i__3 = j;
symb_zero__ = symb_zero__ && (x[i__3].r == 0.f && x[ i__3].i == 0.f || temp == 0.f);
i__3 = jx;
y[iy] += *alpha * ((r__1 = x[i__3].r, abs(r__1)) + ( r__2 = r_imag(&x[jx]), abs(r__2))) * temp;
jx += *incx;
}
}
if (! symb_zero__)
{
y[iy] += r_sign(&safe1, &y[iy]);
}
iy += *incy;
}
}
}
return 0;
/* End of CLA_HEAMV */
}
/* Subroutine */ int sdrvgg_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, real *thresh, real *thrshn, integer *
nounit, real *a, integer *lda, real *b, real *s, real *t, real *s2,
real *t2, real *q, integer *ldq, real *z__, real *alphr1, real *
alphi1, real *beta1, real *alphr2, real *alphi2, real *beta2, real *
vl, real *vr, real *work, integer *lwork, real *result, 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 SDRVGG: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(\002 SDRVGG: SGET53 returned INFO=\002,i1,"
"\002 for eigenvalue \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JT"
"YPE=\002,i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9996[] = "(\002 SDRVGG: 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_9998[] = "(\002 SDRVGG: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
"i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9995[] = "(/1x,a3,\002 -- Real Generalized eigenvalue pr"
"oblem driver\002)";
static char fmt_9994[] = "(\002 Matrix types (see SDRVGG for details):"
" \002)";
static char fmt_9993[] = "(\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_9992[] = "(\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_9991[] = "(/\002 Tests performed: (S is Schur, T is tri"
"angular, \002,\002Q and Z are \002,a,\002,\002,/20x,\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 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 = difference between (alpha,beta"
") and diagonals of\002,\002 (S,T)\002,/\002 6 = max | ( b A - a "
"B )\002,a,\002 l | / const. 7 = max | ( b A - a B ) r | / cons"
"t.\002,/1x)";
static char fmt_9990[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
",0p,f8.2)";
static char fmt_9989[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
",1p,e10.3)";
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1,
s_offset, s2_dim1, s2_offset, t_dim1, t_offset, t2_dim1,
t2_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, z_dim1,
z_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10;
/* Builtin functions */
double r_sign(real *, real *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer j, n, i1, n1, jc, nb, in, jr, ns, nbz;
real ulp;
integer iadd, nmax;
real temp1, temp2;
logical badnn;
real dumma[4];
integer iinfo;
real rmagn[4];
extern /* Subroutine */ int sgegs_(char *, char *, integer *, real *,
integer *, real *, integer *, real *, real *, real *, real *,
integer *, real *, integer *, real *, integer *, integer *), sget51_(integer *, integer *, real *, integer *,
real *, integer *, real *, integer *, real *, integer *, real *,
real *), sget52_(logical *, integer *, real *, integer *, real *,
integer *, real *, integer *, real *, real *, real *, real *,
real *), sgegv_(char *, char *, integer *, real *, integer *,
real *, integer *, real *, real *, real *, real *, integer *,
real *, integer *, real *, integer *, integer *),
sget53_(real *, integer *, real *, integer *, real *, real *,
real *, real *, integer *);
integer nmats, jsize, nerrs, jtype, ntest;
extern /* Subroutine */ int slatm4_(integer *, integer *, integer *,
integer *, integer *, real *, real *, real *, integer *, integer *
, real *, integer *);
logical ilabad;
extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *), slabad_(real *, real *);
extern doublereal slamch_(char *);
real safmin;
integer ioldsd[4];
real safmax;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
real *);
extern doublereal slarnd_(integer *, integer *);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *), xerbla_(char *, integer *),
slacpy_(char *, integer *, integer *, real *, integer *, real *,
integer *), slaset_(char *, integer *, integer *, real *,
real *, real *, integer *);
real ulpinv;
integer lwkopt, mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9990, 0 };
static cilist io___60 = { 0, 0, 0, fmt_9989, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SDRVGG checks the nonsymmetric generalized eigenvalue driver */
/* routines. */
/* T T T */
/* SGEGS 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(1),beta(1)), ..., */
/* (alpha(n),beta(n)), where alpha(j)=S(j,j) and beta(j)=P(j,j) -- */
/* thus, w(j) = alpha(j)/beta(j) is a root of the generalized */
/* eigenvalue problem */
/* det( A - w(j) B ) = 0 */
/* and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent */
/* problem */
/* det( m(j) A - B ) = 0 */
/* SGEGV computes the generalized eigenvalues (alpha(1),beta(1)), ..., */
/* (alpha(n),beta(n)), the matrix L whose columns contain the */
/* generalized left eigenvectors l, and the matrix R whose columns */
/* contain the generalized right eigenvectors r for the pair (A,B). */
/* When SDRVGG is called, a number of matrix "sizes" ("n's") and a */
/* number of matrix "types" are specified. For each size ("n") */
/* and each type of matrix, one matrix will be generated and used */
/* to test the nonsymmetric eigenroutines. For each matrix, 7 */
/* tests will be performed and compared with the threshhold THRESH: */
/* Results from SGEGS: */
/* T */
/* (1) | A - Q S Z | / ( |A| n ulp ) */
/* T */
/* (2) | B - Q T Z | / ( |B| n ulp ) */
/* T */
/* (3) | I - QQ | / ( n ulp ) */
/* T */
/* (4) | I - ZZ | / ( n ulp ) */
/* (5) 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 eigenvalue. */
/* Results from SGEGV: */
/* (6) max over all left eigenvalue/-vector pairs (beta/alpha,l) of */
/* | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) ) */
/* where l**H is the conjugate tranpose of l. */
/* (7) max over all right eigenvalue/-vector pairs (beta/alpha,r) of */
/* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) ) */
/* 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, */
/* SDRVGG does nothing. It must be at least zero. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. If it is zero, SDRVGG */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A. This */
/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* 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 SDRVGG to continue the same random number */
/* sequence. */
/* THRESH (input) REAL */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error is */
/* scaled to be O(1), so THRESH should be a reasonably small */
/* multiple of 1, e.g., 10 or 100. In particular, it should */
/* not depend on the precision (single vs. double) or the size */
/* of the matrix. It must be at least zero. */
/* THRSHN (input) REAL */
/* Threshhold for reporting eigenvector normalization error. */
/* If the normalization of any eigenvector differs from 1 by */
/* more than THRSHN*ulp, then a special error message will be */
/* printed. (This is handled separately from the other tests, */
/* since only a compiler or programming error should cause an */
/* error message, at least if THRSHN is at least 5--10.) */
/* 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) REAL 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, T, S2, and T2. */
/* It must be at least 1 and at least max( NN ). */
/* B (input/workspace) REAL 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) REAL array, dimension (LDA, max(NN)) */
/* The Schur form matrix computed from A by SGEGS. On exit, S */
/* contains the Schur form matrix corresponding to the matrix */
/* in A. */
/* T (workspace) REAL array, dimension (LDA, max(NN)) */
/* The upper triangular matrix computed from B by SGEGS. */
/* S2 (workspace) REAL array, dimension (LDA, max(NN)) */
/* The matrix computed from A by SGEGV. This will be the */
/* Schur form of some matrix related to A, but will not, in */
/* general, be the same as S. */
/* T2 (workspace) REAL array, dimension (LDA, max(NN)) */
/* The matrix computed from B by SGEGV. This will be the */
/* Schur form of some matrix related to B, but will not, in */
/* general, be the same as T. */
/* Q (workspace) REAL array, dimension (LDQ, max(NN)) */
/* The (left) orthogonal matrix computed by SGEGS. */
/* LDQ (input) INTEGER */
/* The leading dimension of Q, Z, VL, and VR. It must */
/* be at least 1 and at least max( NN ). */
/* Z (workspace) REAL array of */
/* dimension( LDQ, max(NN) ) */
/* The (right) orthogonal matrix computed by SGEGS. */
/* ALPHR1 (workspace) REAL array, dimension (max(NN)) */
/* ALPHI1 (workspace) REAL array, dimension (max(NN)) */
/* BETA1 (workspace) REAL array, dimension (max(NN)) */
/* The generalized eigenvalues of (A,B) computed by SGEGS. */
/* ( ALPHR1(k)+ALPHI1(k)*i ) / BETA1(k) is the k-th */
/* generalized eigenvalue of the matrices in A and B. */
/* ALPHR2 (workspace) REAL array, dimension (max(NN)) */
/* ALPHI2 (workspace) REAL array, dimension (max(NN)) */
/* BETA2 (workspace) REAL array, dimension (max(NN)) */
/* The generalized eigenvalues of (A,B) computed by SGEGV. */
/* ( ALPHR2(k)+ALPHI2(k)*i ) / BETA2(k) is the k-th */
/* generalized eigenvalue of the matrices in A and B. */
/* VL (workspace) REAL array, dimension (LDQ, max(NN)) */
/* The (block lower triangular) left eigenvector matrix for */
/* the matrices in A and B. (See STGEVC for the format.) */
/* VR (workspace) REAL array, dimension (LDQ, max(NN)) */
/* The (block upper triangular) right eigenvector matrix for */
/* the matrices in A and B. (See STGEVC for the format.) */
/* WORK (workspace) REAL array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* 2*N + MAX( 6*N, N*(NB+1), (k+1)*(2*k+N+1) ), where */
/* "k" is the sum of the blocksize and number-of-shifts for */
/* SHGEQZ, and NB is the greatest of the blocksizes for */
/* SGEQRF, SORMQR, and SORGQR. (The blocksizes and the */
/* number-of-shifts are retrieved through calls to ILAENV.) */
/* RESULT (output) REAL array, dimension (15) */
/* The values computed by the tests described above. */
/* The values are currently limited to 1/ulp, to avoid */
/* overflow. */
/* 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;
t2_dim1 = *lda;
t2_offset = 1 + t2_dim1;
t2 -= t2_offset;
s2_dim1 = *lda;
s2_offset = 1 + s2_dim1;
s2 -= s2_offset;
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;
vr_dim1 = *ldq;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
vl_dim1 = *ldq;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
z_dim1 = *ldq;
z_offset = 1 + z_dim1;
z__ -= z_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--alphr1;
--alphi1;
--beta1;
--alphr2;
--alphi2;
--beta2;
--work;
--result;
/* 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: */
}
/* Maximum blocksize and shift -- we assume that blocksize and number */
/* of shifts are monotone increasing functions of N. */
/* Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, "SGEQRF", " ", &nmax, &nmax, &c_n1, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
c__1, "SORMQR", "LT", &nmax, &nmax, &nmax, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&c__1, "SORGQR",
" ", &nmax, &nmax, &nmax, &c_n1);
nb = max(i__1,i__2);
nbz = ilaenv_(&c__1, "SHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0);
ns = ilaenv_(&c__4, "SHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0);
i1 = nbz + ns;
/* Computing MAX */
i__1 = nmax * 6, i__2 = nmax * (nb + 1), i__1 = max(i__1,i__2), i__2 = ((
i1 << 1) + nmax + 1) * (i1 + 1);
lwkopt = (nmax << 1) + max(i__1,i__2);
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.f) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -10;
} else if (*ldq <= 1 || *ldq < nmax) {
*info = -19;
} else if (lwkopt > *lwork) {
*info = -30;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SDRVGG", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
safmin = slamch_("Safe minimum");
ulp = slamch_("Epsilon") * slamch_("Base");
safmin /= ulp;
safmax = 1.f / safmin;
slabad_(&safmin, &safmax);
ulpinv = 1.f / ulp;
/* The values RMAGN(2:3) depend on N, see below. */
rmagn[0] = 0.f;
rmagn[1] = 1.f;
/* Loop over sizes, types */
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 / (real) n1;
rmagn[3] = safmin * ulpinv * n1;
if (*nsizes != 1) {
mtypes = min(26,*ntypes);
} else {
mtypes = min(27,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L160;
}
++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 <= 15; ++j) {
result[j] = 0.f;
/* L30: */
}
/* Compute A and B */
/* Description of control parameters: */
/* KCLASS: =1 means w/o rotation, =2 means w/ rotation, */
/* =3 means random. */
/* KATYPE: the "type" to be passed to SLATM4 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) {
slaset_("Full", &n, &n, &c_b36, &c_b36, &a[a_offset],
lda);
}
} else {
in = n;
}
slatm4_(&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.f;
}
/* Generate B (w/o rotation) */
if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
slaset_("Full", &n, &n, &c_b36, &c_b36, &b[b_offset],
lda);
}
} else {
in = n;
}
slatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
&kz2[kbzero[jtype - 1] - 1], &ibsign[jtype - 1], &
rmagn[kbmagn[jtype - 1]], &c_b42, &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.f;
}
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] = slarnd_(&c__3, &iseed[1]);
z__[jr + jc * z_dim1] = slarnd_(&c__3, &iseed[1]);
/* L40: */
}
i__4 = n + 1 - jc;
slarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc *
q_dim1], &c__1, &work[jc]);
work[(n << 1) + jc] = r_sign(&c_b42, &q[jc + jc *
q_dim1]);
q[jc + jc * q_dim1] = 1.f;
i__4 = n + 1 - jc;
slarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 +
jc * z_dim1], &c__1, &work[n + jc]);
work[n * 3 + jc] = r_sign(&c_b42, &z__[jc + jc *
z_dim1]);
z__[jc + jc * z_dim1] = 1.f;
/* L50: */
}
q[n + n * q_dim1] = 1.f;
work[n] = 0.f;
r__1 = slarnd_(&c__2, &iseed[1]);
work[n * 3] = r_sign(&c_b42, &r__1);
z__[n + n * z_dim1] = 1.f;
work[n * 2] = 0.f;
r__1 = slarnd_(&c__2, &iseed[1]);
work[n * 4] = r_sign(&c_b42, &r__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;
sorm2r_("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;
sorm2r_("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;
sorm2r_("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;
sorm2r_("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]] *
slarnd_(&c__2, &iseed[1]);
b[jr + jc * b_dim1] = rmagn[kbmagn[jtype - 1]] *
slarnd_(&c__2, &iseed[1]);
/* L80: */
}
/* L90: */
}
}
L100:
if (iinfo != 0) {
io___42.ciunit = *nounit;
s_wsfe(&io___42);
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:
/* Call SGEGS to compute H, T, Q, Z, alpha, and beta. */
slacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
slacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
ntest = 1;
result[1] = ulpinv;
sgegs_("V", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
alphr1[1], &alphi1[1], &beta1[1], &q[q_offset], ldq, &z__[
z_offset], ldq, &work[1], lwork, &iinfo);
if (iinfo != 0) {
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, "SGEGS", (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 L140;
}
ntest = 4;
/* Do tests 1--4 */
sget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, &q[
q_offset], ldq, &z__[z_offset], ldq, &work[1], &result[1])
;
sget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
q_offset], ldq, &z__[z_offset], ldq, &work[1], &result[2])
;
sget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
q_offset], ldq, &q[q_offset], ldq, &work[1], &result[3]);
sget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[
z_offset], ldq, &z__[z_offset], ldq, &work[1], &result[4])
;
/* Do test 5: compare eigenvalues with diagonals. */
/* Also check Schur form of A. */
temp1 = 0.f;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
ilabad = FALSE_;
if (alphi1[j] == 0.f) {
/* Computing MAX */
r__7 = safmin, r__8 = (r__2 = alphr1[j], dabs(r__2)),
r__7 = max(r__7,r__8), r__8 = (r__3 = s[j + j *
s_dim1], dabs(r__3));
/* Computing MAX */
r__9 = safmin, r__10 = (r__5 = beta1[j], dabs(r__5)),
r__9 = max(r__9,r__10), r__10 = (r__6 = t[j + j *
t_dim1], dabs(r__6));
temp2 = ((r__1 = alphr1[j] - s[j + j * s_dim1], dabs(r__1)
) / dmax(r__7,r__8) + (r__4 = beta1[j] - t[j + j *
t_dim1], dabs(r__4)) / dmax(r__9,r__10)) / ulp;
if (j < n) {
if (s[j + 1 + j * s_dim1] != 0.f) {
ilabad = TRUE_;
}
}
if (j > 1) {
if (s[j + (j - 1) * s_dim1] != 0.f) {
ilabad = TRUE_;
}
}
} else {
if (alphi1[j] > 0.f) {
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.f) {
ilabad = TRUE_;
}
} else if (i1 > 1) {
if (s[i1 + (i1 - 1) * s_dim1] != 0.f) {
ilabad = TRUE_;
}
}
if (! ilabad) {
sget53_(&s[i1 + i1 * s_dim1], lda, &t[i1 + i1 *
t_dim1], lda, &beta1[j], &alphr1[j], &alphi1[
j], &temp2, &iinfo);
if (iinfo >= 3) {
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, (char *)&iinfo, (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(iinfo);
}
} else {
temp2 = ulpinv;
}
}
temp1 = dmax(temp1,temp2);
if (ilabad) {
io___48.ciunit = *nounit;
s_wsfe(&io___48);
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();
}
/* L120: */
}
result[5] = temp1;
/* Call SGEGV to compute S2, T2, VL, and VR, do tests. */
/* Eigenvalues and Eigenvectors */
slacpy_(" ", &n, &n, &a[a_offset], lda, &s2[s2_offset], lda);
slacpy_(" ", &n, &n, &b[b_offset], lda, &t2[t2_offset], lda);
ntest = 6;
result[6] = ulpinv;
sgegv_("V", "V", &n, &s2[s2_offset], lda, &t2[t2_offset], lda, &
alphr2[1], &alphi2[1], &beta2[1], &vl[vl_offset], ldq, &
vr[vr_offset], ldq, &work[1], lwork, &iinfo);
if (iinfo != 0) {
io___49.ciunit = *nounit;
s_wsfe(&io___49);
do_fio(&c__1, "SGEGV", (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 L140;
}
ntest = 7;
/* Do Tests 6 and 7 */
sget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &vl[
vl_offset], ldq, &alphr2[1], &alphi2[1], &beta2[1], &work[
1], dumma);
result[6] = dumma[0];
if (dumma[1] > *thrshn) {
io___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "SGEGV", (ftnlen)5);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
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();
}
sget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &vr[
vr_offset], ldq, &alphr2[1], &alphi2[1], &beta2[1], &work[
1], dumma);
result[7] = dumma[0];
if (dumma[1] > *thresh) {
io___52.ciunit = *nounit;
s_wsfe(&io___52);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "SGEGV", (ftnlen)5);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
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();
}
/* Check form of Complex eigenvalues. */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
ilabad = FALSE_;
if (alphi2[j] > 0.f) {
if (j == n) {
ilabad = TRUE_;
} else if (alphi2[j + 1] >= 0.f) {
ilabad = TRUE_;
}
} else if (alphi2[j] < 0.f) {
if (j == 1) {
ilabad = TRUE_;
} else if (alphi2[j - 1] <= 0.f) {
ilabad = TRUE_;
}
}
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: */
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L140:
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___54.ciunit = *nounit;
s_wsfe(&io___54);
do_fio(&c__1, "SGG", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___55.ciunit = *nounit;
s_wsfe(&io___55);
e_wsfe();
io___56.ciunit = *nounit;
s_wsfe(&io___56);
e_wsfe();
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, "Orthogonal", (ftnlen)10);
e_wsfe();
/* Tests performed */
io___58.ciunit = *nounit;
s_wsfe(&io___58);
do_fio(&c__1, "orthogonal", (ftnlen)10);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (j = 1; j <= 5; ++j) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[jr] < 1e4f) {
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__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(
real));
e_wsfe();
} else {
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(
real));
e_wsfe();
}
}
/* L150: */
}
L160:
;
}
/* L170: */
}
/* Summary */
alasvm_("SGG", nounit, &nerrs, &ntestt, &c__0);
return 0;
/* End of SDRVGG */
} /* sdrvgg_ */
/* Subroutine */ int slaed3_(integer *k, integer *n, integer *n1, real *d__,
real *q, integer *ldq, real *rho, real *dlamda, real *q2, integer *
indx, integer *ctot, real *w, real *s, integer *info)
{
/* System generated locals */
integer q_dim1, q_offset, i__1, i__2;
real r__1;
/* Builtin functions */
double sqrt(doublereal), r_sign(real *, real *);
/* Local variables */
integer i__, j, n2, n12, ii, n23, iq2;
real temp;
extern doublereal snrm2_(integer *, real *, integer *);
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *), scopy_(integer *, real *,
integer *, real *, integer *), slaed4_(integer *, integer *, real
*, real *, real *, real *, real *, integer *);
extern doublereal slamc3_(real *, real *);
extern /* Subroutine */ int xerbla_(char *, integer *), slacpy_(
char *, integer *, integer *, real *, integer *, real *, integer *
), slaset_(char *, integer *, integer *, real *, real *,
real *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLAED3 finds the roots of the secular equation, as defined by the */
/* values in D, W, and RHO, between 1 and K. It makes the */
/* appropriate calls to SLAED4 and then updates the eigenvectors by */
/* multiplying the matrix of eigenvectors of the pair of eigensystems */
/* being combined by the matrix of eigenvectors of the K-by-K system */
/* which is solved here. */
/* This code makes very mild assumptions about floating point */
/* arithmetic. It will work on machines with a guard digit in */
/* add/subtract, or on those binary machines without guard digits */
/* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */
/* It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. */
/* Arguments */
/* ========= */
/* K (input) INTEGER */
/* The number of terms in the rational function to be solved by */
/* SLAED4. K >= 0. */
/* N (input) INTEGER */
/* The number of rows and columns in the Q matrix. */
/* N >= K (deflation may result in N>K). */
/* N1 (input) INTEGER */
/* The location of the last eigenvalue in the leading submatrix. */
/* min(1,N) <= N1 <= N/2. */
/* D (output) REAL array, dimension (N) */
/* D(I) contains the updated eigenvalues for */
/* 1 <= I <= K. */
/* Q (output) REAL array, dimension (LDQ,N) */
/* Initially the first K columns are used as workspace. */
/* On output the columns 1 to K contain */
/* the updated eigenvectors. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= max(1,N). */
/* RHO (input) REAL */
/* The value of the parameter in the rank one update equation. */
/* RHO >= 0 required. */
/* DLAMDA (input/output) REAL array, dimension (K) */
/* The first K elements of this array contain the old roots */
/* of the deflated updating problem. These are the poles */
/* of the secular equation. May be changed on output by */
/* having lowest order bit set to zero on Cray X-MP, Cray Y-MP, */
/* Cray-2, or Cray C-90, as described above. */
/* Q2 (input) REAL array, dimension (LDQ2, N) */
/* The first K columns of this matrix contain the non-deflated */
/* eigenvectors for the split problem. */
/* INDX (input) INTEGER array, dimension (N) */
/* The permutation used to arrange the columns of the deflated */
/* Q matrix into three groups (see SLAED2). */
/* The rows of the eigenvectors found by SLAED4 must be likewise */
/* permuted before the matrix multiply can take place. */
/* CTOT (input) INTEGER array, dimension (4) */
/* A count of the total number of the various types of columns */
/* in Q, as described in INDX. The fourth column type is any */
/* column which has been deflated. */
/* W (input/output) REAL array, dimension (K) */
/* The first K elements of this array contain the components */
/* of the deflation-adjusted updating vector. Destroyed on */
/* output. */
/* S (workspace) REAL array, dimension (N1 + 1)*K */
/* Will contain the eigenvectors of the repaired matrix which */
/* will be multiplied by the previously accumulated eigenvectors */
/* to update the system. */
/* LDS (input) INTEGER */
/* The leading dimension of S. LDS >= max(1,K). */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = 1, an eigenvalue did not converge */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Jeff Rutter, Computer Science Division, University of California */
/* at Berkeley, USA */
/* Modified by Francoise Tisseur, University of Tennessee. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--dlamda;
--q2;
--indx;
--ctot;
--w;
--s;
/* Function Body */
*info = 0;
if (*k < 0) {
*info = -1;
} else if (*n < *k) {
*info = -2;
} else if (*ldq < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SLAED3", &i__1);
return 0;
}
/* Quick return if possible */
if (*k == 0) {
return 0;
}
/* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */
/* be computed with high relative accuracy (barring over/underflow). */
/* This is a problem on machines without a guard digit in */
/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */
/* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), */
/* which on any of these machines zeros out the bottommost */
/* bit of DLAMDA(I) if it is 1; this makes the subsequent */
/* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation */
/* occurs. On binary machines with a guard digit (almost all */
/* machines) it does not change DLAMDA(I) at all. On hexadecimal */
/* and decimal machines with a guard digit, it slightly */
/* changes the bottommost bits of DLAMDA(I). It does not account */
/* for hexadecimal or decimal machines without guard digits */
/* (we know of none). We use a subroutine call to compute */
/* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating */
/* this code. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
dlamda[i__] = slamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__];
/* L10: */
}
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
slaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j],
info);
/* If the zero finder fails, the computation is terminated. */
if (*info != 0) {
goto L120;
}
/* L20: */
}
if (*k == 1) {
goto L110;
}
if (*k == 2) {
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
w[1] = q[j * q_dim1 + 1];
w[2] = q[j * q_dim1 + 2];
ii = indx[1];
q[j * q_dim1 + 1] = w[ii];
ii = indx[2];
q[j * q_dim1 + 2] = w[ii];
/* L30: */
}
goto L110;
}
/* Compute updated W. */
scopy_(k, &w[1], &c__1, &s[1], &c__1);
/* Initialize W(I) = Q(I,I) */
i__1 = *ldq + 1;
scopy_(k, &q[q_offset], &i__1, &w[1], &c__1);
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
/* L40: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
/* L50: */
}
/* L60: */
}
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
r__1 = sqrt(-w[i__]);
w[i__] = r_sign(&r__1, &s[i__]);
/* L70: */
}
/* Compute eigenvectors of the modified rank-1 modification. */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *k;
for (i__ = 1; i__ <= i__2; ++i__) {
s[i__] = w[i__] / q[i__ + j * q_dim1];
/* L80: */
}
temp = snrm2_(k, &s[1], &c__1);
i__2 = *k;
for (i__ = 1; i__ <= i__2; ++i__) {
ii = indx[i__];
q[i__ + j * q_dim1] = s[ii] / temp;
/* L90: */
}
/* L100: */
}
/* Compute the updated eigenvectors. */
L110:
n2 = *n - *n1;
n12 = ctot[1] + ctot[2];
n23 = ctot[2] + ctot[3];
slacpy_("A", &n23, k, &q[ctot[1] + 1 + q_dim1], ldq, &s[1], &n23);
iq2 = *n1 * n12 + 1;
if (n23 != 0) {
sgemm_("N", "N", &n2, k, &n23, &c_b22, &q2[iq2], &n2, &s[1], &n23, &
c_b23, &q[*n1 + 1 + q_dim1], ldq);
} else {
slaset_("A", &n2, k, &c_b23, &c_b23, &q[*n1 + 1 + q_dim1], ldq);
}
slacpy_("A", &n12, k, &q[q_offset], ldq, &s[1], &n12);
if (n12 != 0) {
sgemm_("N", "N", n1, k, &n12, &c_b22, &q2[1], n1, &s[1], &n12, &c_b23,
&q[q_offset], ldq);
} else {
slaset_("A", n1, k, &c_b23, &c_b23, &q[q_dim1 + 1], ldq);
}
L120:
return 0;
/* End of SLAED3 */
} /* slaed3_ */
/* DECK FZERO */
/* Subroutine */ int fzero_(E_fp f, real *b, real *c__, real *r__, real *re,
real *ae, integer *iflag)
{
/* System generated locals */
real r__1, r__2;
/* Local variables */
static real a, p, q, t, z__, fa, fb, fc;
static integer ic;
static real aw, er, fx, fz, rw, cmb, tol, acmb, acbs;
static integer kount;
extern doublereal r1mach_(integer *);
/* ***BEGIN PROLOGUE FZERO */
/* ***PURPOSE Search for a zero of a function F(X) in a given interval */
/* (B,C). It is designed primarily for problems where F(B) */
/* and F(C) have opposite signs. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY F1B */
/* ***TYPE SINGLE PRECISION (FZERO-S, DFZERO-D) */
/* ***KEYWORDS BISECTION, NONLINEAR EQUATIONS, ROOTS, ZEROS */
/* ***AUTHOR Shampine, L. F., (SNLA) */
/* Watts, H. A., (SNLA) */
/* ***DESCRIPTION */
/* FZERO searches for a zero of a REAL function F(X) between the */
/* given REAL values B and C until the width of the interval (B,C) */
/* has collapsed to within a tolerance specified by the stopping */
/* criterion, */
/* ABS(B-C) .LE. 2.*(RW*ABS(B)+AE). */
/* The method used is an efficient combination of bisection and the */
/* secant rule and is due to T. J. Dekker. */
/* Description Of Arguments */
/* F :EXT - Name of the REAL external function. This name must */
/* be in an EXTERNAL statement in the calling program. */
/* F must be a function of one REAL argument. */
/* B :INOUT - One end of the REAL interval (B,C). The value */
/* returned for B usually is the better approximation */
/* to a zero of F. */
/* C :INOUT - The other end of the REAL interval (B,C) */
/* R :OUT - A (better) REAL guess of a zero of F which could help */
/* in speeding up convergence. If F(B) and F(R) have */
/* opposite signs, a root will be found in the interval */
/* (B,R); if not, but F(R) and F(C) have opposite signs, */
/* a root will be found in the interval (R,C); */
/* otherwise, the interval (B,C) will be searched for a */
/* possible root. When no better guess is known, it is */
/* recommended that r be set to B or C, since if R is */
/* not interior to the interval (B,C), it will be */
/* ignored. */
/* RE :IN - Relative error used for RW in the stopping criterion. */
/* If the requested RE is less than machine precision, */
/* then RW is set to approximately machine precision. */
/* AE :IN - Absolute error used in the stopping criterion. If */
/* the given interval (B,C) contains the origin, then a */
/* nonzero value should be chosen for AE. */
/* IFLAG :OUT - A status code. User must check IFLAG after each */
/* call. Control returns to the user from FZERO in all */
/* cases. */
/* 1 B is within the requested tolerance of a zero. */
/* The interval (B,C) collapsed to the requested */
/* tolerance, the function changes sign in (B,C), and */
/* F(X) decreased in magnitude as (B,C) collapsed. */
/* 2 F(B) = 0. However, the interval (B,C) may not have */
/* collapsed to the requested tolerance. */
/* 3 B may be near a singular point of F(X). */
/* The interval (B,C) collapsed to the requested tol- */
/* erance and the function changes sign in (B,C), but */
/* F(X) increased in magnitude as (B,C) collapsed, i.e. */
/* ABS(F(B out)) .GT. MAX(ABS(F(B in)),ABS(F(C in))) */
/* 4 No change in sign of F(X) was found although the */
/* interval (B,C) collapsed to the requested tolerance. */
/* The user must examine this case and decide whether */
/* B is near a local minimum of F(X), or B is near a */
/* zero of even multiplicity, or neither of these. */
/* 5 Too many (.GT. 500) function evaluations used. */
/* ***REFERENCES L. F. Shampine and H. A. Watts, FZERO, a root-solving */
/* code, Report SC-TM-70-631, Sandia Laboratories, */
/* September 1970. */
/* T. J. Dekker, Finding a zero by means of successive */
/* linear interpolation, Constructive Aspects of the */
/* Fundamental Theorem of Algebra, edited by B. Dejon */
/* and P. Henrici, Wiley-Interscience, 1969. */
/* ***ROUTINES CALLED R1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 700901 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890531 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE FZERO */
/* ***FIRST EXECUTABLE STATEMENT FZERO */
/* ER is two times the computer unit roundoff value which is defined */
/* here by the function R1MACH. */
er = r1mach_(&c__4) * 2.f;
/* Initialize. */
z__ = *r__;
if (*r__ <= dmin(*b,*c__) || *r__ >= dmax(*b,*c__)) {
z__ = *c__;
}
rw = dmax(*re,er);
aw = dmax(*ae,0.f);
ic = 0;
t = z__;
fz = (*f)(&t);
fc = fz;
t = *b;
fb = (*f)(&t);
kount = 2;
if (r_sign(&c_b3, &fz) == r_sign(&c_b3, &fb)) {
goto L1;
}
*c__ = z__;
goto L2;
L1:
if (z__ == *c__) {
goto L2;
}
t = *c__;
fc = (*f)(&t);
kount = 3;
if (r_sign(&c_b3, &fz) == r_sign(&c_b3, &fc)) {
goto L2;
}
*b = z__;
fb = fz;
L2:
a = *c__;
fa = fc;
acbs = (r__1 = *b - *c__, dabs(r__1));
/* Computing MAX */
r__1 = dabs(fb), r__2 = dabs(fc);
fx = dmax(r__1,r__2);
L3:
if (dabs(fc) >= dabs(fb)) {
goto L4;
}
/* Perform interchange. */
a = *b;
fa = fb;
*b = *c__;
fb = fc;
*c__ = a;
fc = fa;
L4:
cmb = (*c__ - *b) * .5f;
acmb = dabs(cmb);
tol = rw * dabs(*b) + aw;
/* Test stopping criterion and function count. */
if (acmb <= tol) {
goto L10;
}
if (fb == 0.f) {
goto L11;
}
if (kount >= 500) {
goto L14;
}
/* Calculate new iterate implicitly as B+P/Q, where we arrange */
/* P .GE. 0. The implicit form is used to prevent overflow. */
p = (*b - a) * fb;
q = fa - fb;
if (p >= 0.f) {
goto L5;
}
p = -p;
q = -q;
/* Update A and check for satisfactory reduction in the size of the */
/* bracketing interval. If not, perform bisection. */
L5:
a = *b;
fa = fb;
++ic;
if (ic < 4) {
goto L6;
}
if (acmb * 8.f >= acbs) {
goto L8;
}
ic = 0;
acbs = acmb;
/* Test for too small a change. */
L6:
if (p > dabs(q) * tol) {
goto L7;
}
/* Increment by TOLerance. */
*b += r_sign(&tol, &cmb);
goto L9;
/* Root ought to be between B and (C+B)/2. */
L7:
if (p >= cmb * q) {
goto L8;
}
/* Use secant rule. */
*b += p / q;
goto L9;
/* Use bisection (C+B)/2. */
L8:
*b += cmb;
/* Have completed computation for new iterate B. */
L9:
t = *b;
fb = (*f)(&t);
++kount;
/* Decide whether next step is interpolation or extrapolation. */
if (r_sign(&c_b3, &fb) != r_sign(&c_b3, &fc)) {
goto L3;
}
*c__ = a;
fc = fa;
goto L3;
/* Finished. Process results for proper setting of IFLAG. */
L10:
if (r_sign(&c_b3, &fb) == r_sign(&c_b3, &fc)) {
goto L13;
}
if (dabs(fb) > fx) {
goto L12;
}
*iflag = 1;
return 0;
L11:
*iflag = 2;
return 0;
L12:
*iflag = 3;
return 0;
L13:
*iflag = 4;
return 0;
L14:
*iflag = 5;
return 0;
} /* fzero_ */
/* Subroutine */ int slaic1_(integer *job, integer *j, real *x, real *sest,
real *w, real *gamma, real *sestpr, real *s, real *c__)
{
/* System generated locals */
real r__1, r__2, r__3, r__4;
/* Builtin functions */
double sqrt(doublereal), r_sign(real *, real *);
/* Local variables */
static real sine;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
static real test, zeta1, zeta2, b, t, alpha, norma, s1, s2, absgam,
absalp;
extern doublereal slamch_(char *);
static real cosine, absest, eps, tmp;
/* -- LAPACK auxiliary routine (instrumented to count ops, version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
SLAIC1 applies one step of incremental condition estimation in
its simplest version:
Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j
lower triangular matrix L, such that
twonorm(L*x) = sest
Then SLAIC1 computes sestpr, s, c such that
the vector
[ s*x ]
xhat = [ c ]
is an approximate singular vector of
[ L 0 ]
Lhat = [ w' gamma ]
in the sense that
twonorm(Lhat*xhat) = sestpr.
Depending on JOB, an estimate for the largest or smallest singular
value is computed.
Note that [s c]' and sestpr**2 is an eigenpair of the system
diag(sest*sest, 0) + [alpha gamma] * [ alpha ]
[ gamma ]
where alpha = x'*w.
Arguments
=========
JOB (input) INTEGER
= 1: an estimate for the largest singular value is computed.
= 2: an estimate for the smallest singular value is computed.
J (input) INTEGER
Length of X and W
X (input) REAL array, dimension (J)
The j-vector x.
SEST (input) REAL
Estimated singular value of j by j matrix L
W (input) REAL array, dimension (J)
The j-vector w.
GAMMA (input) REAL
The diagonal element gamma.
SESTPR (output) REAL
Estimated singular value of (j+1) by (j+1) matrix Lhat.
S (output) REAL
Sine needed in forming xhat.
C (output) REAL
Cosine needed in forming xhat.
=====================================================================
Parameter adjustments */
--w;
--x;
/* Function Body */
eps = slamch_("Epsilon");
alpha = sdot_(j, &x[1], &c__1, &w[1], &c__1);
absalp = dabs(alpha);
absgam = dabs(*gamma);
absest = dabs(*sest);
if (*job == 1) {
/* Estimating largest singular value
special cases */
if (*sest == 0.f) {
s1 = dmax(absgam,absalp);
if (s1 == 0.f) {
*s = 0.f;
*c__ = 1.f;
*sestpr = 0.f;
} else {
latime_1.ops += 9;
*s = alpha / s1;
*c__ = *gamma / s1;
tmp = sqrt(*s * *s + *c__ * *c__);
*s /= tmp;
*c__ /= tmp;
*sestpr = s1 * tmp;
}
return 0;
} else if (absgam <= eps * absest) {
latime_1.ops += 7;
*s = 1.f;
*c__ = 0.f;
tmp = dmax(absest,absalp);
s1 = absest / tmp;
s2 = absalp / tmp;
*sestpr = tmp * sqrt(s1 * s1 + s2 * s2);
return 0;
} else if (absalp <= eps * absest) {
s1 = absgam;
s2 = absest;
if (s1 <= s2) {
*s = 1.f;
*c__ = 0.f;
*sestpr = s2;
} else {
*s = 0.f;
*c__ = 1.f;
*sestpr = s1;
}
return 0;
} else if (absest <= eps * absalp || absest <= eps * absgam) {
s1 = absgam;
s2 = absalp;
if (s1 <= s2) {
latime_1.ops += 8;
tmp = s1 / s2;
*s = sqrt(tmp * tmp + 1.f);
*sestpr = s2 * *s;
*c__ = *gamma / s2 / *s;
*s = r_sign(&c_b5, &alpha) / *s;
} else {
latime_1.ops += 8;
tmp = s2 / s1;
*c__ = sqrt(tmp * tmp + 1.f);
*sestpr = s1 * *c__;
*s = alpha / s1 / *c__;
*c__ = r_sign(&c_b5, gamma) / *c__;
}
return 0;
} else {
/* normal case */
latime_1.ops += 8;
zeta1 = alpha / absest;
zeta2 = *gamma / absest;
b = (1.f - zeta1 * zeta1 - zeta2 * zeta2) * .5f;
*c__ = zeta1 * zeta1;
if (b > 0.f) {
latime_1.ops += 5;
t = *c__ / (b + sqrt(b * b + *c__));
} else {
latime_1.ops += 4;
t = sqrt(b * b + *c__) - b;
}
latime_1.ops += 12;
sine = -zeta1 / t;
cosine = -zeta2 / (t + 1.f);
tmp = sqrt(sine * sine + cosine * cosine);
*s = sine / tmp;
*c__ = cosine / tmp;
*sestpr = sqrt(t + 1.f) * absest;
return 0;
}
} else if (*job == 2) {
/* Estimating smallest singular value
special cases */
if (*sest == 0.f) {
*sestpr = 0.f;
if (dmax(absgam,absalp) == 0.f) {
sine = 1.f;
cosine = 0.f;
} else {
sine = -(*gamma);
cosine = alpha;
}
latime_1.ops += 7;
/* Computing MAX */
r__1 = dabs(sine), r__2 = dabs(cosine);
s1 = dmax(r__1,r__2);
*s = sine / s1;
*c__ = cosine / s1;
tmp = sqrt(*s * *s + *c__ * *c__);
*s /= tmp;
*c__ /= tmp;
return 0;
} else if (absgam <= eps * absest) {
*s = 0.f;
*c__ = 1.f;
*sestpr = absgam;
return 0;
} else if (absalp <= eps * absest) {
s1 = absgam;
s2 = absest;
if (s1 <= s2) {
*s = 0.f;
*c__ = 1.f;
*sestpr = s1;
} else {
*s = 1.f;
*c__ = 0.f;
*sestpr = s2;
}
return 0;
} else if (absest <= eps * absalp || absest <= eps * absgam) {
s1 = absgam;
s2 = absalp;
if (s1 <= s2) {
latime_1.ops += 9;
tmp = s1 / s2;
*c__ = sqrt(tmp * tmp + 1.f);
*sestpr = absest * (tmp / *c__);
*s = -(*gamma / s2) / *c__;
*c__ = r_sign(&c_b5, &alpha) / *c__;
} else {
latime_1.ops += 8;
tmp = s2 / s1;
*s = sqrt(tmp * tmp + 1.f);
*sestpr = absest / *s;
*c__ = alpha / s1 / *s;
*s = -r_sign(&c_b5, gamma) / *s;
}
return 0;
} else {
/* normal case */
latime_1.ops += 14;
zeta1 = alpha / absest;
zeta2 = *gamma / absest;
/* Computing MAX */
r__3 = zeta1 * zeta1 + 1.f + (r__1 = zeta1 * zeta2, dabs(r__1)),
r__4 = (r__2 = zeta1 * zeta2, dabs(r__2)) + zeta2 * zeta2;
norma = dmax(r__3,r__4);
/* See if root is closer to zero or to ONE */
test = (zeta1 - zeta2) * 2.f * (zeta1 + zeta2) + 1.f;
if (test >= 0.f) {
/* root is close to zero, compute directly */
latime_1.ops += 20;
b = (zeta1 * zeta1 + zeta2 * zeta2 + 1.f) * .5f;
*c__ = zeta2 * zeta2;
t = *c__ / (b + sqrt((r__1 = b * b - *c__, dabs(r__1))));
sine = zeta1 / (1.f - t);
cosine = -zeta2 / t;
*sestpr = sqrt(t + eps * 4.f * eps * norma) * absest;
} else {
/* root is closer to ONE, shift by that amount */
latime_1.ops += 6;
b = (zeta2 * zeta2 + zeta1 * zeta1 - 1.f) * .5f;
*c__ = zeta1 * zeta1;
if (b >= 0.f) {
latime_1.ops += 5;
t = -(*c__) / (b + sqrt(b * b + *c__));
} else {
latime_1.ops += 4;
t = b - sqrt(b * b + *c__);
}
latime_1.ops += 10;
sine = -zeta1 / t;
cosine = -zeta2 / (t + 1.f);
*sestpr = sqrt(t + 1.f + eps * 4.f * eps * norma) * absest;
}
latime_1.ops += 6;
tmp = sqrt(sine * sine + cosine * cosine);
*s = sine / tmp;
*c__ = cosine / tmp;
return 0;
}
}
return 0;
/* End of SLAIC1 */
} /* slaic1_ */
/* Subroutine */ int slanv2_(real *a, real *b, real *c__, real *d__, real *
rt1r, real *rt1i, real *rt2r, real *rt2i, real *cs, real *sn)
{
/* System generated locals */
real r__1;
/* Builtin functions */
double r_sign(real *, real *), sqrt(doublereal);
/* Local variables */
static real p, aa, bb, cc, dd, cs1, sn1, sab, sac, tau, temp, sigma;
extern doublereal slapy2_(real *, real *);
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric */
/* matrix in standard form: */
/* [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] */
/* [ C D ] [ SN CS ] [ CC DD ] [-SN CS ] */
/* where either */
/* 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or */
/* 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex */
/* conjugate eigenvalues. */
/* Arguments */
/* ========= */
/* A (input/output) REAL */
/* B (input/output) REAL */
/* C (input/output) REAL */
/* D (input/output) REAL */
/* On entry, the elements of the input matrix. */
/* On exit, they are overwritten by the elements of the */
/* standardised Schur form. */
/* RT1R (output) REAL */
/* RT1I (output) REAL */
/* RT2R (output) REAL */
/* RT2I (output) REAL */
/* The real and imaginary parts of the eigenvalues. If the */
/* eigenvalues are both real, abs(RT1R) >= abs(RT2R); if the */
/* eigenvalues are a complex conjugate pair, RT1I > 0. */
/* CS (output) REAL */
/* SN (output) REAL */
/* Parameters of the rotation matrix. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Initialize CS and SN */
*cs = 1.f;
*sn = 0.f;
if (*c__ == 0.f) {
goto L10;
} else if (*b == 0.f) {
/* Swap rows and columns */
*cs = 0.f;
*sn = 1.f;
temp = *d__;
*d__ = *a;
*a = temp;
*b = -(*c__);
*c__ = 0.f;
goto L10;
} else if (*a - *d__ == 0.f && r_sign(&c_b3, b) != r_sign(&c_b3, c__)) {
goto L10;
} else {
/* Make diagonal elements equal */
temp = *a - *d__;
p = temp * .5f;
sigma = *b + *c__;
tau = slapy2_(&sigma, &temp);
cs1 = sqrt((dabs(sigma) / tau + 1.f) * .5f);
sn1 = -(p / (tau * cs1)) * r_sign(&c_b3, &sigma);
/* Compute [ AA BB ] = [ A B ] [ CS1 -SN1 ] */
/* [ CC DD ] [ C D ] [ SN1 CS1 ] */
aa = *a * cs1 + *b * sn1;
bb = -(*a) * sn1 + *b * cs1;
cc = *c__ * cs1 + *d__ * sn1;
dd = -(*c__) * sn1 + *d__ * cs1;
/* Compute [ A B ] = [ CS1 SN1 ] [ AA BB ] */
/* [ C D ] [-SN1 CS1 ] [ CC DD ] */
*a = aa * cs1 + cc * sn1;
*b = bb * cs1 + dd * sn1;
*c__ = -aa * sn1 + cc * cs1;
*d__ = -bb * sn1 + dd * cs1;
/* Accumulate transformation */
temp = *cs * cs1 - *sn * sn1;
*sn = *cs * sn1 + *sn * cs1;
*cs = temp;
temp = (*a + *d__) * .5f;
*a = temp;
*d__ = temp;
if (*c__ != 0.f) {
if (*b != 0.f) {
if (r_sign(&c_b3, b) == r_sign(&c_b3, c__)) {
/* Real eigenvalues: reduce to upper triangular form */
sab = sqrt((dabs(*b)));
sac = sqrt((dabs(*c__)));
r__1 = sab * sac;
p = r_sign(&r__1, c__);
tau = 1.f / sqrt((r__1 = *b + *c__, dabs(r__1)));
*a = temp + p;
*d__ = temp - p;
*b -= *c__;
*c__ = 0.f;
cs1 = sab * tau;
sn1 = sac * tau;
temp = *cs * cs1 - *sn * sn1;
*sn = *cs * sn1 + *sn * cs1;
*cs = temp;
}
} else {
*b = -(*c__);
*c__ = 0.f;
temp = *cs;
*cs = -(*sn);
*sn = temp;
}
}
}
L10:
/* Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). */
*rt1r = *a;
*rt2r = *d__;
if (*c__ == 0.f) {
*rt1i = 0.f;
*rt2i = 0.f;
} else {
*rt1i = sqrt((dabs(*b))) * sqrt((dabs(*c__)));
*rt2i = -(*rt1i);
}
return 0;
/* End of SLANV2 */
} /* slanv2_ */
/* DECK CUNK1 */
/* Subroutine */ int cunk1_(complex *z__, real *fnu, integer *kode, integer *
mr, integer *n, complex *y, integer *nz, real *tol, real *elim, real *
alim)
{
/* Initialized data */
static complex czero = {0.f,0.f};
static complex cone = {1.f,0.f};
static real pi = 3.14159265358979324f;
/* System generated locals */
integer i__1, i__2, i__3;
real r__1, r__2;
complex q__1, q__2, q__3, q__4, q__5;
/* Local variables */
static integer i__, j, k, m;
static real x;
static complex c1, c2, s1, s2;
static integer ib, ic;
static complex ck;
static real fn;
static integer il;
static complex cs;
static integer kk;
static complex cy[2];
static integer nw;
static complex rz, zr;
static real c2i, c2m, c2r, rs1, ang;
static complex cfn;
static real asc, fnf;
static integer ifn;
static complex phi[2];
static real cpn;
static integer iuf;
static real fmr;
static complex csr[3], css[3];
static real sgn;
static integer inu;
static real bry[3], spn;
static complex sum[2];
static real aphi;
static complex cscl, phid, crsc, csgn;
extern /* Subroutine */ int cs1s2_(complex *, complex *, complex *,
integer *, real *, real *, integer *);
static complex cspn;
static integer init[2];
static complex cwrk[48] /* was [16][3] */, sumd, zeta1[2], zeta2[2];
static integer iflag, kflag;
static real ascle;
static integer kdflg;
extern /* Subroutine */ int cuchk_(complex *, integer *, real *, real *);
static integer ipard, initd;
extern /* Subroutine */ int cunik_(complex *, real *, integer *, integer *
, real *, integer *, complex *, complex *, complex *, complex *,
complex *);
extern doublereal r1mach_(integer *);
static complex zeta1d, zeta2d;
/* ***BEGIN PROLOGUE CUNK1 */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to CBESK */
/* ***LIBRARY SLATEC */
/* ***TYPE ALL (CUNK1-A, ZUNK1-A) */
/* ***AUTHOR Amos, D. E., (SNL) */
/* ***DESCRIPTION */
/* CUNK1 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE */
/* RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE */
/* UNIFORM ASYMPTOTIC EXPANSION. */
/* MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. */
/* NZ=-1 MEANS AN OVERFLOW WILL OCCUR */
/* ***SEE ALSO CBESK */
/* ***ROUTINES CALLED CS1S2, CUCHK, CUNIK, R1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 830501 DATE WRITTEN */
/* 910415 Prologue converted to Version 4.0 format. (BAB) */
/* ***END PROLOGUE CUNK1 */
/* Parameter adjustments */
--y;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT CUNK1 */
kdflg = 1;
*nz = 0;
/* ----------------------------------------------------------------------- */
/* EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN */
/* THE UNDERFLOW LIMIT */
/* ----------------------------------------------------------------------- */
r__1 = 1.f / *tol;
q__1.r = r__1, q__1.i = 0.f;
cscl.r = q__1.r, cscl.i = q__1.i;
q__1.r = *tol, q__1.i = 0.f;
crsc.r = q__1.r, crsc.i = q__1.i;
css[0].r = cscl.r, css[0].i = cscl.i;
css[1].r = cone.r, css[1].i = cone.i;
css[2].r = crsc.r, css[2].i = crsc.i;
csr[0].r = crsc.r, csr[0].i = crsc.i;
csr[1].r = cone.r, csr[1].i = cone.i;
csr[2].r = cscl.r, csr[2].i = cscl.i;
bry[0] = r1mach_(&c__1) * 1e3f / *tol;
bry[1] = 1.f / bry[0];
bry[2] = r1mach_(&c__2);
x = z__->r;
zr.r = z__->r, zr.i = z__->i;
if (x < 0.f) {
q__1.r = -z__->r, q__1.i = -z__->i;
zr.r = q__1.r, zr.i = q__1.i;
}
j = 2;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* ----------------------------------------------------------------------- */
/* J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J */
/* ----------------------------------------------------------------------- */
j = 3 - j;
fn = *fnu + (i__ - 1);
init[j - 1] = 0;
cunik_(&zr, &fn, &c__2, &c__0, tol, &init[j - 1], &phi[j - 1], &zeta1[
j - 1], &zeta2[j - 1], &sum[j - 1], &cwrk[(j << 4) - 16]);
if (*kode == 1) {
goto L20;
}
q__1.r = fn, q__1.i = 0.f;
cfn.r = q__1.r, cfn.i = q__1.i;
i__2 = j - 1;
i__3 = j - 1;
q__4.r = zr.r + zeta2[i__3].r, q__4.i = zr.i + zeta2[i__3].i;
c_div(&q__3, &cfn, &q__4);
q__2.r = cfn.r * q__3.r - cfn.i * q__3.i, q__2.i = cfn.r * q__3.i +
cfn.i * q__3.r;
q__1.r = zeta1[i__2].r - q__2.r, q__1.i = zeta1[i__2].i - q__2.i;
s1.r = q__1.r, s1.i = q__1.i;
goto L30;
L20:
i__2 = j - 1;
i__3 = j - 1;
q__1.r = zeta1[i__2].r - zeta2[i__3].r, q__1.i = zeta1[i__2].i -
zeta2[i__3].i;
s1.r = q__1.r, s1.i = q__1.i;
L30:
/* ----------------------------------------------------------------------- */
/* TEST FOR UNDERFLOW AND OVERFLOW */
/* ----------------------------------------------------------------------- */
rs1 = s1.r;
if (dabs(rs1) > *elim) {
goto L60;
}
if (kdflg == 1) {
kflag = 2;
}
if (dabs(rs1) < *alim) {
goto L40;
}
/* ----------------------------------------------------------------------- */
/* REFINE TEST AND SCALE */
/* ----------------------------------------------------------------------- */
aphi = c_abs(&phi[j - 1]);
rs1 += log(aphi);
if (dabs(rs1) > *elim) {
goto L60;
}
if (kdflg == 1) {
kflag = 1;
}
if (rs1 < 0.f) {
goto L40;
}
if (kdflg == 1) {
kflag = 3;
}
L40:
/* ----------------------------------------------------------------------- */
/* SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR */
/* EXPONENT EXTREMES */
/* ----------------------------------------------------------------------- */
i__2 = j - 1;
i__3 = j - 1;
q__1.r = phi[i__2].r * sum[i__3].r - phi[i__2].i * sum[i__3].i,
q__1.i = phi[i__2].r * sum[i__3].i + phi[i__2].i * sum[i__3]
.r;
s2.r = q__1.r, s2.i = q__1.i;
c2r = s1.r;
c2i = r_imag(&s1);
i__2 = kflag - 1;
c2m = exp(c2r) * css[i__2].r;
q__2.r = c2m, q__2.i = 0.f;
r__1 = cos(c2i);
r__2 = sin(c2i);
q__3.r = r__1, q__3.i = r__2;
q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * q__3.i
+ q__2.i * q__3.r;
s1.r = q__1.r, s1.i = q__1.i;
q__1.r = s2.r * s1.r - s2.i * s1.i, q__1.i = s2.r * s1.i + s2.i *
s1.r;
s2.r = q__1.r, s2.i = q__1.i;
if (kflag != 1) {
goto L50;
}
cuchk_(&s2, &nw, bry, tol);
if (nw != 0) {
goto L60;
}
L50:
i__2 = kdflg - 1;
cy[i__2].r = s2.r, cy[i__2].i = s2.i;
i__2 = i__;
i__3 = kflag - 1;
q__1.r = s2.r * csr[i__3].r - s2.i * csr[i__3].i, q__1.i = s2.r * csr[
i__3].i + s2.i * csr[i__3].r;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
if (kdflg == 2) {
goto L75;
}
kdflg = 2;
goto L70;
L60:
if (rs1 > 0.f) {
goto L290;
}
/* ----------------------------------------------------------------------- */
/* FOR X.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW */
/* ----------------------------------------------------------------------- */
if (x < 0.f) {
goto L290;
}
kdflg = 1;
i__2 = i__;
y[i__2].r = czero.r, y[i__2].i = czero.i;
++(*nz);
if (i__ == 1) {
goto L70;
}
i__2 = i__ - 1;
if (y[i__2].r == czero.r && y[i__2].i == czero.i) {
goto L70;
}
i__2 = i__ - 1;
y[i__2].r = czero.r, y[i__2].i = czero.i;
++(*nz);
L70:
;
}
i__ = *n;
L75:
c_div(&q__1, &c_b14, &zr);
rz.r = q__1.r, rz.i = q__1.i;
q__2.r = fn, q__2.i = 0.f;
q__1.r = q__2.r * rz.r - q__2.i * rz.i, q__1.i = q__2.r * rz.i + q__2.i *
rz.r;
ck.r = q__1.r, ck.i = q__1.i;
ib = i__ + 1;
if (*n < ib) {
goto L160;
}
/* ----------------------------------------------------------------------- */
/* TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW, SET SEQUENCE TO ZERO */
/* ON UNDERFLOW */
/* ----------------------------------------------------------------------- */
fn = *fnu + (*n - 1);
ipard = 1;
if (*mr != 0) {
ipard = 0;
}
initd = 0;
cunik_(&zr, &fn, &c__2, &ipard, tol, &initd, &phid, &zeta1d, &zeta2d, &
sumd, &cwrk[32]);
if (*kode == 1) {
goto L80;
}
q__1.r = fn, q__1.i = 0.f;
cfn.r = q__1.r, cfn.i = q__1.i;
q__4.r = zr.r + zeta2d.r, q__4.i = zr.i + zeta2d.i;
c_div(&q__3, &cfn, &q__4);
q__2.r = cfn.r * q__3.r - cfn.i * q__3.i, q__2.i = cfn.r * q__3.i + cfn.i
* q__3.r;
q__1.r = zeta1d.r - q__2.r, q__1.i = zeta1d.i - q__2.i;
s1.r = q__1.r, s1.i = q__1.i;
goto L90;
L80:
q__1.r = zeta1d.r - zeta2d.r, q__1.i = zeta1d.i - zeta2d.i;
s1.r = q__1.r, s1.i = q__1.i;
L90:
rs1 = s1.r;
if (dabs(rs1) > *elim) {
goto L95;
}
if (dabs(rs1) < *alim) {
goto L100;
}
/* ----------------------------------------------------------------------- */
/* REFINE ESTIMATE AND TEST */
/* ----------------------------------------------------------------------- */
aphi = c_abs(&phid);
rs1 += log(aphi);
if (dabs(rs1) < *elim) {
goto L100;
}
L95:
if (rs1 > 0.f) {
goto L290;
}
/* ----------------------------------------------------------------------- */
/* FOR X.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW */
/* ----------------------------------------------------------------------- */
if (x < 0.f) {
goto L290;
}
*nz = *n;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
y[i__2].r = czero.r, y[i__2].i = czero.i;
/* L96: */
}
return 0;
L100:
/* ----------------------------------------------------------------------- */
/* RECUR FORWARD FOR REMAINDER OF THE SEQUENCE */
/* ----------------------------------------------------------------------- */
s1.r = cy[0].r, s1.i = cy[0].i;
s2.r = cy[1].r, s2.i = cy[1].i;
i__1 = kflag - 1;
c1.r = csr[i__1].r, c1.i = csr[i__1].i;
ascle = bry[kflag - 1];
i__1 = *n;
for (i__ = ib; i__ <= i__1; ++i__) {
c2.r = s2.r, c2.i = s2.i;
q__2.r = ck.r * s2.r - ck.i * s2.i, q__2.i = ck.r * s2.i + ck.i *
s2.r;
q__1.r = q__2.r + s1.r, q__1.i = q__2.i + s1.i;
s2.r = q__1.r, s2.i = q__1.i;
s1.r = c2.r, s1.i = c2.i;
q__1.r = ck.r + rz.r, q__1.i = ck.i + rz.i;
ck.r = q__1.r, ck.i = q__1.i;
q__1.r = s2.r * c1.r - s2.i * c1.i, q__1.i = s2.r * c1.i + s2.i *
c1.r;
c2.r = q__1.r, c2.i = q__1.i;
i__2 = i__;
y[i__2].r = c2.r, y[i__2].i = c2.i;
if (kflag >= 3) {
goto L120;
}
c2r = c2.r;
c2i = r_imag(&c2);
c2r = dabs(c2r);
c2i = dabs(c2i);
c2m = dmax(c2r,c2i);
if (c2m <= ascle) {
goto L120;
}
++kflag;
ascle = bry[kflag - 1];
q__1.r = s1.r * c1.r - s1.i * c1.i, q__1.i = s1.r * c1.i + s1.i *
c1.r;
s1.r = q__1.r, s1.i = q__1.i;
s2.r = c2.r, s2.i = c2.i;
i__2 = kflag - 1;
q__1.r = s1.r * css[i__2].r - s1.i * css[i__2].i, q__1.i = s1.r * css[
i__2].i + s1.i * css[i__2].r;
s1.r = q__1.r, s1.i = q__1.i;
i__2 = kflag - 1;
q__1.r = s2.r * css[i__2].r - s2.i * css[i__2].i, q__1.i = s2.r * css[
i__2].i + s2.i * css[i__2].r;
s2.r = q__1.r, s2.i = q__1.i;
i__2 = kflag - 1;
c1.r = csr[i__2].r, c1.i = csr[i__2].i;
L120:
;
}
L160:
if (*mr == 0) {
return 0;
}
/* ----------------------------------------------------------------------- */
/* ANALYTIC CONTINUATION FOR RE(Z).LT.0.0E0 */
/* ----------------------------------------------------------------------- */
*nz = 0;
fmr = (real) (*mr);
sgn = -r_sign(&pi, &fmr);
/* ----------------------------------------------------------------------- */
/* CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP. */
/* ----------------------------------------------------------------------- */
q__1.r = 0.f, q__1.i = sgn;
csgn.r = q__1.r, csgn.i = q__1.i;
inu = *fnu;
fnf = *fnu - inu;
ifn = inu + *n - 1;
ang = fnf * sgn;
cpn = cos(ang);
spn = sin(ang);
q__1.r = cpn, q__1.i = spn;
cspn.r = q__1.r, cspn.i = q__1.i;
if (ifn % 2 == 1) {
q__1.r = -cspn.r, q__1.i = -cspn.i;
cspn.r = q__1.r, cspn.i = q__1.i;
}
asc = bry[0];
kk = *n;
iuf = 0;
kdflg = 1;
--ib;
ic = ib - 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
fn = *fnu + (kk - 1);
/* ----------------------------------------------------------------------- */
/* LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K */
/* FUNCTION ABOVE */
/* ----------------------------------------------------------------------- */
m = 3;
if (*n > 2) {
goto L175;
}
L170:
initd = init[j - 1];
i__2 = j - 1;
phid.r = phi[i__2].r, phid.i = phi[i__2].i;
i__2 = j - 1;
zeta1d.r = zeta1[i__2].r, zeta1d.i = zeta1[i__2].i;
i__2 = j - 1;
zeta2d.r = zeta2[i__2].r, zeta2d.i = zeta2[i__2].i;
i__2 = j - 1;
sumd.r = sum[i__2].r, sumd.i = sum[i__2].i;
m = j;
j = 3 - j;
goto L180;
L175:
if (kk == *n && ib < *n) {
goto L180;
}
if (kk == ib || kk == ic) {
goto L170;
}
initd = 0;
L180:
cunik_(&zr, &fn, &c__1, &c__0, tol, &initd, &phid, &zeta1d, &zeta2d, &
sumd, &cwrk[(m << 4) - 16]);
if (*kode == 1) {
goto L190;
}
q__1.r = fn, q__1.i = 0.f;
cfn.r = q__1.r, cfn.i = q__1.i;
q__2.r = -zeta1d.r, q__2.i = -zeta1d.i;
q__5.r = zr.r + zeta2d.r, q__5.i = zr.i + zeta2d.i;
c_div(&q__4, &cfn, &q__5);
q__3.r = cfn.r * q__4.r - cfn.i * q__4.i, q__3.i = cfn.r * q__4.i +
cfn.i * q__4.r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
s1.r = q__1.r, s1.i = q__1.i;
goto L200;
L190:
q__2.r = -zeta1d.r, q__2.i = -zeta1d.i;
q__1.r = q__2.r + zeta2d.r, q__1.i = q__2.i + zeta2d.i;
s1.r = q__1.r, s1.i = q__1.i;
L200:
/* ----------------------------------------------------------------------- */
/* TEST FOR UNDERFLOW AND OVERFLOW */
/* ----------------------------------------------------------------------- */
rs1 = s1.r;
if (dabs(rs1) > *elim) {
goto L250;
}
if (kdflg == 1) {
iflag = 2;
}
if (dabs(rs1) < *alim) {
goto L210;
}
/* ----------------------------------------------------------------------- */
/* REFINE TEST AND SCALE */
/* ----------------------------------------------------------------------- */
aphi = c_abs(&phid);
rs1 += log(aphi);
if (dabs(rs1) > *elim) {
goto L250;
}
if (kdflg == 1) {
iflag = 1;
}
if (rs1 < 0.f) {
goto L210;
}
if (kdflg == 1) {
iflag = 3;
}
L210:
q__2.r = csgn.r * phid.r - csgn.i * phid.i, q__2.i = csgn.r * phid.i
+ csgn.i * phid.r;
q__1.r = q__2.r * sumd.r - q__2.i * sumd.i, q__1.i = q__2.r * sumd.i
+ q__2.i * sumd.r;
s2.r = q__1.r, s2.i = q__1.i;
c2r = s1.r;
c2i = r_imag(&s1);
i__2 = iflag - 1;
c2m = exp(c2r) * css[i__2].r;
q__2.r = c2m, q__2.i = 0.f;
r__1 = cos(c2i);
r__2 = sin(c2i);
q__3.r = r__1, q__3.i = r__2;
q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * q__3.i
+ q__2.i * q__3.r;
s1.r = q__1.r, s1.i = q__1.i;
q__1.r = s2.r * s1.r - s2.i * s1.i, q__1.i = s2.r * s1.i + s2.i *
s1.r;
s2.r = q__1.r, s2.i = q__1.i;
if (iflag != 1) {
goto L220;
}
cuchk_(&s2, &nw, bry, tol);
if (nw != 0) {
s2.r = 0.f, s2.i = 0.f;
}
L220:
i__2 = kdflg - 1;
cy[i__2].r = s2.r, cy[i__2].i = s2.i;
c2.r = s2.r, c2.i = s2.i;
i__2 = iflag - 1;
q__1.r = s2.r * csr[i__2].r - s2.i * csr[i__2].i, q__1.i = s2.r * csr[
i__2].i + s2.i * csr[i__2].r;
s2.r = q__1.r, s2.i = q__1.i;
/* ----------------------------------------------------------------------- */
/* ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N */
/* ----------------------------------------------------------------------- */
i__2 = kk;
s1.r = y[i__2].r, s1.i = y[i__2].i;
if (*kode == 1) {
goto L240;
}
cs1s2_(&zr, &s1, &s2, &nw, &asc, alim, &iuf);
*nz += nw;
L240:
i__2 = kk;
q__2.r = s1.r * cspn.r - s1.i * cspn.i, q__2.i = s1.r * cspn.i + s1.i
* cspn.r;
q__1.r = q__2.r + s2.r, q__1.i = q__2.i + s2.i;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
--kk;
q__1.r = -cspn.r, q__1.i = -cspn.i;
cspn.r = q__1.r, cspn.i = q__1.i;
if (c2.r != czero.r || c2.i != czero.i) {
goto L245;
}
kdflg = 1;
goto L260;
L245:
if (kdflg == 2) {
goto L265;
}
kdflg = 2;
goto L260;
L250:
if (rs1 > 0.f) {
goto L290;
}
s2.r = czero.r, s2.i = czero.i;
goto L220;
L260:
;
}
k = *n;
L265:
il = *n - k;
if (il == 0) {
return 0;
}
/* ----------------------------------------------------------------------- */
/* RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE */
/* K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP */
/* INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. */
/* ----------------------------------------------------------------------- */
s1.r = cy[0].r, s1.i = cy[0].i;
s2.r = cy[1].r, s2.i = cy[1].i;
i__1 = iflag - 1;
cs.r = csr[i__1].r, cs.i = csr[i__1].i;
ascle = bry[iflag - 1];
fn = (real) (inu + il);
i__1 = il;
for (i__ = 1; i__ <= i__1; ++i__) {
c2.r = s2.r, c2.i = s2.i;
r__1 = fn + fnf;
q__4.r = r__1, q__4.i = 0.f;
q__3.r = q__4.r * rz.r - q__4.i * rz.i, q__3.i = q__4.r * rz.i +
q__4.i * rz.r;
q__2.r = q__3.r * s2.r - q__3.i * s2.i, q__2.i = q__3.r * s2.i +
q__3.i * s2.r;
q__1.r = s1.r + q__2.r, q__1.i = s1.i + q__2.i;
s2.r = q__1.r, s2.i = q__1.i;
s1.r = c2.r, s1.i = c2.i;
fn += -1.f;
q__1.r = s2.r * cs.r - s2.i * cs.i, q__1.i = s2.r * cs.i + s2.i *
cs.r;
c2.r = q__1.r, c2.i = q__1.i;
ck.r = c2.r, ck.i = c2.i;
i__2 = kk;
c1.r = y[i__2].r, c1.i = y[i__2].i;
if (*kode == 1) {
goto L270;
}
cs1s2_(&zr, &c1, &c2, &nw, &asc, alim, &iuf);
*nz += nw;
L270:
i__2 = kk;
q__2.r = c1.r * cspn.r - c1.i * cspn.i, q__2.i = c1.r * cspn.i + c1.i
* cspn.r;
q__1.r = q__2.r + c2.r, q__1.i = q__2.i + c2.i;
y[i__2].r = q__1.r, y[i__2].i = q__1.i;
--kk;
q__1.r = -cspn.r, q__1.i = -cspn.i;
cspn.r = q__1.r, cspn.i = q__1.i;
if (iflag >= 3) {
goto L280;
}
c2r = ck.r;
c2i = r_imag(&ck);
c2r = dabs(c2r);
c2i = dabs(c2i);
c2m = dmax(c2r,c2i);
if (c2m <= ascle) {
goto L280;
}
++iflag;
ascle = bry[iflag - 1];
q__1.r = s1.r * cs.r - s1.i * cs.i, q__1.i = s1.r * cs.i + s1.i *
cs.r;
s1.r = q__1.r, s1.i = q__1.i;
s2.r = ck.r, s2.i = ck.i;
i__2 = iflag - 1;
q__1.r = s1.r * css[i__2].r - s1.i * css[i__2].i, q__1.i = s1.r * css[
i__2].i + s1.i * css[i__2].r;
s1.r = q__1.r, s1.i = q__1.i;
i__2 = iflag - 1;
q__1.r = s2.r * css[i__2].r - s2.i * css[i__2].i, q__1.i = s2.r * css[
i__2].i + s2.i * css[i__2].r;
s2.r = q__1.r, s2.i = q__1.i;
i__2 = iflag - 1;
cs.r = csr[i__2].r, cs.i = csr[i__2].i;
L280:
;
}
return 0;
L290:
*nz = -1;
return 0;
} /* cunk1_ */
static void vparms(int32_t vwin[],
float *inbuf,
float *lpbuf,
const int32_t buflim[],
int32_t half,
float *dither,
int32_t *mintau,
int32_t *zc,
int32_t *lbe,
int32_t *fbe,
float *qs,
float *rc1,
float *ar_b,
float *ar_f)
{
int32_t inbuf_offset;
int32_t lpbuf_offset;
int32_t vlen;
int32_t stop;
int32_t i;
int32_t start;
float r1;
float r2;
float e_pre;
float ap_rms;
float e_0;
float oldsgn;
float lp_rms;
float e_b;
float e_f;
float r_b;
float r_f;
float e0ap;
/* Calculate zero crossings (ZC) and several energy and correlation */
/* measures on low band and full band speech. Each measure is taken */
/* over either the first or the second half of the voicing window, */
/* depending on the variable HALF. */
lpbuf_offset = buflim[2];
lpbuf -= lpbuf_offset;
inbuf_offset = buflim[0];
inbuf -= inbuf_offset;
lp_rms = 0.0f;
ap_rms = 0.0f;
e_pre = 0.0f;
e0ap = 0.0f;
*rc1 = 0.0f;
e_0 = 0.0f;
e_b = 0.0f;
e_f = 0.0f;
r_f = 0.0f;
r_b = 0.0f;
*zc = 0;
vlen = vwin[1] - vwin[0] + 1;
start = vwin[0] + half*vlen/2 + 1;
stop = start + vlen/2 - 1;
/* I'll use the symbol HVL in the table below to represent the value */
/* VLEN/2. Note that if VLEN is odd, then HVL should be rounded down, */
/* i.e., HVL = (VLEN-1)/2. */
/* HALF START STOP */
/* 1 VWIN(1)+1 VWIN(1)+HVL */
/* 2 VWIN(1)+HVL+1 VWIN(1)+2*HVL */
oldsgn = r_sign(1.0f, inbuf[start - 1] - *dither);
for (i = start; i <= stop; i++)
{
lp_rms += fabsf(lpbuf[i]);
ap_rms += fabsf(inbuf[i]);
e_pre += fabsf(inbuf[i] - inbuf[i - 1]);
r1 = inbuf[i];
e0ap += r1*r1;
*rc1 += inbuf[i]*inbuf[i - 1];
r1 = lpbuf[i];
e_0 += r1*r1;
r1 = lpbuf[i - *mintau];
e_b += r1*r1;
r1 = lpbuf[i + *mintau];
e_f += r1*r1;
r_f += lpbuf[i]*lpbuf[i + *mintau];
r_b += lpbuf[i]*lpbuf[i - *mintau];
r1 = inbuf[i] + *dither;
if (r_sign(1.0f, r1) != oldsgn)
{
++(*zc);
oldsgn = -oldsgn;
}
*dither = -(*dither);
}
/* Normalized short-term autocovariance coefficient at unit sample delay */
*rc1 /= max(e0ap, 1.0f);
/* Ratio of the energy of the first difference signal (6 dB/oct preemphasis)*/
/* to the energy of the full band signal */
/* Computing MAX */
r1 = ap_rms*2.0f;
*qs = e_pre/max(r1, 1.0f);
/* aR_b is the product of the forward and reverse prediction gains, */
/* looking backward in time (the causal case). */
*ar_b = r_b/max(e_b, 1.0f)*(r_b/max(e_0, 1.0f));
/* aR_f is the same as aR_b, but looking forward in time (non causal case).*/
*ar_f = r_f/max(e_f, 1.0f)*(r_f/max(e_0, 1.0f));
/* Normalize ZC, LBE, and FBE to old fixed window length of 180. */
/* (The fraction 90/VLEN has a range of 0.58 to 1) */
r2 = (float) (*zc << 1);
*zc = lfastrintf(r2*(90.0f/vlen));
r1 = lp_rms/4*(90.0f/vlen);
*lbe = min(lfastrintf(r1), 32767);
r1 = ap_rms/4*(90.0f/vlen);
*fbe = min(lfastrintf(r1), 32767);
}
/* Subroutine */ int ssterf_(integer *n, real *d__, real *e, integer *info)
{
/* System generated locals */
integer i__1;
real r__1, r__2, r__3;
/* Builtin functions */
double sqrt(doublereal), r_sign(real *, real *);
/* Local variables */
real c__;
integer i__, l, m;
real p, r__, s;
integer l1;
real bb, rt1, rt2, eps, rte;
integer lsv;
real eps2, oldc;
integer lend, jtot;
extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *)
;
real gamma, alpha, sigma, anorm;
extern doublereal slapy2_(real *, real *);
integer iscale;
real oldgam;
extern doublereal slamch_(char *);
real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
real safmax;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
integer lendsv;
real ssfmin;
integer nmaxit;
real ssfmax;
extern doublereal slanst_(char *, integer *, real *, real *);
extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SSTERF computes all eigenvalues of a symmetric tridiagonal matrix */
/* using the Pal-Walker-Kahan variant of the QL or QR algorithm. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* D (input/output) REAL array, dimension (N) */
/* On entry, the n diagonal elements of the tridiagonal matrix. */
/* On exit, if INFO = 0, the eigenvalues in ascending order. */
/* E (input/output) REAL array, dimension (N-1) */
/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
/* matrix. */
/* On exit, E has been destroyed. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: the algorithm failed to find all of the eigenvalues in */
/* a total of 30*N iterations; if INFO = i, then i */
/* elements of E have not converged to zero. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--e;
--d__;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n < 0) {
*info = -1;
i__1 = -(*info);
xerbla_("SSTERF", &i__1);
return 0;
}
if (*n <= 1) {
return 0;
}
/* Determine the unit roundoff for this environment. */
eps = slamch_("E");
/* Computing 2nd power */
r__1 = eps;
eps2 = r__1 * r__1;
safmin = slamch_("S");
safmax = 1.f / safmin;
ssfmax = sqrt(safmax) / 3.f;
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues of the tridiagonal matrix. */
nmaxit = *n * 30;
sigma = 0.f;
jtot = 0;
/* Determine where the matrix splits and choose QL or QR iteration */
/* for each block, according to whether top or bottom diagonal */
/* element is smaller. */
l1 = 1;
L10:
if (l1 > *n) {
goto L170;
}
if (l1 > 1) {
e[l1 - 1] = 0.f;
}
i__1 = *n - 1;
for (m = l1; m <= i__1; ++m) {
if ((r__3 = e[m], dabs(r__3)) <= sqrt((r__1 = d__[m], dabs(r__1))) *
sqrt((r__2 = d__[m + 1], dabs(r__2))) * eps) {
e[m] = 0.f;
goto L30;
}
/* L20: */
}
m = *n;
L30:
l = l1;
lsv = l;
lend = m;
lendsv = lend;
l1 = m + 1;
if (lend == l) {
goto L10;
}
/* Scale submatrix in rows and columns L to LEND */
i__1 = lend - l + 1;
anorm = slanst_("I", &i__1, &d__[l], &e[l]);
iscale = 0;
if (anorm > ssfmax) {
iscale = 1;
i__1 = lend - l + 1;
slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
info);
} else if (anorm < ssfmin) {
iscale = 2;
i__1 = lend - l + 1;
slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
info);
}
i__1 = lend - 1;
for (i__ = l; i__ <= i__1; ++i__) {
/* Computing 2nd power */
r__1 = e[i__];
e[i__] = r__1 * r__1;
/* L40: */
}
/* Choose between QL and QR iteration */
if ((r__1 = d__[lend], dabs(r__1)) < (r__2 = d__[l], dabs(r__2))) {
lend = lsv;
l = lendsv;
}
if (lend >= l) {
/* QL Iteration */
/* Look for small subdiagonal element. */
L50:
if (l != lend) {
i__1 = lend - 1;
for (m = l; m <= i__1; ++m) {
if ((r__2 = e[m], dabs(r__2)) <= eps2 * (r__1 = d__[m] * d__[
m + 1], dabs(r__1))) {
goto L70;
}
/* L60: */
}
}
m = lend;
L70:
if (m < lend) {
e[m] = 0.f;
}
p = d__[l];
if (m == l) {
goto L90;
}
/* If remaining matrix is 2 by 2, use SLAE2 to compute its */
/* eigenvalues. */
if (m == l + 1) {
rte = sqrt(e[l]);
slae2_(&d__[l], &rte, &d__[l + 1], &rt1, &rt2);
d__[l] = rt1;
d__[l + 1] = rt2;
e[l] = 0.f;
l += 2;
if (l <= lend) {
goto L50;
}
goto L150;
}
if (jtot == nmaxit) {
goto L150;
}
++jtot;
/* Form shift. */
rte = sqrt(e[l]);
sigma = (d__[l + 1] - p) / (rte * 2.f);
r__ = slapy2_(&sigma, &c_b32);
sigma = p - rte / (sigma + r_sign(&r__, &sigma));
c__ = 1.f;
s = 0.f;
gamma = d__[m] - sigma;
p = gamma * gamma;
/* Inner loop */
i__1 = l;
for (i__ = m - 1; i__ >= i__1; --i__) {
bb = e[i__];
r__ = p + bb;
if (i__ != m - 1) {
e[i__ + 1] = s * r__;
}
oldc = c__;
c__ = p / r__;
s = bb / r__;
oldgam = gamma;
alpha = d__[i__];
gamma = c__ * (alpha - sigma) - s * oldgam;
d__[i__ + 1] = oldgam + (alpha - gamma);
if (c__ != 0.f) {
p = gamma * gamma / c__;
} else {
p = oldc * bb;
}
/* L80: */
}
e[l] = s * p;
d__[l] = sigma + gamma;
goto L50;
/* Eigenvalue found. */
L90:
d__[l] = p;
++l;
if (l <= lend) {
goto L50;
}
goto L150;
} else {
/* QR Iteration */
/* Look for small superdiagonal element. */
L100:
i__1 = lend + 1;
for (m = l; m >= i__1; --m) {
if ((r__2 = e[m - 1], dabs(r__2)) <= eps2 * (r__1 = d__[m] * d__[
m - 1], dabs(r__1))) {
goto L120;
}
/* L110: */
}
m = lend;
L120:
if (m > lend) {
e[m - 1] = 0.f;
}
p = d__[l];
if (m == l) {
goto L140;
}
/* If remaining matrix is 2 by 2, use SLAE2 to compute its */
/* eigenvalues. */
if (m == l - 1) {
rte = sqrt(e[l - 1]);
slae2_(&d__[l], &rte, &d__[l - 1], &rt1, &rt2);
d__[l] = rt1;
d__[l - 1] = rt2;
e[l - 1] = 0.f;
l += -2;
if (l >= lend) {
goto L100;
}
goto L150;
}
if (jtot == nmaxit) {
goto L150;
}
++jtot;
/* Form shift. */
rte = sqrt(e[l - 1]);
sigma = (d__[l - 1] - p) / (rte * 2.f);
r__ = slapy2_(&sigma, &c_b32);
sigma = p - rte / (sigma + r_sign(&r__, &sigma));
c__ = 1.f;
s = 0.f;
gamma = d__[m] - sigma;
p = gamma * gamma;
/* Inner loop */
i__1 = l - 1;
for (i__ = m; i__ <= i__1; ++i__) {
bb = e[i__];
r__ = p + bb;
if (i__ != m) {
e[i__ - 1] = s * r__;
}
oldc = c__;
c__ = p / r__;
s = bb / r__;
oldgam = gamma;
alpha = d__[i__ + 1];
gamma = c__ * (alpha - sigma) - s * oldgam;
d__[i__] = oldgam + (alpha - gamma);
if (c__ != 0.f) {
p = gamma * gamma / c__;
} else {
p = oldc * bb;
}
/* L130: */
}
e[l - 1] = s * p;
d__[l] = sigma + gamma;
goto L100;
/* Eigenvalue found. */
L140:
d__[l] = p;
--l;
if (l >= lend) {
goto L100;
}
goto L150;
}
/* Undo scaling if necessary */
L150:
if (iscale == 1) {
i__1 = lendsv - lsv + 1;
slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
}
if (iscale == 2) {
i__1 = lendsv - lsv + 1;
slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
}
/* Check for no convergence to an eigenvalue after a total */
/* of N*MAXIT iterations. */
if (jtot < nmaxit) {
goto L10;
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.f) {
++(*info);
}
/* L160: */
}
goto L180;
/* Sort eigenvalues in increasing order. */
L170:
slasrt_("I", n, &d__[1], info);
L180:
return 0;
/* End of SSTERF */
} /* ssterf_ */
/* Subroutine */ int sla_syamv__(integer *uplo, integer *n, real *alpha, real
*a, integer *lda, real *x, integer *incx, real *beta, real *y,
integer *incy)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real r__1;
/* Builtin functions */
double r_sign(real *, real *);
/* Local variables */
integer i__, j;
logical symb_zero__;
integer iy, jx, kx, ky, info;
real temp, safe1;
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilauplo_(char *);
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLA_SYAMV performs the matrix-vector operation */
/* y := alpha*abs(A)*abs(x) + beta*abs(y), */
/* where alpha and beta are scalars, x and y are vectors and A is an */
/* n by n symmetric matrix. */
/* This function is primarily used in calculating error bounds. */
/* To protect against underflow during evaluation, components in */
/* the resulting vector are perturbed away from zero by (N+1) */
/* times the underflow threshold. To prevent unnecessarily large */
/* errors for block-structure embedded in general matrices, */
/* "symbolically" zero components are not perturbed. A zero */
/* entry is considered "symbolic" if all multiplications involved */
/* in computing that entry have at least one zero multiplicand. */
/* Parameters */
/* ========== */
/* UPLO - INTEGER */
/* On entry, UPLO specifies whether the upper or lower */
/* triangular part of the array A is to be referenced as */
/* follows: */
/* UPLO = BLAS_UPPER Only the upper triangular part of A */
/* is to be referenced. */
/* UPLO = BLAS_LOWER Only the lower triangular part of A */
/* is to be referenced. */
/* Unchanged on exit. */
/* N - INTEGER. */
/* On entry, N specifies the number of columns of the matrix A. */
/* N must be at least zero. */
/* Unchanged on exit. */
/* ALPHA - REAL . */
/* On entry, ALPHA specifies the scalar alpha. */
/* Unchanged on exit. */
/* A - REAL array of DIMENSION ( LDA, n ). */
/* Before entry, the leading m by n part of the array A must */
/* contain the matrix of coefficients. */
/* Unchanged on exit. */
/* LDA - INTEGER. */
/* On entry, LDA specifies the first dimension of A as declared */
/* in the calling (sub) program. LDA must be at least */
/* max( 1, n ). */
/* Unchanged on exit. */
/* X - REAL array of DIMENSION at least */
/* ( 1 + ( n - 1 )*abs( INCX ) ) */
/* Before entry, the incremented array X must contain the */
/* vector x. */
/* Unchanged on exit. */
/* INCX - INTEGER. */
/* On entry, INCX specifies the increment for the elements of */
/* X. INCX must not be zero. */
/* Unchanged on exit. */
/* BETA - REAL . */
/* On entry, BETA specifies the scalar beta. When BETA is */
/* supplied as zero then Y need not be set on input. */
/* Unchanged on exit. */
/* Y - REAL array of DIMENSION at least */
/* ( 1 + ( n - 1 )*abs( INCY ) ) */
/* Before entry with BETA non-zero, the incremented array Y */
/* must contain the vector y. On exit, Y is overwritten by the */
/* updated vector y. */
/* INCY - INTEGER. */
/* On entry, INCY specifies the increment for the elements of */
/* Y. INCY must not be zero. */
/* Unchanged on exit. */
/* Level 2 Blas routine. */
/* -- Written on 22-October-1986. */
/* Jack Dongarra, Argonne National Lab. */
/* Jeremy Du Croz, Nag Central Office. */
/* Sven Hammarling, Nag Central Office. */
/* Richard Hanson, Sandia National Labs. */
/* -- Modified for the absolute-value product, April 2006 */
/* Jason Riedy, UC Berkeley */
/* .. */
/* .. 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;
--x;
--y;
/* Function Body */
info = 0;
if (*uplo != ilauplo_("U") && *uplo != ilauplo_("L")
) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*lda < max(1,*n)) {
info = 5;
} else if (*incx == 0) {
info = 7;
} else if (*incy == 0) {
info = 10;
}
if (info != 0) {
xerbla_("SSYMV ", &info);
return 0;
}
/* Quick return if possible. */
if (*n == 0 || *alpha == 0.f && *beta == 1.f) {
return 0;
}
/* Set up the start points in X and Y. */
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (*n - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (*n - 1) * *incy;
}
/* Set SAFE1 essentially to be the underflow threshold times the */
/* number of additions in each row. */
safe1 = slamch_("Safe minimum");
safe1 = (*n + 1) * safe1;
/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */
/* The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to */
/* the inexact flag. Still doesn't help change the iteration order */
/* to per-column. */
iy = ky;
if (*incx == 1) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (*beta == 0.f) {
symb_zero__ = TRUE_;
y[iy] = 0.f;
} else if (y[iy] == 0.f) {
symb_zero__ = TRUE_;
} else {
symb_zero__ = FALSE_;
y[iy] = *beta * (r__1 = y[iy], dabs(r__1));
}
if (*alpha != 0.f) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
if (*uplo == ilauplo_("U")) {
if (i__ <= j) {
temp = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
} else {
temp = (r__1 = a[j + i__ * a_dim1], dabs(r__1));
}
} else {
if (i__ >= j) {
temp = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
} else {
temp = (r__1 = a[j + i__ * a_dim1], dabs(r__1));
}
}
symb_zero__ = symb_zero__ && (x[j] == 0.f || temp == 0.f);
y[iy] += *alpha * (r__1 = x[j], dabs(r__1)) * temp;
}
}
if (! symb_zero__) {
y[iy] += r_sign(&safe1, &y[iy]);
}
iy += *incy;
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (*beta == 0.f) {
symb_zero__ = TRUE_;
y[iy] = 0.f;
} else if (y[iy] == 0.f) {
symb_zero__ = TRUE_;
} else {
symb_zero__ = FALSE_;
y[iy] = *beta * (r__1 = y[iy], dabs(r__1));
}
jx = kx;
if (*alpha != 0.f) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
if (*uplo == ilauplo_("U")) {
if (i__ <= j) {
temp = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
} else {
temp = (r__1 = a[j + i__ * a_dim1], dabs(r__1));
}
} else {
if (i__ >= j) {
temp = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
} else {
temp = (r__1 = a[j + i__ * a_dim1], dabs(r__1));
}
}
symb_zero__ = symb_zero__ && (x[j] == 0.f || temp == 0.f);
y[iy] += *alpha * (r__1 = x[jx], dabs(r__1)) * temp;
jx += *incx;
}
}
if (! symb_zero__) {
y[iy] += r_sign(&safe1, &y[iy]);
}
iy += *incy;
}
}
return 0;
/* End of SLA_SYAMV */
} /* sla_syamv__ */
/* Subroutine */ int slaed3_(integer *k, integer *n, integer *n1, real *d__,
real *q, integer *ldq, real *rho, real *dlamda, real *q2, integer *
indx, integer *ctot, real *w, real *s, integer *info)
{
/* System generated locals */
integer q_dim1, q_offset, i__1, i__2;
real r__1;
/* Builtin functions */
double sqrt(doublereal), r_sign(real *, real *);
/* Local variables */
static real temp;
extern doublereal snrm2_(integer *, real *, integer *);
static integer i__, j;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *), scopy_(integer *, real *,
integer *, real *, integer *);
static integer n2;
extern /* Subroutine */ int slaed4_(integer *, integer *, real *, real *,
real *, real *, real *, integer *);
extern doublereal slamc3_(real *, real *);
static integer n12, ii, n23;
extern /* Subroutine */ int xerbla_(char *, integer *), slacpy_(
char *, integer *, integer *, real *, integer *, real *, integer *
), slaset_(char *, integer *, integer *, real *, real *,
real *, integer *);
static integer iq2;
#define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
/* -- LAPACK routine (instrumented to count operations, version 3.0) --
Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
Courant Institute, NAG Ltd., and Rice University
June 30, 1999
Common block to return operation count and iteration count
ITCNT is unchanged, OPS is only incremented
Purpose
=======
SLAED3 finds the roots of the secular equation, as defined by the
values in D, W, and RHO, between 1 and K. It makes the
appropriate calls to SLAED4 and then updates the eigenvectors by
multiplying the matrix of eigenvectors of the pair of eigensystems
being combined by the matrix of eigenvectors of the K-by-K system
which is solved here.
This code makes very mild assumptions about floating point
arithmetic. It will work on machines with a guard digit in
add/subtract, or on those binary machines without guard digits
which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
It could conceivably fail on hexadecimal or decimal machines
without guard digits, but we know of none.
Arguments
=========
K (input) INTEGER
The number of terms in the rational function to be solved by
SLAED4. K >= 0.
N (input) INTEGER
The number of rows and columns in the Q matrix.
N >= K (deflation may result in N>K).
N1 (input) INTEGER
The location of the last eigenvalue in the leading submatrix.
min(1,N) <= N1 <= N/2.
D (output) REAL array, dimension (N)
D(I) contains the updated eigenvalues for
1 <= I <= K.
Q (output) REAL array, dimension (LDQ,N)
Initially the first K columns are used as workspace.
On output the columns 1 to K contain
the updated eigenvectors.
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= max(1,N).
RHO (input) REAL
The value of the parameter in the rank one update equation.
RHO >= 0 required.
DLAMDA (input/output) REAL array, dimension (K)
The first K elements of this array contain the old roots
of the deflated updating problem. These are the poles
of the secular equation. May be changed on output by
having lowest order bit set to zero on Cray X-MP, Cray Y-MP,
Cray-2, or Cray C-90, as described above.
Q2 (input) REAL array, dimension (LDQ2, N)
The first K columns of this matrix contain the non-deflated
eigenvectors for the split problem.
INDX (input) INTEGER array, dimension (N)
The permutation used to arrange the columns of the deflated
Q matrix into three groups (see SLAED2).
The rows of the eigenvectors found by SLAED4 must be likewise
permuted before the matrix multiply can take place.
CTOT (input) INTEGER array, dimension (4)
A count of the total number of the various types of columns
in Q, as described in INDX. The fourth column type is any
column which has been deflated.
W (input/output) REAL array, dimension (K)
The first K elements of this array contain the components
of the deflation-adjusted updating vector. Destroyed on
output.
S (workspace) REAL array, dimension (N1 + 1)*K
Will contain the eigenvectors of the repaired matrix which
will be multiplied by the previously accumulated eigenvectors
to update the system.
LDS (input) INTEGER
The leading dimension of S. LDS >= max(1,K).
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: if INFO = 1, an eigenvalue did not converge
Further Details
===============
Based on contributions by
Jeff Rutter, Computer Science Division, University of California
at Berkeley, USA
Modified by Francoise Tisseur, University of Tennessee.
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
--dlamda;
--q2;
--indx;
--ctot;
--w;
--s;
/* Function Body */
*info = 0;
if (*k < 0) {
*info = -1;
} else if (*n < *k) {
*info = -2;
} else if (*ldq < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SLAED3", &i__1);
return 0;
}
/* Quick return if possible */
if (*k == 0) {
return 0;
}
/* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
be computed with high relative accuracy (barring over/underflow).
This is a problem on machines without a guard digit in
add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
which on any of these machines zeros out the bottommost
bit of DLAMDA(I) if it is 1; this makes the subsequent
subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
occurs. On binary machines with a guard digit (almost all
machines) it does not change DLAMDA(I) at all. On hexadecimal
and decimal machines with a guard digit, it slightly
changes the bottommost bits of DLAMDA(I). It does not account
for hexadecimal or decimal machines without guard digits
(we know of none). We use a subroutine call to compute
2*DLAMBDA(I) to prevent optimizing compilers from eliminating
this code. */
latime_1.ops += *n << 1;
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
dlamda[i__] = slamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__];
/* L10: */
}
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
slaed4_(k, &j, &dlamda[1], &w[1], &q_ref(1, j), rho, &d__[j], info);
/* If the zero finder fails, the computation is terminated. */
if (*info != 0) {
goto L120;
}
/* L20: */
}
if (*k == 1) {
goto L110;
}
if (*k == 2) {
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
w[1] = q_ref(1, j);
w[2] = q_ref(2, j);
ii = indx[1];
q_ref(1, j) = w[ii];
ii = indx[2];
q_ref(2, j) = w[ii];
/* L30: */
}
goto L110;
}
/* Compute updated W. */
scopy_(k, &w[1], &c__1, &s[1], &c__1);
/* Initialize W(I) = Q(I,I) */
i__1 = *ldq + 1;
scopy_(k, &q[q_offset], &i__1, &w[1], &c__1);
latime_1.ops += *k * 3 * (*k - 1);
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
w[i__] *= q_ref(i__, j) / (dlamda[i__] - dlamda[j]);
/* L40: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
w[i__] *= q_ref(i__, j) / (dlamda[i__] - dlamda[j]);
/* L50: */
}
/* L60: */
}
latime_1.ops += *k;
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
r__1 = sqrt(-w[i__]);
w[i__] = r_sign(&r__1, &s[i__]);
/* L70: */
}
/* Compute eigenvectors of the modified rank-1 modification. */
latime_1.ops += (*k << 2) * *k;
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *k;
for (i__ = 1; i__ <= i__2; ++i__) {
s[i__] = w[i__] / q_ref(i__, j);
/* L80: */
}
temp = snrm2_(k, &s[1], &c__1);
i__2 = *k;
for (i__ = 1; i__ <= i__2; ++i__) {
ii = indx[i__];
q_ref(i__, j) = s[ii] / temp;
/* L90: */
}
/* L100: */
}
/* Compute the updated eigenvectors. */
L110:
n2 = *n - *n1;
n12 = ctot[1] + ctot[2];
n23 = ctot[2] + ctot[3];
slacpy_("A", &n23, k, &q_ref(ctot[1] + 1, 1), ldq, &s[1], &n23)
;
iq2 = *n1 * n12 + 1;
if (n23 != 0) {
latime_1.ops += (real) n2 * 2 * *k * n23;
sgemm_("N", "N", &n2, k, &n23, &c_b22, &q2[iq2], &n2, &s[1], &n23, &
c_b23, &q_ref(*n1 + 1, 1), ldq);
} else {
slaset_("A", &n2, k, &c_b23, &c_b23, &q_ref(*n1 + 1, 1), ldq);
}
slacpy_("A", &n12, k, &q[q_offset], ldq, &s[1], &n12);
if (n12 != 0) {
latime_1.ops += (real) (*n1) * 2 * *k * n12;
sgemm_("N", "N", n1, k, &n12, &c_b22, &q2[1], n1, &s[1], &n12, &c_b23,
&q[q_offset], ldq);
} else {
slaset_("A", n1, k, &c_b23, &c_b23, &q_ref(1, 1), ldq);
}
L120:
return 0;
/* End of SLAED3 */
} /* slaed3_ */
int sbdsdc_(char *uplo, char *compq, int *n, float *d__,
float *e, float *u, int *ldu, float *vt, int *ldvt, float *q,
int *iq, float *work, int *iwork, int *info)
{
/* System generated locals */
int u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2;
float r__1;
/* Builtin functions */
double r_sign(float *, float *), log(double);
/* Local variables */
int i__, j, k;
float p, r__;
int z__, ic, ii, kk;
float cs;
int is, iu;
float sn;
int nm1;
float eps;
int ivt, difl, difr, ierr, perm, mlvl, sqre;
extern int lsame_(char *, char *);
int poles;
extern int slasr_(char *, char *, char *, int *,
int *, float *, float *, float *, int *);
int iuplo, nsize, start;
extern int scopy_(int *, float *, int *, float *,
int *), sswap_(int *, float *, int *, float *, int *
), slasd0_(int *, int *, float *, float *, float *, int *
, float *, int *, int *, int *, float *, int *);
extern double slamch_(char *);
extern int slasda_(int *, int *, int *,
int *, float *, float *, float *, int *, float *, int *,
float *, float *, float *, float *, int *, int *, int *,
int *, float *, float *, float *, float *, int *, int *),
xerbla_(char *, int *);
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
extern int slascl_(char *, int *, int *, float *,
float *, int *, int *, float *, int *, int *);
int givcol;
extern int slasdq_(char *, int *, int *, int
*, int *, int *, float *, float *, float *, int *, float *
, int *, float *, int *, float *, int *);
int icompq;
extern int slaset_(char *, int *, int *, float *,
float *, float *, int *), slartg_(float *, float *, float *
, float *, float *);
float orgnrm;
int givnum;
extern double slanst_(char *, int *, float *, float *);
int givptr, qstart, smlsiz, wstart, smlszp;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SBDSDC computes the singular value decomposition (SVD) of a float */
/* N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT, */
/* using a divide and conquer method, where S is a diagonal matrix */
/* with non-negative diagonal elements (the singular values of B), and */
/* U and VT are orthogonal matrices of left and right singular vectors, */
/* respectively. SBDSDC can be used to compute all singular values, */
/* and optionally, singular vectors or singular vectors in compact form. */
/* This code makes very mild assumptions about floating point */
/* arithmetic. It will work on machines with a guard digit in */
/* add/subtract, or on those binary machines without guard digits */
/* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */
/* It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. See SLASD3 for details. */
/* The code currently calls SLASDQ if singular values only are desired. */
/* However, it can be slightly modified to compute singular values */
/* using the divide and conquer method. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': B is upper bidiagonal. */
/* = 'L': B is lower bidiagonal. */
/* COMPQ (input) CHARACTER*1 */
/* Specifies whether singular vectors are to be computed */
/* as follows: */
/* = 'N': Compute singular values only; */
/* = 'P': Compute singular values and compute singular */
/* vectors in compact form; */
/* = 'I': Compute singular values and singular vectors. */
/* N (input) INTEGER */
/* The order of the matrix B. N >= 0. */
/* D (input/output) REAL array, dimension (N) */
/* On entry, the n diagonal elements of the bidiagonal matrix B. */
/* On exit, if INFO=0, the singular values of B. */
/* E (input/output) REAL array, dimension (N-1) */
/* On entry, the elements of E contain the offdiagonal */
/* elements of the bidiagonal matrix whose SVD is desired. */
/* On exit, E has been destroyed. */
/* U (output) REAL array, dimension (LDU,N) */
/* If COMPQ = 'I', then: */
/* On exit, if INFO = 0, U contains the left singular vectors */
/* of the bidiagonal matrix. */
/* For other values of COMPQ, U is not referenced. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= 1. */
/* If singular vectors are desired, then LDU >= MAX( 1, N ). */
/* VT (output) REAL array, dimension (LDVT,N) */
/* If COMPQ = 'I', then: */
/* On exit, if INFO = 0, VT' contains the right singular */
/* vectors of the bidiagonal matrix. */
/* For other values of COMPQ, VT is not referenced. */
/* LDVT (input) INTEGER */
/* The leading dimension of the array VT. LDVT >= 1. */
/* If singular vectors are desired, then LDVT >= MAX( 1, N ). */
/* Q (output) REAL array, dimension (LDQ) */
/* If COMPQ = 'P', then: */
/* On exit, if INFO = 0, Q and IQ contain the left */
/* and right singular vectors in a compact form, */
/* requiring O(N log N) space instead of 2*N**2. */
/* In particular, Q contains all the REAL data in */
/* LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1)))) */
/* words of memory, where SMLSIZ is returned by ILAENV and */
/* is equal to the maximum size of the subproblems at the */
/* bottom of the computation tree (usually about 25). */
/* For other values of COMPQ, Q is not referenced. */
/* IQ (output) INTEGER array, dimension (LDIQ) */
/* If COMPQ = 'P', then: */
/* On exit, if INFO = 0, Q and IQ contain the left */
/* and right singular vectors in a compact form, */
/* requiring O(N log N) space instead of 2*N**2. */
/* In particular, IQ contains all INTEGER data in */
/* LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1)))) */
/* words of memory, where SMLSIZ is returned by ILAENV and */
/* is equal to the maximum size of the subproblems at the */
/* bottom of the computation tree (usually about 25). */
/* For other values of COMPQ, IQ is not referenced. */
/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)) */
/* If COMPQ = 'N' then LWORK >= (4 * N). */
/* If COMPQ = 'P' then LWORK >= (6 * N). */
/* If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N). */
/* IWORK (workspace) INTEGER array, dimension (8*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: The algorithm failed to compute an singular value. */
/* The update process of divide and conquer failed. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Huan Ren, Computer Science Division, University of */
/* California at Berkeley, USA */
/* ===================================================================== */
/* Changed dimension statement in comment describing E from (N) to */
/* (N-1). Sven, 17 Feb 05. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
--q;
--iq;
--work;
--iwork;
/* Function Body */
*info = 0;
iuplo = 0;
if (lsame_(uplo, "U")) {
iuplo = 1;
}
if (lsame_(uplo, "L")) {
iuplo = 2;
}
if (lsame_(compq, "N")) {
icompq = 0;
} else if (lsame_(compq, "P")) {
icompq = 1;
} else if (lsame_(compq, "I")) {
icompq = 2;
} else {
icompq = -1;
}
if (iuplo == 0) {
*info = -1;
} else if (icompq < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ldu < 1 || icompq == 2 && *ldu < *n) {
*info = -7;
} else if (*ldvt < 1 || icompq == 2 && *ldvt < *n) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SBDSDC", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
smlsiz = ilaenv_(&c__9, "SBDSDC", " ", &c__0, &c__0, &c__0, &c__0);
if (*n == 1) {
if (icompq == 1) {
q[1] = r_sign(&c_b15, &d__[1]);
q[smlsiz * *n + 1] = 1.f;
} else if (icompq == 2) {
u[u_dim1 + 1] = r_sign(&c_b15, &d__[1]);
vt[vt_dim1 + 1] = 1.f;
}
d__[1] = ABS(d__[1]);
return 0;
}
nm1 = *n - 1;
/* If matrix lower bidiagonal, rotate to be upper bidiagonal */
/* by applying Givens rotations on the left */
wstart = 1;
qstart = 3;
if (icompq == 1) {
scopy_(n, &d__[1], &c__1, &q[1], &c__1);
i__1 = *n - 1;
scopy_(&i__1, &e[1], &c__1, &q[*n + 1], &c__1);
}
if (iuplo == 2) {
qstart = 5;
wstart = (*n << 1) - 1;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
slartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
if (icompq == 1) {
q[i__ + (*n << 1)] = cs;
q[i__ + *n * 3] = sn;
} else if (icompq == 2) {
work[i__] = cs;
work[nm1 + i__] = -sn;
}
/* L10: */
}
}
/* If ICOMPQ = 0, use SLASDQ to compute the singular values. */
if (icompq == 0) {
slasdq_("U", &c__0, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[
vt_offset], ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[
wstart], info);
goto L40;
}
/* If N is smaller than the minimum divide size SMLSIZ, then solve */
/* the problem with another solver. */
if (*n <= smlsiz) {
if (icompq == 2) {
slaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu);
slaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt);
slasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &vt[vt_offset]
, ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[
wstart], info);
} else if (icompq == 1) {
iu = 1;
ivt = iu + *n;
slaset_("A", n, n, &c_b29, &c_b15, &q[iu + (qstart - 1) * *n], n);
slaset_("A", n, n, &c_b29, &c_b15, &q[ivt + (qstart - 1) * *n], n);
slasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &q[ivt + (
qstart - 1) * *n], n, &q[iu + (qstart - 1) * *n], n, &q[
iu + (qstart - 1) * *n], n, &work[wstart], info);
}
goto L40;
}
if (icompq == 2) {
slaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu);
slaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt);
}
/* Scale. */
orgnrm = slanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.f) {
return 0;
}
slascl_("G", &c__0, &c__0, &orgnrm, &c_b15, n, &c__1, &d__[1], n, &ierr);
slascl_("G", &c__0, &c__0, &orgnrm, &c_b15, &nm1, &c__1, &e[1], &nm1, &
ierr);
eps = slamch_("Epsilon");
mlvl = (int) (log((float) (*n) / (float) (smlsiz + 1)) / log(2.f)) + 1;
smlszp = smlsiz + 1;
if (icompq == 1) {
iu = 1;
ivt = smlsiz + 1;
difl = ivt + smlszp;
difr = difl + mlvl;
z__ = difr + (mlvl << 1);
ic = z__ + mlvl;
is = ic + 1;
poles = is + 1;
givnum = poles + (mlvl << 1);
k = 1;
givptr = 2;
perm = 3;
givcol = perm + mlvl;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((r__1 = d__[i__], ABS(r__1)) < eps) {
d__[i__] = r_sign(&eps, &d__[i__]);
}
/* L20: */
}
start = 1;
sqre = 0;
i__1 = nm1;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((r__1 = e[i__], ABS(r__1)) < eps || i__ == nm1) {
/* Subproblem found. First determine its size and then */
/* apply divide and conquer on it. */
if (i__ < nm1) {
/* A subproblem with E(I) small for I < NM1. */
nsize = i__ - start + 1;
} else if ((r__1 = e[i__], ABS(r__1)) >= eps) {
/* A subproblem with E(NM1) not too small but I = NM1. */
nsize = *n - start + 1;
} else {
/* A subproblem with E(NM1) small. This implies an */
/* 1-by-1 subproblem at D(N). Solve this 1-by-1 problem */
/* first. */
nsize = i__ - start + 1;
if (icompq == 2) {
u[*n + *n * u_dim1] = r_sign(&c_b15, &d__[*n]);
vt[*n + *n * vt_dim1] = 1.f;
} else if (icompq == 1) {
q[*n + (qstart - 1) * *n] = r_sign(&c_b15, &d__[*n]);
q[*n + (smlsiz + qstart - 1) * *n] = 1.f;
}
d__[*n] = (r__1 = d__[*n], ABS(r__1));
}
if (icompq == 2) {
slasd0_(&nsize, &sqre, &d__[start], &e[start], &u[start +
start * u_dim1], ldu, &vt[start + start * vt_dim1],
ldvt, &smlsiz, &iwork[1], &work[wstart], info);
} else {
slasda_(&icompq, &smlsiz, &nsize, &sqre, &d__[start], &e[
start], &q[start + (iu + qstart - 2) * *n], n, &q[
start + (ivt + qstart - 2) * *n], &iq[start + k * *n],
&q[start + (difl + qstart - 2) * *n], &q[start + (
difr + qstart - 2) * *n], &q[start + (z__ + qstart -
2) * *n], &q[start + (poles + qstart - 2) * *n], &iq[
start + givptr * *n], &iq[start + givcol * *n], n, &
iq[start + perm * *n], &q[start + (givnum + qstart -
2) * *n], &q[start + (ic + qstart - 2) * *n], &q[
start + (is + qstart - 2) * *n], &work[wstart], &
iwork[1], info);
if (*info != 0) {
return 0;
}
}
start = i__ + 1;
}
/* L30: */
}
/* Unscale */
slascl_("G", &c__0, &c__0, &c_b15, &orgnrm, n, &c__1, &d__[1], n, &ierr);
L40:
/* Use Selection Sort to minimize swaps of singular vectors */
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
i__ = ii - 1;
kk = i__;
p = d__[i__];
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
if (d__[j] > p) {
kk = j;
p = d__[j];
}
/* L50: */
}
if (kk != i__) {
d__[kk] = d__[i__];
d__[i__] = p;
if (icompq == 1) {
iq[i__] = kk;
} else if (icompq == 2) {
sswap_(n, &u[i__ * u_dim1 + 1], &c__1, &u[kk * u_dim1 + 1], &
c__1);
sswap_(n, &vt[i__ + vt_dim1], ldvt, &vt[kk + vt_dim1], ldvt);
}
} else if (icompq == 1) {
iq[i__] = i__;
}
/* L60: */
}
/* If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO */
if (icompq == 1) {
if (iuplo == 1) {
iq[*n] = 1;
} else {
iq[*n] = 0;
}
}
/* If B is lower bidiagonal, update U by those Givens rotations */
/* which rotated B to be upper bidiagonal */
if (iuplo == 2 && icompq == 2) {
slasr_("L", "V", "B", n, n, &work[1], &work[*n], &u[u_offset], ldu);
}
return 0;
/* End of SBDSDC */
} /* sbdsdc_ */
/*< SUBROUTINE SLARFG( N, ALPHA, X, INCX, TAU ) >*/
/* Subroutine */ int slarfg_(integer *n, real *alpha, real *x, integer *incx,
real *tau)
{
/* System generated locals */
integer i__1;
real r__1;
/* Builtin functions */
double r_sign(real *, real *);
/* Local variables */
integer j, knt;
real beta;
extern doublereal snrm2_(integer *, real *, integer *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real xnorm;
extern doublereal slapy2_(real *, real *), slamch_(char *, ftnlen);
real safmin, rsafmn;
/* -- 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 */
/* .. Scalar Arguments .. */
/*< INTEGER INCX, N >*/
/*< REAL ALPHA, TAU >*/
/* .. */
/* .. Array Arguments .. */
/*< REAL X( * ) >*/
/* .. */
/* Purpose */
/* ======= */
/* SLARFG generates a real elementary reflector H of order n, such */
/* that */
/* H * ( alpha ) = ( beta ), H' * H = I. */
/* ( x ) ( 0 ) */
/* where alpha and beta are scalars, and x is an (n-1)-element real */
/* vector. H is represented in the form */
/* H = I - tau * ( 1 ) * ( 1 v' ) , */
/* ( v ) */
/* where tau is a real scalar and v is a real (n-1)-element */
/* vector. */
/* If the elements of x are all zero, then tau = 0 and H is taken to be */
/* the unit matrix. */
/* Otherwise 1 <= tau <= 2. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the elementary reflector. */
/* ALPHA (input/output) REAL */
/* On entry, the value alpha. */
/* On exit, it is overwritten with the value beta. */
/* X (input/output) REAL array, dimension */
/* (1+(N-2)*abs(INCX)) */
/* On entry, the vector x. */
/* On exit, it is overwritten with the vector v. */
/* INCX (input) INTEGER */
/* The increment between elements of X. INCX > 0. */
/* TAU (output) REAL */
/* The value tau. */
/* ===================================================================== */
/* .. Parameters .. */
/*< REAL ONE, ZERO >*/
/*< PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) >*/
/* .. */
/* .. Local Scalars .. */
/*< INTEGER J, KNT >*/
/*< REAL BETA, RSAFMN, SAFMIN, XNORM >*/
/* .. */
/* .. External Functions .. */
/*< REAL SLAMCH, SLAPY2, SNRM2 >*/
/*< EXTERNAL SLAMCH, SLAPY2, SNRM2 >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC ABS, SIGN >*/
/* .. */
/* .. External Subroutines .. */
/*< EXTERNAL SSCAL >*/
/* .. */
/* .. Executable Statements .. */
/*< IF( N.LE.1 ) THEN >*/
/* Parameter adjustments */
--x;
/* Function Body */
if (*n <= 1) {
/*< TAU = ZERO >*/
*tau = (float)0.;
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/*< XNORM = SNRM2( N-1, X, INCX ) >*/
i__1 = *n - 1;
xnorm = snrm2_(&i__1, &x[1], incx);
/*< IF( XNORM.EQ.ZERO ) THEN >*/
if (xnorm == (float)0.) {
/* H = I */
/*< TAU = ZERO >*/
*tau = (float)0.;
/*< ELSE >*/
} else {
/* general case */
/*< BETA = -SIGN( SLAPY2( ALPHA, XNORM ), ALPHA ) >*/
r__1 = slapy2_(alpha, &xnorm);
beta = -r_sign(&r__1, alpha);
/*< SAFMIN = SLAMCH( 'S' ) / SLAMCH( 'E' ) >*/
safmin = slamch_("S", (ftnlen)1) / slamch_("E", (ftnlen)1);
/*< IF( ABS( BETA ).LT.SAFMIN ) THEN >*/
if (dabs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute them */
/*< RSAFMN = ONE / SAFMIN >*/
rsafmn = (float)1. / safmin;
/*< KNT = 0 >*/
knt = 0;
/*< 10 CONTINUE >*/
L10:
/*< KNT = KNT + 1 >*/
++knt;
/*< CALL SSCAL( N-1, RSAFMN, X, INCX ) >*/
i__1 = *n - 1;
sscal_(&i__1, &rsafmn, &x[1], incx);
/*< BETA = BETA*RSAFMN >*/
beta *= rsafmn;
/*< ALPHA = ALPHA*RSAFMN >*/
*alpha *= rsafmn;
/*< >*/
if (dabs(beta) < safmin) {
goto L10;
}
/* New BETA is at most 1, at least SAFMIN */
/*< XNORM = SNRM2( N-1, X, INCX ) >*/
i__1 = *n - 1;
xnorm = snrm2_(&i__1, &x[1], incx);
/*< BETA = -SIGN( SLAPY2( ALPHA, XNORM ), ALPHA ) >*/
r__1 = slapy2_(alpha, &xnorm);
beta = -r_sign(&r__1, alpha);
/*< TAU = ( BETA-ALPHA ) / BETA >*/
*tau = (beta - *alpha) / beta;
/*< CALL SSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) >*/
i__1 = *n - 1;
r__1 = (float)1. / (*alpha - beta);
sscal_(&i__1, &r__1, &x[1], incx);
/* If ALPHA is subnormal, it may lose relative accuracy */
/*< ALPHA = BETA >*/
*alpha = beta;
/*< DO 20 J = 1, KNT >*/
i__1 = knt;
for (j = 1; j <= i__1; ++j) {
/*< ALPHA = ALPHA*SAFMIN >*/
*alpha *= safmin;
/*< 20 CONTINUE >*/
/* L20: */
}
/*< ELSE >*/
} else {
/*< TAU = ( BETA-ALPHA ) / BETA >*/
*tau = (beta - *alpha) / beta;
/*< CALL SSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) >*/
i__1 = *n - 1;
r__1 = (float)1. / (*alpha - beta);
sscal_(&i__1, &r__1, &x[1], incx);
/*< ALPHA = BETA >*/
*alpha = beta;
/*< END IF >*/
}
/*< END IF >*/
}
/*< RETURN >*/
return 0;
/* End of SLARFG */
/*< END >*/
} /* slarfg_ */
rsexp r_num_ge_p (RState* r, rsexp lhs, rsexp rhs)
{
rsexp diff;
ensure (diff = real_diff (r, lhs, rhs));
return r_bool_to_sexp (r_sign (diff) >= 0);
}
/* Subroutine */ int slarfp_(integer *n, real *alpha, real *x, integer *incx,
real *tau)
{
/* System generated locals */
integer i__1;
real r__1;
/* Local variables */
integer j, knt;
real beta;
real xnorm;
real safmin, rsafmn;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SLARFP generates a real elementary reflector H of order n, such */
/* that */
/* H * ( alpha ) = ( beta ), H' * H = I. */
/* ( x ) ( 0 ) */
/* where alpha and beta are scalars, beta is non-negative, and x is */
/* an (n-1)-element real vector. H is represented in the form */
/* H = I - tau * ( 1 ) * ( 1 v' ) , */
/* ( v ) */
/* where tau is a real scalar and v is a real (n-1)-element */
/* vector. */
/* If the elements of x are all zero, then tau = 0 and H is taken to be */
/* the unit matrix. */
/* Otherwise 1 <= tau <= 2. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the elementary reflector. */
/* ALPHA (input/output) REAL */
/* On entry, the value alpha. */
/* On exit, it is overwritten with the value beta. */
/* X (input/output) REAL array, dimension */
/* (1+(N-2)*abs(INCX)) */
/* On entry, the vector x. */
/* On exit, it is overwritten with the vector v. */
/* INCX (input) INTEGER */
/* The increment between elements of X. INCX > 0. */
/* TAU (output) REAL */
/* The value tau. */
/* ===================================================================== */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n <= 0) {
*tau = 0.f;
return 0;
}
i__1 = *n - 1;
xnorm = snrm2_(&i__1, &x[1], incx);
if (xnorm == 0.f) {
/* H = [+/-1, 0; I], sign chosen so ALPHA >= 0. */
if (*alpha >= 0.f) {
/* When TAU.eq.ZERO, the vector is special-cased to be */
/* all zeros in the application routines. We do not need */
/* to clear it. */
*tau = 0.f;
} else {
/* However, the application routines rely on explicit */
/* zero checks when TAU.ne.ZERO, and we must clear X. */
*tau = 2.f;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
x[(j - 1) * *incx + 1] = 0.f;
}
*alpha = -(*alpha);
}
} else {
/* general case */
r__1 = slapy2_(alpha, &xnorm);
beta = r_sign(&r__1, alpha);
safmin = slamch_("S") / slamch_("E");
knt = 0;
if (dabs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute them */
rsafmn = 1.f / safmin;
L10:
++knt;
i__1 = *n - 1;
sscal_(&i__1, &rsafmn, &x[1], incx);
beta *= rsafmn;
*alpha *= rsafmn;
if (dabs(beta) < safmin) {
goto L10;
}
/* New BETA is at most 1, at least SAFMIN */
i__1 = *n - 1;
xnorm = snrm2_(&i__1, &x[1], incx);
r__1 = slapy2_(alpha, &xnorm);
beta = r_sign(&r__1, alpha);
}
*alpha += beta;
if (beta < 0.f) {
beta = -beta;
*tau = -(*alpha) / beta;
} else {
*alpha = xnorm * (xnorm / *alpha);
*tau = *alpha / beta;
*alpha = -(*alpha);
}
i__1 = *n - 1;
r__1 = 1.f / *alpha;
sscal_(&i__1, &r__1, &x[1], incx);
/* If BETA is subnormal, it may lose relative accuracy */
i__1 = knt;
for (j = 1; j <= i__1; ++j) {
beta *= safmin;
}
*alpha = beta;
}
return 0;
/* End of SLARFP */
} /* slarfp_ */
int sbdsqr_(char *uplo, int *n, int *ncvt, int *
nru, int *ncc, float *d__, float *e, float *vt, int *ldvt, float *
u, int *ldu, float *c__, int *ldc, float *work, int *info)
{
/* System generated locals */
int c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
i__2;
float r__1, r__2, r__3, r__4;
double d__1;
/* Builtin functions */
double pow_dd(double *, double *), sqrt(double), r_sign(float *
, float *);
/* Local variables */
float f, g, h__;
int i__, j, m;
float r__, cs;
int ll;
float sn, mu;
int nm1, nm12, nm13, lll;
float eps, sll, tol, abse;
int idir;
float abss;
int oldm;
float cosl;
int isub, iter;
float unfl, sinl, cosr, smin, smax, sinr;
extern int srot_(int *, float *, int *, float *,
int *, float *, float *), slas2_(float *, float *, float *, float *,
float *);
extern int lsame_(char *, char *);
float oldcs;
extern int sscal_(int *, float *, float *, int *);
int oldll;
float shift, sigmn, oldsn;
int maxit;
float sminl;
extern int slasr_(char *, char *, char *, int *,
int *, float *, float *, float *, int *);
float sigmx;
int lower;
extern int sswap_(int *, float *, int *, float *,
int *), slasq1_(int *, float *, float *, float *, int *),
slasv2_(float *, float *, float *, float *, float *, float *, float *,
float *, float *);
extern double slamch_(char *);
extern int xerbla_(char *, int *);
float sminoa;
extern int slartg_(float *, float *, float *, float *, float *
);
float thresh;
int rotate;
float tolmul;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SBDSQR computes the singular values and, optionally, the right and/or */
/* left singular vectors from the singular value decomposition (SVD) of */
/* a float 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 float 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 SGEBRD, 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 float 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL array, dimension (4*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: If INFO = -i, the i-th argument had an illegal value */
/* > 0: */
/* if NCVT = NRU = NCC = 0, */
/* = 1, a split was marked by a positive value in E */
/* = 2, current block of Z not diagonalized after 30*N */
/* iterations (in inner while loop) */
/* = 3, termination criterion of outer while loop not met */
/* (program created more than N unreduced blocks) */
/* else NCVT = NRU = NCC = 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 REAL, 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_("SBDSQR", &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) {
slasq1_(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 = slamch_("Epsilon");
unfl = slamch_("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__) {
slartg_(&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) {
slasr_("R", "V", "F", nru, n, &work[1], &work[*n], &u[u_offset],
ldu);
}
if (*ncc > 0) {
slasr_("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__1 = (double) eps;
r__3 = 100.f, r__4 = pow_dd(&d__1, &c_b15);
r__1 = 10.f, r__2 = MIN(r__3,r__4);
tolmul = MAX(r__1,r__2);
tol = tolmul * eps;
/* Compute approximate maximum, minimum singular values */
smax = 0.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__2 = smax, r__3 = (r__1 = d__[i__], ABS(r__1));
smax = MAX(r__2,r__3);
/* L20: */
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__2 = smax, r__3 = (r__1 = e[i__], ABS(r__1));
smax = MAX(r__2,r__3);
/* L30: */
}
sminl = 0.f;
if (tol >= 0.f) {
/* Relative accuracy desired */
sminoa = ABS(d__[1]);
if (sminoa == 0.f) {
goto L50;
}
mu = sminoa;
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
mu = (r__2 = d__[i__], ABS(r__2)) * (mu / (mu + (r__1 = e[i__ -
1], ABS(r__1))));
sminoa = MIN(sminoa,mu);
if (sminoa == 0.f) {
goto L50;
}
/* L40: */
}
L50:
sminoa /= sqrt((float) (*n));
/* Computing MAX */
r__1 = tol * sminoa, r__2 = *n * 6 * *n * unfl;
thresh = MAX(r__1,r__2);
} else {
/* Absolute accuracy desired */
/* Computing MAX */
r__1 = ABS(tol) * smax, r__2 = *n * 6 * *n * unfl;
thresh = MAX(r__1,r__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.f && (r__1 = d__[m], ABS(r__1)) <= thresh) {
d__[m] = 0.f;
}
smax = (r__1 = d__[m], ABS(r__1));
smin = smax;
i__1 = m - 1;
for (lll = 1; lll <= i__1; ++lll) {
ll = m - lll;
abss = (r__1 = d__[ll], ABS(r__1));
abse = (r__1 = e[ll], ABS(r__1));
if (tol < 0.f && abss <= thresh) {
d__[ll] = 0.f;
}
if (abse <= thresh) {
goto L80;
}
smin = MIN(smin,abss);
/* Computing MAX */
r__1 = MAX(smax,abss);
smax = MAX(r__1,abse);
/* L70: */
}
ll = 0;
goto L90;
L80:
e[ll] = 0.f;
/* 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 */
slasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr,
&sinl, &cosl);
d__[m - 1] = sigmx;
e[m - 1] = 0.f;
d__[m] = sigmn;
/* Compute singular vectors, if desired */
if (*ncvt > 0) {
srot_(ncvt, &vt[m - 1 + vt_dim1], ldvt, &vt[m + vt_dim1], ldvt, &
cosr, &sinr);
}
if (*nru > 0) {
srot_(nru, &u[(m - 1) * u_dim1 + 1], &c__1, &u[m * u_dim1 + 1], &
c__1, &cosl, &sinl);
}
if (*ncc > 0) {
srot_(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 ((r__1 = d__[ll], ABS(r__1)) >= (r__2 = d__[m], ABS(r__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 ((r__2 = e[m - 1], ABS(r__2)) <= ABS(tol) * (r__1 = d__[m], ABS(
r__1)) || tol < 0.f && (r__3 = e[m - 1], ABS(r__3)) <=
thresh) {
e[m - 1] = 0.f;
goto L60;
}
if (tol >= 0.f) {
/* If relative accuracy desired, */
/* apply convergence criterion forward */
mu = (r__1 = d__[ll], ABS(r__1));
sminl = mu;
i__1 = m - 1;
for (lll = ll; lll <= i__1; ++lll) {
if ((r__1 = e[lll], ABS(r__1)) <= tol * mu) {
e[lll] = 0.f;
goto L60;
}
mu = (r__2 = d__[lll + 1], ABS(r__2)) * (mu / (mu + (r__1 =
e[lll], ABS(r__1))));
sminl = MIN(sminl,mu);
/* L100: */
}
}
} else {
/* Run convergence test in backward direction */
/* First apply standard test to top of matrix */
if ((r__2 = e[ll], ABS(r__2)) <= ABS(tol) * (r__1 = d__[ll], ABS(
r__1)) || tol < 0.f && (r__3 = e[ll], ABS(r__3)) <= thresh) {
e[ll] = 0.f;
goto L60;
}
if (tol >= 0.f) {
/* If relative accuracy desired, */
/* apply convergence criterion backward */
mu = (r__1 = d__[m], ABS(r__1));
sminl = mu;
i__1 = ll;
for (lll = m - 1; lll >= i__1; --lll) {
if ((r__1 = e[lll], ABS(r__1)) <= tol * mu) {
e[lll] = 0.f;
goto L60;
}
mu = (r__2 = d__[lll], ABS(r__2)) * (mu / (mu + (r__1 = e[
lll], ABS(r__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 */
r__1 = eps, r__2 = tol * .01f;
if (tol >= 0.f && *n * tol * (sminl / smax) <= MAX(r__1,r__2)) {
/* Use a zero shift to avoid loss of relative accuracy */
shift = 0.f;
} else {
/* Compute the shift from 2-by-2 block at end of matrix */
if (idir == 1) {
sll = (r__1 = d__[ll], ABS(r__1));
slas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__);
} else {
sll = (r__1 = d__[m], ABS(r__1));
slas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__);
}
/* Test if shift negligible, and if so set to zero */
if (sll > 0.f) {
/* Computing 2nd power */
r__1 = shift / sll;
if (r__1 * r__1 < eps) {
shift = 0.f;
}
}
}
/* Increment iteration count */
iter = iter + m - ll;
/* If SHIFT = 0, do simplified QR iteration */
if (shift == 0.f) {
if (idir == 1) {
/* Chase bulge from top to bottom */
/* Save cosines and sines for later singular vector updates */
cs = 1.f;
oldcs = 1.f;
i__1 = m - 1;
for (i__ = ll; i__ <= i__1; ++i__) {
r__1 = d__[i__] * cs;
slartg_(&r__1, &e[i__], &cs, &sn, &r__);
if (i__ > ll) {
e[i__ - 1] = oldsn * r__;
}
r__1 = oldcs * r__;
r__2 = d__[i__ + 1] * sn;
slartg_(&r__1, &r__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;
slasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[
ll + vt_dim1], ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
slasr_("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;
slasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13
+ 1], &c__[ll + c_dim1], ldc);
}
/* Test convergence */
if ((r__1 = e[m - 1], ABS(r__1)) <= thresh) {
e[m - 1] = 0.f;
}
} else {
/* Chase bulge from bottom to top */
/* Save cosines and sines for later singular vector updates */
cs = 1.f;
oldcs = 1.f;
i__1 = ll + 1;
for (i__ = m; i__ >= i__1; --i__) {
r__1 = d__[i__] * cs;
slartg_(&r__1, &e[i__ - 1], &cs, &sn, &r__);
if (i__ < m) {
e[i__] = oldsn * r__;
}
r__1 = oldcs * r__;
r__2 = d__[i__ - 1] * sn;
slartg_(&r__1, &r__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;
slasr_("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;
slasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll *
u_dim1 + 1], ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
slasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &c__[
ll + c_dim1], ldc);
}
/* Test convergence */
if ((r__1 = e[ll], ABS(r__1)) <= thresh) {
e[ll] = 0.f;
}
}
} else {
/* Use nonzero shift */
if (idir == 1) {
/* Chase bulge from top to bottom */
/* Save cosines and sines for later singular vector updates */
f = ((r__1 = d__[ll], ABS(r__1)) - shift) * (r_sign(&c_b49, &d__[
ll]) + shift / d__[ll]);
g = e[ll];
i__1 = m - 1;
for (i__ = ll; i__ <= i__1; ++i__) {
slartg_(&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];
slartg_(&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;
slasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[
ll + vt_dim1], ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
slasr_("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;
slasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13
+ 1], &c__[ll + c_dim1], ldc);
}
/* Test convergence */
if ((r__1 = e[m - 1], ABS(r__1)) <= thresh) {
e[m - 1] = 0.f;
}
} else {
/* Chase bulge from bottom to top */
/* Save cosines and sines for later singular vector updates */
f = ((r__1 = d__[m], ABS(r__1)) - shift) * (r_sign(&c_b49, &d__[
m]) + shift / d__[m]);
g = e[m - 1];
i__1 = ll + 1;
for (i__ = m; i__ >= i__1; --i__) {
slartg_(&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];
slartg_(&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 ((r__1 = e[ll], ABS(r__1)) <= thresh) {
e[ll] = 0.f;
}
/* Update singular vectors if desired */
if (*ncvt > 0) {
i__1 = m - ll + 1;
slasr_("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;
slasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll *
u_dim1 + 1], ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
slasr_("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.f) {
d__[i__] = -d__[i__];
/* Change sign of singular vectors, if desired */
if (*ncvt > 0) {
sscal_(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) {
sswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[*n + 1 - i__ +
vt_dim1], ldvt);
}
if (*nru > 0) {
sswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[(*n + 1 - i__) *
u_dim1 + 1], &c__1);
}
if (*ncc > 0) {
sswap_(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.f) {
++(*info);
}
/* L210: */
}
L220:
return 0;
/* End of SBDSQR */
} /* sbdsqr_ */
/* Subroutine */ int slaic1_(integer *job, integer *j, real *x, real *sest,
real *w, real *gamma, real *sestpr, real *s, real *c__)
{
/* System generated locals */
real r__1, r__2, r__3, r__4;
/* Builtin functions */
double sqrt(doublereal), r_sign(real *, real *);
/* Local variables */
real b, t, s1, s2, eps, tmp, sine;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
real test, zeta1, zeta2, alpha, norma, absgam, absalp;
extern doublereal slamch_(char *);
real cosine, absest;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLAIC1 applies one step of incremental condition estimation in */
/* its simplest version: */
/* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j */
/* lower triangular matrix L, such that */
/* twonorm(L*x) = sest */
/* Then SLAIC1 computes sestpr, s, c such that */
/* the vector */
/* [ s*x ] */
/* xhat = [ c ] */
/* is an approximate singular vector of */
/* [ L 0 ] */
/* Lhat = [ w' gamma ] */
/* in the sense that */
/* twonorm(Lhat*xhat) = sestpr. */
/* Depending on JOB, an estimate for the largest or smallest singular */
/* value is computed. */
/* Note that [s c]' and sestpr**2 is an eigenpair of the system */
/* diag(sest*sest, 0) + [alpha gamma] * [ alpha ] */
/* [ gamma ] */
/* where alpha = x'*w. */
/* Arguments */
/* ========= */
/* JOB (input) INTEGER */
/* = 1: an estimate for the largest singular value is computed. */
/* = 2: an estimate for the smallest singular value is computed. */
/* J (input) INTEGER */
/* Length of X and W */
/* X (input) REAL array, dimension (J) */
/* The j-vector x. */
/* SEST (input) REAL */
/* Estimated singular value of j by j matrix L */
/* W (input) REAL array, dimension (J) */
/* The j-vector w. */
/* GAMMA (input) REAL */
/* The diagonal element gamma. */
/* SESTPR (output) REAL */
/* Estimated singular value of (j+1) by (j+1) matrix Lhat. */
/* S (output) REAL */
/* Sine needed in forming xhat. */
/* C (output) REAL */
/* Cosine needed in forming xhat. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--w;
--x;
/* Function Body */
eps = slamch_("Epsilon");
alpha = sdot_(j, &x[1], &c__1, &w[1], &c__1);
absalp = dabs(alpha);
absgam = dabs(*gamma);
absest = dabs(*sest);
if (*job == 1) {
/* Estimating largest singular value */
/* special cases */
if (*sest == 0.f) {
s1 = dmax(absgam,absalp);
if (s1 == 0.f) {
*s = 0.f;
*c__ = 1.f;
*sestpr = 0.f;
} else {
*s = alpha / s1;
*c__ = *gamma / s1;
tmp = sqrt(*s * *s + *c__ * *c__);
*s /= tmp;
*c__ /= tmp;
*sestpr = s1 * tmp;
}
return 0;
} else if (absgam <= eps * absest) {
*s = 1.f;
*c__ = 0.f;
tmp = dmax(absest,absalp);
s1 = absest / tmp;
s2 = absalp / tmp;
*sestpr = tmp * sqrt(s1 * s1 + s2 * s2);
return 0;
} else if (absalp <= eps * absest) {
s1 = absgam;
s2 = absest;
if (s1 <= s2) {
*s = 1.f;
*c__ = 0.f;
*sestpr = s2;
} else {
*s = 0.f;
*c__ = 1.f;
*sestpr = s1;
}
return 0;
} else if (absest <= eps * absalp || absest <= eps * absgam) {
s1 = absgam;
s2 = absalp;
if (s1 <= s2) {
tmp = s1 / s2;
*s = sqrt(tmp * tmp + 1.f);
*sestpr = s2 * *s;
*c__ = *gamma / s2 / *s;
*s = r_sign(&c_b5, &alpha) / *s;
} else {
tmp = s2 / s1;
*c__ = sqrt(tmp * tmp + 1.f);
*sestpr = s1 * *c__;
*s = alpha / s1 / *c__;
*c__ = r_sign(&c_b5, gamma) / *c__;
}
return 0;
} else {
/* normal case */
zeta1 = alpha / absest;
zeta2 = *gamma / absest;
b = (1.f - zeta1 * zeta1 - zeta2 * zeta2) * .5f;
*c__ = zeta1 * zeta1;
if (b > 0.f) {
t = *c__ / (b + sqrt(b * b + *c__));
} else {
t = sqrt(b * b + *c__) - b;
}
sine = -zeta1 / t;
cosine = -zeta2 / (t + 1.f);
tmp = sqrt(sine * sine + cosine * cosine);
*s = sine / tmp;
*c__ = cosine / tmp;
*sestpr = sqrt(t + 1.f) * absest;
return 0;
}
} else if (*job == 2) {
/* Estimating smallest singular value */
/* special cases */
if (*sest == 0.f) {
*sestpr = 0.f;
if (dmax(absgam,absalp) == 0.f) {
sine = 1.f;
cosine = 0.f;
} else {
sine = -(*gamma);
cosine = alpha;
}
/* Computing MAX */
r__1 = dabs(sine), r__2 = dabs(cosine);
s1 = dmax(r__1,r__2);
*s = sine / s1;
*c__ = cosine / s1;
tmp = sqrt(*s * *s + *c__ * *c__);
*s /= tmp;
*c__ /= tmp;
return 0;
} else if (absgam <= eps * absest) {
*s = 0.f;
*c__ = 1.f;
*sestpr = absgam;
return 0;
} else if (absalp <= eps * absest) {
s1 = absgam;
s2 = absest;
if (s1 <= s2) {
*s = 0.f;
*c__ = 1.f;
*sestpr = s1;
} else {
*s = 1.f;
*c__ = 0.f;
*sestpr = s2;
}
return 0;
} else if (absest <= eps * absalp || absest <= eps * absgam) {
s1 = absgam;
s2 = absalp;
if (s1 <= s2) {
tmp = s1 / s2;
*c__ = sqrt(tmp * tmp + 1.f);
*sestpr = absest * (tmp / *c__);
*s = -(*gamma / s2) / *c__;
*c__ = r_sign(&c_b5, &alpha) / *c__;
} else {
tmp = s2 / s1;
*s = sqrt(tmp * tmp + 1.f);
*sestpr = absest / *s;
*c__ = alpha / s1 / *s;
*s = -r_sign(&c_b5, gamma) / *s;
}
return 0;
} else {
/* normal case */
zeta1 = alpha / absest;
zeta2 = *gamma / absest;
/* Computing MAX */
r__3 = zeta1 * zeta1 + 1.f + (r__1 = zeta1 * zeta2, dabs(r__1)),
r__4 = (r__2 = zeta1 * zeta2, dabs(r__2)) + zeta2 * zeta2;
norma = dmax(r__3,r__4);
/* See if root is closer to zero or to ONE */
test = (zeta1 - zeta2) * 2.f * (zeta1 + zeta2) + 1.f;
if (test >= 0.f) {
/* root is close to zero, compute directly */
b = (zeta1 * zeta1 + zeta2 * zeta2 + 1.f) * .5f;
*c__ = zeta2 * zeta2;
t = *c__ / (b + sqrt((r__1 = b * b - *c__, dabs(r__1))));
sine = zeta1 / (1.f - t);
cosine = -zeta2 / t;
*sestpr = sqrt(t + eps * 4.f * eps * norma) * absest;
} else {
/* root is closer to ONE, shift by that amount */
b = (zeta2 * zeta2 + zeta1 * zeta1 - 1.f) * .5f;
*c__ = zeta1 * zeta1;
if (b >= 0.f) {
t = -(*c__) / (b + sqrt(b * b + *c__));
} else {
t = b - sqrt(b * b + *c__);
}
sine = -zeta1 / t;
cosine = -zeta2 / (t + 1.f);
*sestpr = sqrt(t + 1.f + eps * 4.f * eps * norma) * absest;
}
tmp = sqrt(sine * sine + cosine * cosine);
*s = sine / tmp;
*c__ = cosine / tmp;
return 0;
}
}
return 0;
/* End of SLAIC1 */
} /* slaic1_ */
/* Subroutine */ int slasd3_(integer *nl, integer *nr, integer *sqre, integer
*k, real *d__, real *q, integer *ldq, real *dsigma, real *u, integer *
ldu, real *u2, integer *ldu2, real *vt, integer *ldvt, real *vt2,
integer *ldvt2, integer *idxc, integer *ctot, real *z__, integer *
info)
{
/* System generated locals */
integer q_dim1, q_offset, u_dim1, u_offset, u2_dim1, u2_offset, vt_dim1,
vt_offset, vt2_dim1, vt2_offset, i__1, i__2;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal), r_sign(real *, real *);
/* Local variables */
integer i__, j, m, n, jc;
real rho;
integer nlp1, nlp2, nrp1;
real temp;
extern doublereal snrm2_(integer *, real *, integer *);
integer ctemp;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
integer ktemp;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
extern doublereal slamc3_(real *, real *);
extern /* Subroutine */ int slasd4_(integer *, integer *, real *, real *,
real *, real *, real *, real *, integer *), xerbla_(char *,
integer *), slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *,
real *, integer *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLASD3 finds all the square roots of the roots of the secular */
/* equation, as defined by the values in D and Z. It makes the */
/* appropriate calls to SLASD4 and then updates the singular */
/* vectors by matrix multiplication. */
/* This code makes very mild assumptions about floating point */
/* arithmetic. It will work on machines with a guard digit in */
/* add/subtract, or on those binary machines without guard digits */
/* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. */
/* It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. */
/* SLASD3 is called from SLASD1. */
/* Arguments */
/* ========= */
/* NL (input) INTEGER */
/* The row dimension of the upper block. NL >= 1. */
/* NR (input) INTEGER */
/* The row dimension of the lower block. NR >= 1. */
/* SQRE (input) INTEGER */
/* = 0: the lower block is an NR-by-NR square matrix. */
/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */
/* The bidiagonal matrix has N = NL + NR + 1 rows and */
/* M = N + SQRE >= N columns. */
/* K (input) INTEGER */
/* The size of the secular equation, 1 =< K = < N. */
/* D (output) REAL array, dimension(K) */
/* On exit the square roots of the roots of the secular equation, */
/* in ascending order. */
/* Q (workspace) REAL array, */
/* dimension at least (LDQ,K). */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= K. */
/* DSIGMA (input/output) REAL array, dimension(K) */
/* The first K elements of this array contain the old roots */
/* of the deflated updating problem. These are the poles */
/* of the secular equation. */
/* U (output) REAL array, dimension (LDU, N) */
/* The last N - K columns of this matrix contain the deflated */
/* left singular vectors. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= N. */
/* U2 (input) REAL array, dimension (LDU2, N) */
/* The first K columns of this matrix contain the non-deflated */
/* left singular vectors for the split problem. */
/* LDU2 (input) INTEGER */
/* The leading dimension of the array U2. LDU2 >= N. */
/* VT (output) REAL array, dimension (LDVT, M) */
/* The last M - K columns of VT' contain the deflated */
/* right singular vectors. */
/* LDVT (input) INTEGER */
/* The leading dimension of the array VT. LDVT >= N. */
/* VT2 (input/output) REAL array, dimension (LDVT2, N) */
/* The first K columns of VT2' contain the non-deflated */
/* right singular vectors for the split problem. */
/* LDVT2 (input) INTEGER */
/* The leading dimension of the array VT2. LDVT2 >= N. */
/* IDXC (input) INTEGER array, dimension (N) */
/* The permutation used to arrange the columns of U (and rows of */
/* VT) into three groups: the first group contains non-zero */
/* entries only at and above (or before) NL +1; the second */
/* contains non-zero entries only at and below (or after) NL+2; */
/* and the third is dense. The first column of U and the row of */
/* VT are treated separately, however. */
/* The rows of the singular vectors found by SLASD4 */
/* must be likewise permuted before the matrix multiplies can */
/* take place. */
/* CTOT (input) INTEGER array, dimension (4) */
/* A count of the total number of the various types of columns */
/* in U (or rows in VT), as described in IDXC. The fourth column */
/* type is any column which has been deflated. */
/* Z (input/output) REAL array, dimension (K) */
/* The first K elements of this array contain the components */
/* of the deflation-adjusted updating row vector. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = 1, an singular value did not converge */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Huan Ren, Computer Science Division, University of */
/* California at Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--dsigma;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
u2_dim1 = *ldu2;
u2_offset = 1 + u2_dim1;
u2 -= u2_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
vt2_dim1 = *ldvt2;
vt2_offset = 1 + vt2_dim1;
vt2 -= vt2_offset;
--idxc;
--ctot;
--z__;
/* Function Body */
*info = 0;
if (*nl < 1) {
*info = -1;
} else if (*nr < 1) {
*info = -2;
} else if (*sqre != 1 && *sqre != 0) {
*info = -3;
}
n = *nl + *nr + 1;
m = n + *sqre;
nlp1 = *nl + 1;
nlp2 = *nl + 2;
if (*k < 1 || *k > n) {
*info = -4;
} else if (*ldq < *k) {
*info = -7;
} else if (*ldu < n) {
*info = -10;
} else if (*ldu2 < n) {
*info = -12;
} else if (*ldvt < m) {
*info = -14;
} else if (*ldvt2 < m) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SLASD3", &i__1);
return 0;
}
/* Quick return if possible */
if (*k == 1) {
d__[1] = dabs(z__[1]);
scopy_(&m, &vt2[vt2_dim1 + 1], ldvt2, &vt[vt_dim1 + 1], ldvt);
if (z__[1] > 0.f) {
scopy_(&n, &u2[u2_dim1 + 1], &c__1, &u[u_dim1 + 1], &c__1);
} else {
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
u[i__ + u_dim1] = -u2[i__ + u2_dim1];
/* L10: */
}
}
return 0;
}
/* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can */
/* be computed with high relative accuracy (barring over/underflow). */
/* This is a problem on machines without a guard digit in */
/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */
/* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), */
/* which on any of these machines zeros out the bottommost */
/* bit of DSIGMA(I) if it is 1; this makes the subsequent */
/* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation */
/* occurs. On binary machines with a guard digit (almost all */
/* machines) it does not change DSIGMA(I) at all. On hexadecimal */
/* and decimal machines with a guard digit, it slightly */
/* changes the bottommost bits of DSIGMA(I). It does not account */
/* for hexadecimal or decimal machines without guard digits */
/* (we know of none). We use a subroutine call to compute */
/* 2*DSIGMA(I) to prevent optimizing compilers from eliminating */
/* this code. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
dsigma[i__] = slamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__];
/* L20: */
}
/* Keep a copy of Z. */
scopy_(k, &z__[1], &c__1, &q[q_offset], &c__1);
/* Normalize Z. */
rho = snrm2_(k, &z__[1], &c__1);
slascl_("G", &c__0, &c__0, &rho, &c_b13, k, &c__1, &z__[1], k, info);
rho *= rho;
/* Find the new singular values. */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
slasd4_(k, &j, &dsigma[1], &z__[1], &u[j * u_dim1 + 1], &rho, &d__[j],
&vt[j * vt_dim1 + 1], info);
/* If the zero finder fails, the computation is terminated. */
if (*info != 0) {
return 0;
}
/* L30: */
}
/* Compute updated Z. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
z__[i__] = u[i__ + *k * u_dim1] * vt[i__ + *k * vt_dim1];
i__2 = i__ - 1;
for (j = 1; j <= i__2; ++j) {
z__[i__] *= u[i__ + j * u_dim1] * vt[i__ + j * vt_dim1] / (dsigma[
i__] - dsigma[j]) / (dsigma[i__] + dsigma[j]);
/* L40: */
}
i__2 = *k - 1;
for (j = i__; j <= i__2; ++j) {
z__[i__] *= u[i__ + j * u_dim1] * vt[i__ + j * vt_dim1] / (dsigma[
i__] - dsigma[j + 1]) / (dsigma[i__] + dsigma[j + 1]);
/* L50: */
}
r__2 = sqrt((r__1 = z__[i__], dabs(r__1)));
z__[i__] = r_sign(&r__2, &q[i__ + q_dim1]);
/* L60: */
}
/* Compute left singular vectors of the modified diagonal matrix, */
/* and store related information for the right singular vectors. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
vt[i__ * vt_dim1 + 1] = z__[1] / u[i__ * u_dim1 + 1] / vt[i__ *
vt_dim1 + 1];
u[i__ * u_dim1 + 1] = -1.f;
i__2 = *k;
for (j = 2; j <= i__2; ++j) {
vt[j + i__ * vt_dim1] = z__[j] / u[j + i__ * u_dim1] / vt[j + i__
* vt_dim1];
u[j + i__ * u_dim1] = dsigma[j] * vt[j + i__ * vt_dim1];
/* L70: */
}
temp = snrm2_(k, &u[i__ * u_dim1 + 1], &c__1);
q[i__ * q_dim1 + 1] = u[i__ * u_dim1 + 1] / temp;
i__2 = *k;
for (j = 2; j <= i__2; ++j) {
jc = idxc[j];
q[j + i__ * q_dim1] = u[jc + i__ * u_dim1] / temp;
/* L80: */
}
/* L90: */
}
/* Update the left singular vector matrix. */
if (*k == 2) {
sgemm_("N", "N", &n, k, k, &c_b13, &u2[u2_offset], ldu2, &q[q_offset],
ldq, &c_b26, &u[u_offset], ldu);
goto L100;
}
if (ctot[1] > 0) {
sgemm_("N", "N", nl, k, &ctot[1], &c_b13, &u2[(u2_dim1 << 1) + 1],
ldu2, &q[q_dim1 + 2], ldq, &c_b26, &u[u_dim1 + 1], ldu);
if (ctot[3] > 0) {
ktemp = ctot[1] + 2 + ctot[2];
sgemm_("N", "N", nl, k, &ctot[3], &c_b13, &u2[ktemp * u2_dim1 + 1]
, ldu2, &q[ktemp + q_dim1], ldq, &c_b13, &u[u_dim1 + 1],
ldu);
}
} else if (ctot[3] > 0) {
ktemp = ctot[1] + 2 + ctot[2];
sgemm_("N", "N", nl, k, &ctot[3], &c_b13, &u2[ktemp * u2_dim1 + 1],
ldu2, &q[ktemp + q_dim1], ldq, &c_b26, &u[u_dim1 + 1], ldu);
} else {
slacpy_("F", nl, k, &u2[u2_offset], ldu2, &u[u_offset], ldu);
}
scopy_(k, &q[q_dim1 + 1], ldq, &u[nlp1 + u_dim1], ldu);
ktemp = ctot[1] + 2;
ctemp = ctot[2] + ctot[3];
sgemm_("N", "N", nr, k, &ctemp, &c_b13, &u2[nlp2 + ktemp * u2_dim1], ldu2,
&q[ktemp + q_dim1], ldq, &c_b26, &u[nlp2 + u_dim1], ldu);
/* Generate the right singular vectors. */
L100:
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = snrm2_(k, &vt[i__ * vt_dim1 + 1], &c__1);
q[i__ + q_dim1] = vt[i__ * vt_dim1 + 1] / temp;
i__2 = *k;
for (j = 2; j <= i__2; ++j) {
jc = idxc[j];
q[i__ + j * q_dim1] = vt[jc + i__ * vt_dim1] / temp;
/* L110: */
}
/* L120: */
}
/* Update the right singular vector matrix. */
if (*k == 2) {
sgemm_("N", "N", k, &m, k, &c_b13, &q[q_offset], ldq, &vt2[vt2_offset]
, ldvt2, &c_b26, &vt[vt_offset], ldvt);
return 0;
}
ktemp = ctot[1] + 1;
sgemm_("N", "N", k, &nlp1, &ktemp, &c_b13, &q[q_dim1 + 1], ldq, &vt2[
vt2_dim1 + 1], ldvt2, &c_b26, &vt[vt_dim1 + 1], ldvt);
ktemp = ctot[1] + 2 + ctot[2];
if (ktemp <= *ldvt2) {
sgemm_("N", "N", k, &nlp1, &ctot[3], &c_b13, &q[ktemp * q_dim1 + 1],
ldq, &vt2[ktemp + vt2_dim1], ldvt2, &c_b13, &vt[vt_dim1 + 1],
ldvt);
}
ktemp = ctot[1] + 1;
nrp1 = *nr + *sqre;
if (ktemp > 1) {
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
q[i__ + ktemp * q_dim1] = q[i__ + q_dim1];
/* L130: */
}
i__1 = m;
for (i__ = nlp2; i__ <= i__1; ++i__) {
vt2[ktemp + i__ * vt2_dim1] = vt2[i__ * vt2_dim1 + 1];
/* L140: */
}
}
ctemp = ctot[2] + 1 + ctot[3];
sgemm_("N", "N", k, &nrp1, &ctemp, &c_b13, &q[ktemp * q_dim1 + 1], ldq, &
vt2[ktemp + nlp2 * vt2_dim1], ldvt2, &c_b26, &vt[nlp2 * vt_dim1 +
1], ldvt);
return 0;
/* End of SLASD3 */
} /* slasd3_ */
/* Subroutine */ int slarfg_(integer *n, real *alpha, real *x, integer *incx,
real *tau)
{
/* System generated locals */
integer i__1;
real r__1;
/* Builtin functions */
double r_sign(real *, real *);
/* Local variables */
static integer j, knt;
static real beta;
extern doublereal snrm2_(integer *, real *, integer *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static real xnorm;
extern doublereal slapy2_(real *, real *), slamch_(char *, ftnlen);
static real safmin, rsafmn;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLARFG generates a real elementary reflector H of order n, such */
/* that */
/* H * ( alpha ) = ( beta ), H' * H = I. */
/* ( x ) ( 0 ) */
/* where alpha and beta are scalars, and x is an (n-1)-element real */
/* vector. H is represented in the form */
/* H = I - tau * ( 1 ) * ( 1 v' ) , */
/* ( v ) */
/* where tau is a real scalar and v is a real (n-1)-element */
/* vector. */
/* If the elements of x are all zero, then tau = 0 and H is taken to be */
/* the unit matrix. */
/* Otherwise 1 <= tau <= 2. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the elementary reflector. */
/* ALPHA (input/output) REAL */
/* On entry, the value alpha. */
/* On exit, it is overwritten with the value beta. */
/* X (input/output) REAL array, dimension */
/* (1+(N-2)*abs(INCX)) */
/* On entry, the vector x. */
/* On exit, it is overwritten with the vector v. */
/* INCX (input) INTEGER */
/* The increment between elements of X. INCX > 0. */
/* TAU (output) REAL */
/* The value tau. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n <= 1) {
*tau = 0.f;
return 0;
}
i__1 = *n - 1;
xnorm = snrm2_(&i__1, &x[1], incx);
if (xnorm == 0.f) {
/* H = I */
*tau = 0.f;
} else {
/* general case */
r__1 = slapy2_(alpha, &xnorm);
beta = -r_sign(&r__1, alpha);
safmin = slamch_("S", (ftnlen)1) / slamch_("E", (ftnlen)1);
if (dabs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute them */
rsafmn = 1.f / safmin;
knt = 0;
L10:
++knt;
i__1 = *n - 1;
sscal_(&i__1, &rsafmn, &x[1], incx);
beta *= rsafmn;
*alpha *= rsafmn;
if (dabs(beta) < safmin) {
goto L10;
}
/* New BETA is at most 1, at least SAFMIN */
i__1 = *n - 1;
xnorm = snrm2_(&i__1, &x[1], incx);
r__1 = slapy2_(alpha, &xnorm);
beta = -r_sign(&r__1, alpha);
*tau = (beta - *alpha) / beta;
i__1 = *n - 1;
r__1 = 1.f / (*alpha - beta);
sscal_(&i__1, &r__1, &x[1], incx);
/* If ALPHA is subnormal, it may lose relative accuracy */
*alpha = beta;
i__1 = knt;
for (j = 1; j <= i__1; ++j) {
*alpha *= safmin;
/* L20: */
}
} else {
*tau = (beta - *alpha) / beta;
i__1 = *n - 1;
r__1 = 1.f / (*alpha - beta);
sscal_(&i__1, &r__1, &x[1], incx);
*alpha = beta;
}
}
return 0;
/* End of SLARFG */
} /* slarfg_ */
/* Subroutine */ int cdrgev_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, real *thresh, integer *nounit,
complex *a, integer *lda, complex *b, complex *s, complex *t, complex
*q, integer *ldq, complex *z__, complex *qe, integer *ldqe, complex *
alpha, complex *beta, complex *alpha1, complex *beta1, complex *work,
integer *lwork, real *rwork, real *result, 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 logical lasign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
TRUE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,FALSE_,
TRUE_,FALSE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_ };
static logical lbsign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,FALSE_,
TRUE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
FALSE_ };
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 CDRGEV: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/3x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 CDRGEV: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,3x,\002N=\002,i4,\002, JTYPE=\002,"
"i3,\002, ISEED=(\002,3(i4,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(/1x,a3,\002 -- Complex Generalized eigenvalue"
" problem \002,\002driver\002)";
static char fmt_9996[] = "(\002 Matrix types (see CDRGEV for details):"
" \002)";
static char fmt_9995[] = "(\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_9994[] = "(\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_9993[] = "(/\002 Tests performed: \002,/\002 1 = max "
"| ( b A - a B )'*l | / const.,\002,/\002 2 = | |VR(i)| - 1 | / u"
"lp,\002,/\002 3 = max | ( b A - a B )*r | / const.\002,/\002 4 ="
" | |VL(i)| - 1 | / ulp,\002,/\002 5 = 0 if W same no matter if r"
" or l computed,\002,/\002 6 = 0 if l same no matter if l compute"
"d,\002,/\002 7 = 0 if r same no matter if r computed,\002,/1x)";
static char fmt_9992[] = "(\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_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
",1p,e10.3)";
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, qe_dim1,
qe_offset, s_dim1, s_offset, t_dim1, t_offset, z_dim1, z_offset,
i__1, i__2, i__3, i__4, i__5, i__6, i__7;
real r__1, r__2;
complex q__1, q__2, q__3;
/* Builtin functions */
double r_sign(real *, real *), c_abs(complex *);
void r_cnjg(complex *, complex *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer iadd, ierr, nmax, i__, j, n;
static logical badnn;
extern /* Subroutine */ int cget52_(logical *, integer *, complex *,
integer *, complex *, integer *, complex *, integer *, complex *,
complex *, complex *, real *, real *), cggev_(char *, char *,
integer *, complex *, integer *, complex *, integer *, complex *,
complex *, complex *, integer *, complex *, integer *, complex *,
integer *, real *, integer *);
static real rmagn[4];
static complex ctemp;
static integer nmats, jsize, nerrs, jtype, n1;
extern /* Subroutine */ int clatm4_(integer *, integer *, integer *,
integer *, logical *, real *, real *, real *, integer *, integer *
, complex *, integer *), cunm2r_(char *, char *, integer *,
integer *, integer *, complex *, integer *, complex *, complex *,
integer *, complex *, integer *);
static integer jc, nb, in;
extern /* Subroutine */ int slabad_(real *, real *);
static integer jr;
extern /* Subroutine */ int clarfg_(integer *, complex *, complex *,
integer *, complex *);
extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *);
static real safmin, safmax;
static integer ioldsd[4];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *), xerbla_(char *, integer *);
static integer minwrk, maxwrk;
static real ulpinv;
static integer mtypes, ntestt;
static real ulp;
/* Fortran I/O blocks */
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9991, 0 };
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
#define qe_subscr(a_1,a_2) (a_2)*qe_dim1 + a_1
#define qe_ref(a_1,a_2) qe[qe_subscr(a_1,a_2)]
/* -- LAPACK test 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
=======
CDRGEV checks the nonsymmetric generalized eigenvalue problem driver
routine CGGEV.
CGGEV computes for a pair of n-by-n nonsymmetric matrices (A,B) the
generalized eigenvalues and, optionally, the left and right
eigenvectors.
A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
or a ratio alpha/beta = w, such that A - w*B is singular. It is
usually represented as the pair (alpha,beta), as there is reasonalbe
interpretation for beta=0, and even for both being zero.
A right generalized eigenvector corresponding to a generalized
eigenvalue w for a pair of matrices (A,B) is a vector r such that
(A - wB) * r = 0. A left generalized eigenvector is a vector l such
that l**H * (A - wB) = 0, where l**H is the conjugate-transpose of l.
When CDRGEV 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 tests
will be performed and compared with the threshhold THRESH.
Results from CGGEV:
(1) max over all left eigenvalue/-vector pairs (alpha/beta,l) of
| VL**H * (beta A - alpha B) |/( ulp max(|beta A|, |alpha B|) )
where VL**H is the conjugate-transpose of VL.
(2) | |VL(i)| - 1 | / ulp and whether largest component real
VL(i) denotes the i-th column of VL.
(3) max over all left eigenvalue/-vector pairs (alpha/beta,r) of
| (beta A - alpha B) * VR | / ( ulp max(|beta A|, |alpha B|) )
(4) | |VR(i)| - 1 | / ulp and whether largest component real
VR(i) denotes the i-th column of VR.
(5) W(full) = W(partial)
W(full) denotes the eigenvalues computed when both l and r
are also computed, and W(partial) denotes the eigenvalues
computed when only W, only W and r, or only W and l are
computed.
(6) VL(full) = VL(partial)
VL(full) denotes the left eigenvectors computed when both l
and r are computed, and VL(partial) denotes the result
when only l is computed.
(7) VR(full) = VR(partial)
VR(full) denotes the right eigenvectors computed when both l
and r are also computed, and VR(partial) denotes the result
when only l is computed.
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,
CDRGES 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, CDRGEV
does nothing. It must be at least zero. If it is MAXTYP+1
and NSIZES is 1, then an additional type, MAXTYP+1 is
defined, which is to use whatever matrix is in A. This
is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
DOTYPE(MAXTYP+1) is .TRUE. .
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 CDRGES to continue the same random number
sequence.
THRESH (input) REAL
A test will count as "failed" if the "error", computed as
described above, exceeds THRESH. Note that the error is
scaled to be O(1), so THRESH should be a reasonably small
multiple of 1, e.g., 10 or 100. In particular, it should
not depend on the precision (single vs. double) or the size
of the matrix. It must be at least zero.
NOUNIT (input) INTEGER
The FORTRAN unit number for printing out error messages
(e.g., if a routine returns IERR not equal to 0.)
A (input/workspace) COMPLEX 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) COMPLEX 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) COMPLEX array, dimension (LDA, max(NN))
The Schur form matrix computed from A by CGGEV. On exit, S
contains the Schur form matrix corresponding to the matrix
in A.
T (workspace) COMPLEX array, dimension (LDA, max(NN))
The upper triangular matrix computed from B by CGGEV.
Q (workspace) COMPLEX array, dimension (LDQ, max(NN))
The (left) eigenvectors matrix computed by CGGEV.
LDQ (input) INTEGER
The leading dimension of Q and Z. It must
be at least 1 and at least max( NN ).
Z (workspace) COMPLEX array, dimension( LDQ, max(NN) )
The (right) orthogonal matrix computed by CGGEV.
QE (workspace) COMPLEX array, dimension( LDQ, max(NN) )
QE holds the computed right or left eigenvectors.
LDQE (input) INTEGER
The leading dimension of QE. LDQE >= max(1,max(NN)).
ALPHA (workspace) COMPLEX array, dimension (max(NN))
BETA (workspace) COMPLEX array, dimension (max(NN))
The generalized eigenvalues of (A,B) computed by CGGEV.
( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th
generalized eigenvalue of A and B.
ALPHA1 (workspace) COMPLEX array, dimension (max(NN))
BETA1 (workspace) COMPLEX array, dimension (max(NN))
Like ALPHAR, ALPHAI, BETA, these arrays contain the
eigenvalues of A and B, but those computed when CGGEV only
computes a partial eigendecomposition, i.e. not the
eigenvalues and left and right eigenvectors.
WORK (workspace) COMPLEX array, dimension (LWORK)
LWORK (input) INTEGER
The number of entries in WORK. LWORK >= N*(N+1)
RWORK (workspace) REAL array, dimension (8*N)
Real workspace.
RESULT (output) REAL array, dimension (2)
The values computed by the tests described above.
The values are currently limited to 1/ulp, to avoid overflow.
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.
=====================================================================
Parameter adjustments */
--nn;
--dotype;
--iseed;
t_dim1 = *lda;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
s_dim1 = *lda;
s_offset = 1 + s_dim1 * 1;
s -= s_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
z_dim1 = *ldq;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
qe_dim1 = *ldqe;
qe_offset = 1 + qe_dim1 * 1;
qe -= qe_offset;
--alpha;
--beta;
--alpha1;
--beta1;
--work;
--rwork;
--result;
/* Function Body
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.f) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -9;
} else if (*ldq <= 1 || *ldq < nmax) {
*info = -14;
} else if (*ldqe <= 1 || *ldqe < nmax) {
*info = -17;
}
/* 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) {
minwrk = nmax * (nmax + 1);
/* Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, "CGEQRF", " ", &nmax, &nmax, &c_n1, &
c_n1, (ftnlen)6, (ftnlen)1), i__1 = max(i__1,i__2), i__2 =
ilaenv_(&c__1, "CUNMQR", "LC", &nmax, &nmax, &nmax, &c_n1, (
ftnlen)6, (ftnlen)2), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
c__1, "CUNGQR", " ", &nmax, &nmax, &nmax, &c_n1, (ftnlen)6, (
ftnlen)1);
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = nmax << 1, i__2 = nmax * (nb + 1), i__1 = max(i__1,i__2), i__2
= nmax * (nmax + 1);
maxwrk = max(i__1,i__2);
work[1].r = (real) maxwrk, work[1].i = 0.f;
}
if (*lwork < minwrk) {
*info = -23;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CDRGEV", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
ulp = slamch_("Precision");
safmin = slamch_("Safe minimum");
safmin /= ulp;
safmax = 1.f / safmin;
slabad_(&safmin, &safmax);
ulpinv = 1.f / ulp;
/* The values RMAGN(2:3) depend on N, see below. */
rmagn[0] = 0.f;
rmagn[1] = 1.f;
/* Loop over sizes, types */
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 / (real) n1;
rmagn[3] = safmin * ulpinv * n1;
if (*nsizes != 1) {
mtypes = min(26,*ntypes);
} else {
mtypes = min(27,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L210;
}
++nmats;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Generate test matrices A and B
Description of control parameters:
KCLASS: =1 means w/o rotation, =2 means w/ rotation,
=3 means random.
KATYPE: the "type" to be passed to CLATM4 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.
LASIGN: .TRUE. if the diagonal elements of A are to be
multiplied by a random magnitude 1 number.
KBTYPE, KBZERO, KBMAGN, LBSIGN: 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 L100;
}
ierr = 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) {
claset_("Full", &n, &n, &c_b1, &c_b1, &a[a_offset],
lda);
}
} else {
in = n;
}
clatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
&kz2[kazero[jtype - 1] - 1], &lasign[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) {
i__3 = a_subscr(iadd, iadd);
i__4 = kamagn[jtype - 1];
a[i__3].r = rmagn[i__4], a[i__3].i = 0.f;
}
/* Generate B (w/o rotation) */
if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
claset_("Full", &n, &n, &c_b1, &c_b1, &b[b_offset],
lda);
}
} else {
in = n;
}
clatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
&kz2[kbzero[jtype - 1] - 1], &lbsign[jtype - 1], &
rmagn[kbmagn[jtype - 1]], &c_b28, &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) {
i__3 = b_subscr(iadd, iadd);
i__4 = kbmagn[jtype - 1];
b[i__3].r = rmagn[i__4], b[i__3].i = 0.f;
}
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) {
i__5 = q_subscr(jr, jc);
clarnd_(&q__1, &c__3, &iseed[1]);
q[i__5].r = q__1.r, q[i__5].i = q__1.i;
i__5 = z___subscr(jr, jc);
clarnd_(&q__1, &c__3, &iseed[1]);
z__[i__5].r = q__1.r, z__[i__5].i = q__1.i;
/* L30: */
}
i__4 = n + 1 - jc;
clarfg_(&i__4, &q_ref(jc, jc), &q_ref(jc + 1, jc), &
c__1, &work[jc]);
i__4 = (n << 1) + jc;
i__5 = q_subscr(jc, jc);
r__2 = q[i__5].r;
r__1 = r_sign(&c_b28, &r__2);
work[i__4].r = r__1, work[i__4].i = 0.f;
i__4 = q_subscr(jc, jc);
q[i__4].r = 1.f, q[i__4].i = 0.f;
i__4 = n + 1 - jc;
clarfg_(&i__4, &z___ref(jc, jc), &z___ref(jc + 1, jc),
&c__1, &work[n + jc]);
i__4 = n * 3 + jc;
i__5 = z___subscr(jc, jc);
r__2 = z__[i__5].r;
r__1 = r_sign(&c_b28, &r__2);
work[i__4].r = r__1, work[i__4].i = 0.f;
i__4 = z___subscr(jc, jc);
z__[i__4].r = 1.f, z__[i__4].i = 0.f;
/* L40: */
}
clarnd_(&q__1, &c__3, &iseed[1]);
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__3 = q_subscr(n, n);
q[i__3].r = 1.f, q[i__3].i = 0.f;
i__3 = n;
work[i__3].r = 0.f, work[i__3].i = 0.f;
i__3 = n * 3;
r__1 = c_abs(&ctemp);
q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
clarnd_(&q__1, &c__3, &iseed[1]);
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__3 = z___subscr(n, n);
z__[i__3].r = 1.f, z__[i__3].i = 0.f;
i__3 = n << 1;
work[i__3].r = 0.f, work[i__3].i = 0.f;
i__3 = n << 2;
r__1 = c_abs(&ctemp);
q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* Apply the diagonal matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = a_subscr(jr, jc);
i__6 = (n << 1) + jr;
r_cnjg(&q__3, &work[n * 3 + jc]);
q__2.r = work[i__6].r * q__3.r - work[i__6].i *
q__3.i, q__2.i = work[i__6].r * q__3.i +
work[i__6].i * q__3.r;
i__7 = a_subscr(jr, jc);
q__1.r = q__2.r * a[i__7].r - q__2.i * a[i__7].i,
q__1.i = q__2.r * a[i__7].i + q__2.i * a[
i__7].r;
a[i__5].r = q__1.r, a[i__5].i = q__1.i;
i__5 = b_subscr(jr, jc);
i__6 = (n << 1) + jr;
r_cnjg(&q__3, &work[n * 3 + jc]);
q__2.r = work[i__6].r * q__3.r - work[i__6].i *
q__3.i, q__2.i = work[i__6].r * q__3.i +
work[i__6].i * q__3.r;
i__7 = b_subscr(jr, jc);
q__1.r = q__2.r * b[i__7].r - q__2.i * b[i__7].i,
q__1.i = q__2.r * b[i__7].i + q__2.i * b[
i__7].r;
b[i__5].r = q__1.r, b[i__5].i = q__1.i;
/* L50: */
}
/* L60: */
}
i__3 = n - 1;
cunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &a[a_offset], lda, &work[(n << 1) + 1], &ierr);
if (ierr != 0) {
goto L90;
}
i__3 = n - 1;
cunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &a[a_offset], lda, &work[(n << 1) +
1], &ierr);
if (ierr != 0) {
goto L90;
}
i__3 = n - 1;
cunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &b[b_offset], lda, &work[(n << 1) + 1], &ierr);
if (ierr != 0) {
goto L90;
}
i__3 = n - 1;
cunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &b[b_offset], lda, &work[(n << 1) +
1], &ierr);
if (ierr != 0) {
goto L90;
}
}
} else {
/* Random matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = a_subscr(jr, jc);
i__6 = kamagn[jtype - 1];
clarnd_(&q__2, &c__4, &iseed[1]);
q__1.r = rmagn[i__6] * q__2.r, q__1.i = rmagn[i__6] *
q__2.i;
a[i__5].r = q__1.r, a[i__5].i = q__1.i;
i__5 = b_subscr(jr, jc);
i__6 = kbmagn[jtype - 1];
clarnd_(&q__2, &c__4, &iseed[1]);
q__1.r = rmagn[i__6] * q__2.r, q__1.i = rmagn[i__6] *
q__2.i;
b[i__5].r = q__1.r, b[i__5].i = q__1.i;
/* L70: */
}
/* L80: */
}
}
L90:
if (ierr != 0) {
io___40.ciunit = *nounit;
s_wsfe(&io___40);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&ierr, (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);
return 0;
}
L100:
for (i__ = 1; i__ <= 7; ++i__) {
result[i__] = -1.f;
/* L110: */
}
/* Call CGGEV to compute eigenvalues and eigenvectors. */
clacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
clacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
cggev_("V", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &alpha[
1], &beta[1], &q[q_offset], ldq, &z__[z_offset], ldq, &
work[1], lwork, &rwork[1], &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___42.ciunit = *nounit;
s_wsfe(&io___42);
do_fio(&c__1, "CGGEV1", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (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);
goto L190;
}
/* Do the tests (1) and (2) */
cget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &q[
q_offset], ldq, &alpha[1], &beta[1], &work[1], &rwork[1],
&result[1]);
if (result[2] > *thresh) {
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "CGGEV1", (ftnlen)6);
do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(real));
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();
}
/* Do the tests (3) and (4) */
cget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &z__[
z_offset], ldq, &alpha[1], &beta[1], &work[1], &rwork[1],
&result[3]);
if (result[4] > *thresh) {
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "CGGEV1", (ftnlen)6);
do_fio(&c__1, (char *)&result[4], (ftnlen)sizeof(real));
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();
}
/* Do test (5) */
clacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
clacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
cggev_("N", "N", &n, &s[s_offset], lda, &t[t_offset], lda, &
alpha1[1], &beta1[1], &q[q_offset], ldq, &z__[z_offset],
ldq, &work[1], lwork, &rwork[1], &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___45.ciunit = *nounit;
s_wsfe(&io___45);
do_fio(&c__1, "CGGEV2", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (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);
goto L190;
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
i__6 = j;
i__7 = j;
if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i !=
alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r ||
beta[i__6].i != beta1[i__7].i)) {
result[5] = ulpinv;
}
/* L120: */
}
/* Do test (6): Compute eigenvalues and left eigenvectors,
and test them */
clacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
clacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
cggev_("V", "N", &n, &s[s_offset], lda, &t[t_offset], lda, &
alpha1[1], &beta1[1], &qe[qe_offset], ldqe, &z__[z_offset]
, ldq, &work[1], lwork, &rwork[1], &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___46.ciunit = *nounit;
s_wsfe(&io___46);
do_fio(&c__1, "CGGEV3", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (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);
goto L190;
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
i__6 = j;
i__7 = j;
if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i !=
alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r ||
beta[i__6].i != beta1[i__7].i)) {
result[6] = ulpinv;
}
/* L130: */
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = n;
for (jc = 1; jc <= i__4; ++jc) {
i__5 = q_subscr(j, jc);
i__6 = qe_subscr(j, jc);
if (q[i__5].r != qe[i__6].r || q[i__5].i != qe[i__6].i) {
result[6] = ulpinv;
}
/* L140: */
}
/* L150: */
}
/* Do test (7): Compute eigenvalues and right eigenvectors,
and test them */
clacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
clacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
cggev_("N", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
alpha1[1], &beta1[1], &q[q_offset], ldq, &qe[qe_offset],
ldqe, &work[1], lwork, &rwork[1], &ierr);
if (ierr != 0 && ierr != n + 1) {
result[1] = ulpinv;
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, "CGGEV4", (ftnlen)6);
do_fio(&c__1, (char *)&ierr, (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);
goto L190;
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = j;
i__5 = j;
i__6 = j;
i__7 = j;
if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i !=
alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r ||
beta[i__6].i != beta1[i__7].i)) {
result[7] = ulpinv;
}
/* L160: */
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = n;
for (jc = 1; jc <= i__4; ++jc) {
i__5 = z___subscr(j, jc);
i__6 = qe_subscr(j, jc);
if (z__[i__5].r != qe[i__6].r || z__[i__5].i != qe[i__6]
.i) {
result[7] = ulpinv;
}
/* L170: */
}
/* L180: */
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L190:
ntestt += 7;
/* Print out tests which fail. */
for (jr = 1; jr <= 9; ++jr) {
if (result[jr] >= *thresh) {
/* If this is the first test to fail,
print a header to the data file. */
if (nerrs == 0) {
io___48.ciunit = *nounit;
s_wsfe(&io___48);
do_fio(&c__1, "CGV", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___49.ciunit = *nounit;
s_wsfe(&io___49);
e_wsfe();
io___50.ciunit = *nounit;
s_wsfe(&io___50);
e_wsfe();
io___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, "Orthogonal", (ftnlen)10);
e_wsfe();
/* Tests performed */
io___52.ciunit = *nounit;
s_wsfe(&io___52);
e_wsfe();
}
++nerrs;
if (result[jr] < 1e4f) {
io___53.ciunit = *nounit;
s_wsfe(&io___53);
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(
real));
e_wsfe();
} else {
io___54.ciunit = *nounit;
s_wsfe(&io___54);
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(
real));
e_wsfe();
}
}
/* L200: */
}
L210:
;
}
/* L220: */
}
/* Summary */
alasvm_("CGV", nounit, &nerrs, &ntestt, &c__0);
work[1].r = (real) maxwrk, work[1].i = 0.f;
return 0;
/* End of CDRGEV */
} /* cdrgev_ */
/* Subroutine */ int cla_gbamv__(integer *trans, integer *m, integer *n,
integer *kl, integer *ku, real *alpha, complex *ab, integer *ldab,
complex *x, integer *incx, real *beta, real *y, integer *incy)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
real r__1, r__2;
/* Builtin functions */
double r_imag(complex *), r_sign(real *, real *);
/* Local variables */
extern integer ilatrans_(char *);
integer i__, j;
logical symb_zero__;
integer kd, iy, jx, kx, ky, info;
real temp;
integer lenx, leny;
real safe1;
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLA_GEAMV performs one of the matrix-vector operations */
/* y := alpha*abs(A)*abs(x) + beta*abs(y), */
/* or y := alpha*abs(A)'*abs(x) + beta*abs(y), */
/* where alpha and beta are scalars, x and y are vectors and A is an */
/* m by n matrix. */
/* This function is primarily used in calculating error bounds. */
/* To protect against underflow during evaluation, components in */
/* the resulting vector are perturbed away from zero by (N+1) */
/* times the underflow threshold. To prevent unnecessarily large */
/* errors for block-structure embedded in general matrices, */
/* "symbolically" zero components are not perturbed. A zero */
/* entry is considered "symbolic" if all multiplications involved */
/* in computing that entry have at least one zero multiplicand. */
/* Parameters */
/* ========== */
/* TRANS - INTEGER */
/* On entry, TRANS specifies the operation to be performed as */
/* follows: */
/* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) */
/* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) */
/* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) */
/* Unchanged on exit. */
/* M - INTEGER */
/* On entry, M specifies the number of rows of the matrix A. */
/* M must be at least zero. */
/* Unchanged on exit. */
/* N - INTEGER */
/* On entry, N specifies the number of columns of the matrix A. */
/* N must be at least zero. */
/* Unchanged on exit. */
/* KL - INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU - INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* ALPHA - REAL */
/* On entry, ALPHA specifies the scalar alpha. */
/* Unchanged on exit. */
/* A - REAL array of DIMENSION ( LDA, n ) */
/* Before entry, the leading m by n part of the array A must */
/* contain the matrix of coefficients. */
/* Unchanged on exit. */
/* LDA - INTEGER */
/* On entry, LDA specifies the first dimension of A as declared */
/* in the calling (sub) program. LDA must be at least */
/* max( 1, m ). */
/* Unchanged on exit. */
/* X - REAL array of DIMENSION at least */
/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
/* and at least */
/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
/* Before entry, the incremented array X must contain the */
/* vector x. */
/* Unchanged on exit. */
/* INCX - INTEGER */
/* On entry, INCX specifies the increment for the elements of */
/* X. INCX must not be zero. */
/* Unchanged on exit. */
/* BETA - REAL */
/* On entry, BETA specifies the scalar beta. When BETA is */
/* supplied as zero then Y need not be set on input. */
/* Unchanged on exit. */
/* Y - REAL array of DIMENSION at least */
/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
/* and at least */
/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
/* Before entry with BETA non-zero, the incremented array Y */
/* must contain the vector y. On exit, Y is overwritten by the */
/* updated vector y. */
/* INCY - INTEGER */
/* On entry, INCY specifies the increment for the elements of */
/* Y. INCY must not be zero. */
/* Unchanged on exit. */
/* Level 2 Blas routine. */
/* .. */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions */
/* .. */
/* .. Statement Function Definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--x;
--y;
/* Function Body */
info = 0;
if (! (*trans == ilatrans_("N") || *trans == ilatrans_("T") || *trans == ilatrans_("C"))) {
info = 1;
} else if (*m < 0) {
info = 2;
} else if (*n < 0) {
info = 3;
} else if (*kl < 0) {
info = 4;
} else if (*ku < 0) {
info = 5;
} else if (*ldab < *kl + *ku + 1) {
info = 6;
} else if (*incx == 0) {
info = 8;
} else if (*incy == 0) {
info = 11;
}
if (info != 0) {
xerbla_("CLA_GBAMV ", &info);
return 0;
}
/* Quick return if possible. */
if (*m == 0 || *n == 0 || *alpha == 0.f && *beta == 1.f) {
return 0;
}
/* Set LENX and LENY, the lengths of the vectors x and y, and set */
/* up the start points in X and Y. */
if (*trans == ilatrans_("N")) {
lenx = *n;
leny = *m;
} else {
lenx = *m;
leny = *n;
}
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (lenx - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (leny - 1) * *incy;
}
/* Set SAFE1 essentially to be the underflow threshold times the */
/* number of additions in each row. */
safe1 = slamch_("Safe minimum");
safe1 = (*n + 1) * safe1;
/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */
/* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to */
/* the inexact flag. Still doesn't help change the iteration order */
/* to per-column. */
kd = *ku + 1;
iy = ky;
if (*incx == 1) {
i__1 = leny;
for (i__ = 1; i__ <= i__1; ++i__) {
if (*beta == 0.f) {
symb_zero__ = TRUE_;
y[iy] = 0.f;
} else if (y[iy] == 0.f) {
symb_zero__ = TRUE_;
} else {
symb_zero__ = FALSE_;
y[iy] = *beta * (r__1 = y[iy], dabs(r__1));
}
if (*alpha != 0.f) {
/* Computing MAX */
i__2 = i__ - *ku;
/* Computing MIN */
i__4 = i__ + *kl;
i__3 = min(i__4,lenx);
for (j = max(i__2,1); j <= i__3; ++j) {
if (*trans == ilatrans_("N")) {
i__2 = kd + i__ - j + j * ab_dim1;
temp = (r__1 = ab[i__2].r, dabs(r__1)) + (r__2 =
r_imag(&ab[kd + i__ - j + j * ab_dim1]), dabs(
r__2));
} else {
i__2 = j + (kd + i__ - j) * ab_dim1;
temp = (r__1 = ab[i__2].r, dabs(r__1)) + (r__2 =
r_imag(&ab[j + (kd + i__ - j) * ab_dim1]),
dabs(r__2));
}
i__2 = j;
symb_zero__ = symb_zero__ && (x[i__2].r == 0.f && x[i__2]
.i == 0.f || temp == 0.f);
i__2 = j;
y[iy] += *alpha * ((r__1 = x[i__2].r, dabs(r__1)) + (r__2
= r_imag(&x[j]), dabs(r__2))) * temp;
}
}
if (! symb_zero__) {
y[iy] += r_sign(&safe1, &y[iy]);
}
iy += *incy;
}
} else {
i__1 = leny;
for (i__ = 1; i__ <= i__1; ++i__) {
if (*beta == 0.f) {
symb_zero__ = TRUE_;
y[iy] = 0.f;
} else if (y[iy] == 0.f) {
symb_zero__ = TRUE_;
} else {
symb_zero__ = FALSE_;
y[iy] = *beta * (r__1 = y[iy], dabs(r__1));
}
if (*alpha != 0.f) {
jx = kx;
/* Computing MAX */
i__3 = i__ - *ku;
/* Computing MIN */
i__4 = i__ + *kl;
i__2 = min(i__4,lenx);
for (j = max(i__3,1); j <= i__2; ++j) {
if (*trans == ilatrans_("N")) {
i__3 = kd + i__ - j + j * ab_dim1;
temp = (r__1 = ab[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&ab[kd + i__ - j + j * ab_dim1]), dabs(
r__2));
} else {
i__3 = j + (kd + i__ - j) * ab_dim1;
temp = (r__1 = ab[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&ab[j + (kd + i__ - j) * ab_dim1]),
dabs(r__2));
}
i__3 = jx;
symb_zero__ = symb_zero__ && (x[i__3].r == 0.f && x[i__3]
.i == 0.f || temp == 0.f);
i__3 = jx;
y[iy] += *alpha * ((r__1 = x[i__3].r, dabs(r__1)) + (r__2
= r_imag(&x[jx]), dabs(r__2))) * temp;
jx += *incx;
}
}
if (! symb_zero__) {
y[iy] += r_sign(&safe1, &y[iy]);
}
iy += *incy;
}
}
return 0;
/* End of CLA_GBAMV */
} /* cla_gbamv__ */
/* Subroutine */ int slag2_(real *a, integer *lda, real *b, integer *ldb,
real *safmin, real *scale1, real *scale2, real *wr1, real *wr2, real *
wi)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
SLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue
problem A - w B, with scaling as necessary to avoid over-/underflow.
The scaling factor "s" results in a modified eigenvalue equation
s A - w B
where s is a non-negative scaling factor chosen so that w, w B,
and s A do not overflow and, if possible, do not underflow, either.
Arguments
=========
A (input) REAL array, dimension (LDA, 2)
On entry, the 2 x 2 matrix A. It is assumed that its 1-norm
is less than 1/SAFMIN. Entries less than
sqrt(SAFMIN)*norm(A) are subject to being treated as zero.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= 2.
B (input) REAL array, dimension (LDB, 2)
On entry, the 2 x 2 upper triangular matrix B. It is
assumed that the one-norm of B is less than 1/SAFMIN. The
diagonals should be at least sqrt(SAFMIN) times the largest
element of B (in absolute value); if a diagonal is smaller
than that, then +/- sqrt(SAFMIN) will be used instead of
that diagonal.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= 2.
SAFMIN (input) REAL
The smallest positive number s.t. 1/SAFMIN does not
overflow. (This should always be SLAMCH('S') -- it is an
argument in order to avoid having to call SLAMCH frequently.)
SCALE1 (output) REAL
A scaling factor used to avoid over-/underflow in the
eigenvalue equation which defines the first eigenvalue. If
the eigenvalues are complex, then the eigenvalues are
( WR1 +/- WI i ) / SCALE1 (which may lie outside the
exponent range of the machine), SCALE1=SCALE2, and SCALE1
will always be positive. If the eigenvalues are real, then
the first (real) eigenvalue is WR1 / SCALE1 , but this may
overflow or underflow, and in fact, SCALE1 may be zero or
less than the underflow threshhold if the exact eigenvalue
is sufficiently large.
SCALE2 (output) REAL
A scaling factor used to avoid over-/underflow in the
eigenvalue equation which defines the second eigenvalue. If
the eigenvalues are complex, then SCALE2=SCALE1. If the
eigenvalues are real, then the second (real) eigenvalue is
WR2 / SCALE2 , but this may overflow or underflow, and in
fact, SCALE2 may be zero or less than the underflow
threshhold if the exact eigenvalue is sufficiently large.
WR1 (output) REAL
If the eigenvalue is real, then WR1 is SCALE1 times the
eigenvalue closest to the (2,2) element of A B**(-1). If the
eigenvalue is complex, then WR1=WR2 is SCALE1 times the real
part of the eigenvalues.
WR2 (output) REAL
If the eigenvalue is real, then WR2 is SCALE2 times the
other eigenvalue. If the eigenvalue is complex, then
WR1=WR2 is SCALE1 times the real part of the eigenvalues.
WI (output) REAL
If the eigenvalue is real, then WI is zero. If the
eigenvalue is complex, then WI is SCALE1 times the imaginary
part of the eigenvalues. WI will always be non-negative.
=====================================================================
Parameter adjustments */
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset;
real r__1, r__2, r__3, r__4, r__5, r__6;
/* Builtin functions */
double sqrt(doublereal), r_sign(real *, real *);
/* Local variables */
static real diff, bmin, wbig, wabs, wdet, r__, binv11, binv22, discr,
anorm, bnorm, bsize, shift, c1, c2, c3, c4, c5, rtmin, rtmax,
wsize, s1, s2, a11, a12, a21, a22, b11, b12, b22, ascale, bscale,
pp, qq, ss, wscale, safmax, wsmall, as11, as12, as22, sum, abi22;
#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;
/* Function Body */
rtmin = sqrt(*safmin);
rtmax = 1.f / rtmin;
safmax = 1.f / *safmin;
/* Scale A
Computing MAX */
r__5 = (r__1 = a_ref(1, 1), dabs(r__1)) + (r__2 = a_ref(2, 1), dabs(r__2))
, r__6 = (r__3 = a_ref(1, 2), dabs(r__3)) + (r__4 = a_ref(2, 2),
dabs(r__4)), r__5 = max(r__5,r__6);
anorm = dmax(r__5,*safmin);
ascale = 1.f / anorm;
a11 = ascale * a_ref(1, 1);
a21 = ascale * a_ref(2, 1);
a12 = ascale * a_ref(1, 2);
a22 = ascale * a_ref(2, 2);
/* Perturb B if necessary to insure non-singularity */
b11 = b_ref(1, 1);
b12 = b_ref(1, 2);
b22 = b_ref(2, 2);
/* Computing MAX */
r__1 = dabs(b11), r__2 = dabs(b12), r__1 = max(r__1,r__2), r__2 = dabs(
b22), r__1 = max(r__1,r__2);
bmin = rtmin * dmax(r__1,rtmin);
if (dabs(b11) < bmin) {
b11 = r_sign(&bmin, &b11);
}
if (dabs(b22) < bmin) {
b22 = r_sign(&bmin, &b22);
}
/* Scale B
Computing MAX */
r__1 = dabs(b11), r__2 = dabs(b12) + dabs(b22), r__1 = max(r__1,r__2);
bnorm = dmax(r__1,*safmin);
/* Computing MAX */
r__1 = dabs(b11), r__2 = dabs(b22);
bsize = dmax(r__1,r__2);
bscale = 1.f / bsize;
b11 *= bscale;
b12 *= bscale;
b22 *= bscale;
/* Compute larger eigenvalue by method described by C. van Loan
( AS is A shifted by -SHIFT*B ) */
binv11 = 1.f / b11;
binv22 = 1.f / b22;
s1 = a11 * binv11;
s2 = a22 * binv22;
if (dabs(s1) <= dabs(s2)) {
as12 = a12 - s1 * b12;
as22 = a22 - s1 * b22;
ss = a21 * (binv11 * binv22);
abi22 = as22 * binv22 - ss * b12;
pp = abi22 * .5f;
shift = s1;
} else {
as12 = a12 - s2 * b12;
as11 = a11 - s2 * b11;
ss = a21 * (binv11 * binv22);
abi22 = -ss * b12;
pp = (as11 * binv11 + abi22) * .5f;
shift = s2;
}
qq = ss * as12;
if ((r__1 = pp * rtmin, dabs(r__1)) >= 1.f) {
/* Computing 2nd power */
r__1 = rtmin * pp;
discr = r__1 * r__1 + qq * *safmin;
r__ = sqrt((dabs(discr))) * rtmax;
} else {
/* Computing 2nd power */
r__1 = pp;
if (r__1 * r__1 + dabs(qq) <= *safmin) {
/* Computing 2nd power */
r__1 = rtmax * pp;
discr = r__1 * r__1 + qq * safmax;
r__ = sqrt((dabs(discr))) * rtmin;
} else {
/* Computing 2nd power */
r__1 = pp;
discr = r__1 * r__1 + qq;
r__ = sqrt((dabs(discr)));
}
}
/* Note: the test of R in the following IF is to cover the case when
DISCR is small and negative and is flushed to zero during
the calculation of R. On machines which have a consistent
flush-to-zero threshhold and handle numbers above that
threshhold correctly, it would not be necessary. */
if (discr >= 0.f || r__ == 0.f) {
sum = pp + r_sign(&r__, &pp);
diff = pp - r_sign(&r__, &pp);
wbig = shift + sum;
/* Compute smaller eigenvalue */
wsmall = shift + diff;
/* Computing MAX */
r__1 = dabs(wsmall);
if (dabs(wbig) * .5f > dmax(r__1,*safmin)) {
wdet = (a11 * a22 - a12 * a21) * (binv11 * binv22);
wsmall = wdet / wbig;
}
/* Choose (real) eigenvalue closest to 2,2 element of A*B**(-1)
for WR1. */
if (pp > abi22) {
*wr1 = dmin(wbig,wsmall);
*wr2 = dmax(wbig,wsmall);
} else {
*wr1 = dmax(wbig,wsmall);
*wr2 = dmin(wbig,wsmall);
}
*wi = 0.f;
} else {
/* Complex eigenvalues */
*wr1 = shift + pp;
*wr2 = *wr1;
*wi = r__;
}
/* Further scaling to avoid underflow and overflow in computing
SCALE1 and overflow in computing w*B.
This scale factor (WSCALE) is bounded from above using C1 and C2,
and from below using C3 and C4.
C1 implements the condition s A must never overflow.
C2 implements the condition w B must never overflow.
C3, with C2,
implement the condition that s A - w B must never overflow.
C4 implements the condition s should not underflow.
C5 implements the condition max(s,|w|) should be at least 2. */
c1 = bsize * (*safmin * dmax(1.f,ascale));
c2 = *safmin * dmax(1.f,bnorm);
c3 = bsize * *safmin;
if (ascale <= 1.f && bsize <= 1.f) {
/* Computing MIN */
r__1 = 1.f, r__2 = ascale / *safmin * bsize;
c4 = dmin(r__1,r__2);
} else {
c4 = 1.f;
}
if (ascale <= 1.f || bsize <= 1.f) {
/* Computing MIN */
r__1 = 1.f, r__2 = ascale * bsize;
c5 = dmin(r__1,r__2);
} else {
c5 = 1.f;
}
/* Scale first eigenvalue */
wabs = dabs(*wr1) + dabs(*wi);
/* Computing MAX
Computing MIN */
r__3 = c4, r__4 = dmax(wabs,c5) * .5f;
r__1 = max(*safmin,c1), r__2 = (wabs * c2 + c3) * 1.0000100000000001f,
r__1 = max(r__1,r__2), r__2 = dmin(r__3,r__4);
wsize = dmax(r__1,r__2);
if (wsize != 1.f) {
wscale = 1.f / wsize;
if (wsize > 1.f) {
*scale1 = dmax(ascale,bsize) * wscale * dmin(ascale,bsize);
} else {
*scale1 = dmin(ascale,bsize) * wscale * dmax(ascale,bsize);
}
*wr1 *= wscale;
if (*wi != 0.f) {
*wi *= wscale;
*wr2 = *wr1;
*scale2 = *scale1;
}
} else {
*scale1 = ascale * bsize;
*scale2 = *scale1;
}
/* Scale second eigenvalue (if real) */
if (*wi == 0.f) {
/* Computing MAX
Computing MIN
Computing MAX */
r__5 = dabs(*wr2);
r__3 = c4, r__4 = dmax(r__5,c5) * .5f;
r__1 = max(*safmin,c1), r__2 = (dabs(*wr2) * c2 + c3) *
1.0000100000000001f, r__1 = max(r__1,r__2), r__2 = dmin(r__3,
r__4);
wsize = dmax(r__1,r__2);
if (wsize != 1.f) {
wscale = 1.f / wsize;
if (wsize > 1.f) {
*scale2 = dmax(ascale,bsize) * wscale * dmin(ascale,bsize);
} else {
*scale2 = dmin(ascale,bsize) * wscale * dmax(ascale,bsize);
}
*wr2 *= wscale;
} else {
*scale2 = ascale * bsize;
}
}
/* End of SLAG2 */
return 0;
} /* slag2_ */
/* Subroutine */ int slanv2_(real *a, real *b, real *c__, real *d__, real *
rt1r, real *rt1i, real *rt2r, real *rt2i, real *cs, real *sn)
{
/* -- LAPACK driver routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric
matrix in standard form:
[ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ]
[ C D ] [ SN CS ] [ CC DD ] [-SN CS ]
where either
1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or
2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex
conjugate eigenvalues.
Arguments
=========
A (input/output) REAL
B (input/output) REAL
C (input/output) REAL
D (input/output) REAL
On entry, the elements of the input matrix.
On exit, they are overwritten by the elements of the
standardised Schur form.
RT1R (output) REAL
RT1I (output) REAL
RT2R (output) REAL
RT2I (output) REAL
The real and imaginary parts of the eigenvalues. If the
eigenvalues are a complex conjugate pair, RT1I > 0.
CS (output) REAL
SN (output) REAL
Parameters of the rotation matrix.
Further Details
===============
Modified by V. Sima, Research Institute for Informatics, Bucharest,
Romania, to reduce the risk of cancellation errors,
when computing real eigenvalues, and to ensure, if possible, that
abs(RT1R) >= abs(RT2R).
===================================================================== */
/* Table of constant values */
static real c_b4 = 1.f;
/* System generated locals */
real r__1, r__2;
/* Builtin functions */
double r_sign(real *, real *), sqrt(doublereal);
/* Local variables */
static real temp, p, scale, bcmax, z__, bcmis, sigma, aa, bb, cc, dd;
extern doublereal slapy2_(real *, real *), slamch_(char *);
static real cs1, sn1, sab, sac, eps, tau;
eps = slamch_("P");
if (*c__ == 0.f) {
*cs = 1.f;
*sn = 0.f;
goto L10;
} else if (*b == 0.f) {
/* Swap rows and columns */
*cs = 0.f;
*sn = 1.f;
temp = *d__;
*d__ = *a;
*a = temp;
*b = -(*c__);
*c__ = 0.f;
goto L10;
} else if (*a - *d__ == 0.f && r_sign(&c_b4, b) != r_sign(&c_b4, c__)) {
*cs = 1.f;
*sn = 0.f;
goto L10;
} else {
temp = *a - *d__;
p = temp * .5f;
/* Computing MAX */
r__1 = dabs(*b), r__2 = dabs(*c__);
bcmax = dmax(r__1,r__2);
/* Computing MIN */
r__1 = dabs(*b), r__2 = dabs(*c__);
bcmis = dmin(r__1,r__2) * r_sign(&c_b4, b) * r_sign(&c_b4, c__);
/* Computing MAX */
r__1 = dabs(p);
scale = dmax(r__1,bcmax);
z__ = p / scale * p + bcmax / scale * bcmis;
/* If Z is of the order of the machine accuracy, postpone the
decision on the nature of eigenvalues */
if (z__ >= eps * 4.f) {
/* Real eigenvalues. Compute A and D. */
r__1 = sqrt(scale) * sqrt(z__);
z__ = p + r_sign(&r__1, &p);
*a = *d__ + z__;
*d__ -= bcmax / z__ * bcmis;
/* Compute B and the rotation matrix */
tau = slapy2_(c__, &z__);
*cs = z__ / tau;
*sn = *c__ / tau;
*b -= *c__;
*c__ = 0.f;
} else {
/* Complex eigenvalues, or real (almost) equal eigenvalues.
Make diagonal elements equal. */
sigma = *b + *c__;
tau = slapy2_(&sigma, &temp);
*cs = sqrt((dabs(sigma) / tau + 1.f) * .5f);
*sn = -(p / (tau * *cs)) * r_sign(&c_b4, &sigma);
/* Compute [ AA BB ] = [ A B ] [ CS -SN ]
[ CC DD ] [ C D ] [ SN CS ] */
aa = *a * *cs + *b * *sn;
bb = -(*a) * *sn + *b * *cs;
cc = *c__ * *cs + *d__ * *sn;
dd = -(*c__) * *sn + *d__ * *cs;
/* Compute [ A B ] = [ CS SN ] [ AA BB ]
[ C D ] [-SN CS ] [ CC DD ] */
*a = aa * *cs + cc * *sn;
*b = bb * *cs + dd * *sn;
*c__ = -aa * *sn + cc * *cs;
*d__ = -bb * *sn + dd * *cs;
temp = (*a + *d__) * .5f;
*a = temp;
*d__ = temp;
if (*c__ != 0.f) {
if (*b != 0.f) {
if (r_sign(&c_b4, b) == r_sign(&c_b4, c__)) {
/* Real eigenvalues: reduce to upper triangular form */
sab = sqrt((dabs(*b)));
sac = sqrt((dabs(*c__)));
r__1 = sab * sac;
p = r_sign(&r__1, c__);
tau = 1.f / sqrt((r__1 = *b + *c__, dabs(r__1)));
*a = temp + p;
*d__ = temp - p;
*b -= *c__;
*c__ = 0.f;
cs1 = sab * tau;
sn1 = sac * tau;
temp = *cs * cs1 - *sn * sn1;
*sn = *cs * sn1 + *sn * cs1;
*cs = temp;
}
} else {
*b = -(*c__);
*c__ = 0.f;
temp = *cs;
*cs = -(*sn);
*sn = temp;
}
}
}
}
L10:
/* Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). */
*rt1r = *a;
*rt2r = *d__;
if (*c__ == 0.f) {
*rt1i = 0.f;
*rt2i = 0.f;
} else {
*rt1i = sqrt((dabs(*b))) * sqrt((dabs(*c__)));
*rt2i = -(*rt1i);
}
return 0;
/* End of SLANV2 */
} /* slanv2_ */
/* Subroutine */
int clarfgp_(integer *n, complex *alpha, complex *x, integer *incx, complex *tau)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *), r_sign(real *, real *), c_abs(complex *);
/* Local variables */
integer j;
complex savealpha;
integer knt;
real beta;
extern /* Subroutine */
int cscal_(integer *, complex *, complex *, integer *);
real alphi, alphr, xnorm;
extern real scnrm2_(integer *, complex *, integer *), slapy2_(real *, real *), slapy3_(real *, real *, real *);
extern /* Complex */
VOID cladiv_(complex *, complex *, complex *);
extern real slamch_(char *);
extern /* Subroutine */
int csscal_(integer *, real *, complex *, integer *);
real bignum, smlnum;
/* -- 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 .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n <= 0)
{
tau->r = 0.f, tau->i = 0.f;
return 0;
}
i__1 = *n - 1;
xnorm = scnrm2_(&i__1, &x[1], incx);
alphr = alpha->r;
alphi = r_imag(alpha);
if (xnorm == 0.f)
{
/* H = [1-alpha/f2c_abs(alpha) 0;
0 I], sign chosen so ALPHA >= 0. */
if (alphi == 0.f)
{
if (alphr >= 0.f)
{
/* When TAU.eq.ZERO, the vector is special-cased to be */
/* all zeros in the application routines. We do not need */
/* to clear it. */
tau->r = 0.f, tau->i = 0.f;
}
else
{
/* However, the application routines rely on explicit */
/* zero checks when TAU.ne.ZERO, and we must clear X. */
tau->r = 2.f, tau->i = 0.f;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
q__1.r = -alpha->r;
q__1.i = -alpha->i; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
}
}
else
{
/* Only "reflecting" the diagonal entry to be real and non-negative. */
xnorm = slapy2_(&alphr, &alphi);
r__1 = 1.f - alphr / xnorm;
r__2 = -alphi / xnorm;
q__1.r = r__1;
q__1.i = r__2; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
alpha->r = xnorm, alpha->i = 0.f;
}
}
else
{
/* general case */
r__1 = slapy3_(&alphr, &alphi, &xnorm);
beta = r_sign(&r__1, &alphr);
smlnum = slamch_("S") / slamch_("E");
bignum = 1.f / smlnum;
knt = 0;
if (f2c_abs(beta) < smlnum)
{
/* XNORM, BETA may be inaccurate;
scale X and recompute them */
L10:
++knt;
i__1 = *n - 1;
csscal_(&i__1, &bignum, &x[1], incx);
beta *= bignum;
alphi *= bignum;
alphr *= bignum;
if (f2c_abs(beta) < smlnum)
{
goto L10;
}
/* New BETA is at most 1, at least SMLNUM */
i__1 = *n - 1;
xnorm = scnrm2_(&i__1, &x[1], incx);
q__1.r = alphr;
q__1.i = alphi; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
r__1 = slapy3_(&alphr, &alphi, &xnorm);
beta = r_sign(&r__1, &alphr);
}
savealpha.r = alpha->r;
savealpha.i = alpha->i; // , expr subst
q__1.r = alpha->r + beta;
q__1.i = alpha->i; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
if (beta < 0.f)
{
beta = -beta;
q__2.r = -alpha->r;
q__2.i = -alpha->i; // , expr subst
q__1.r = q__2.r / beta;
q__1.i = q__2.i / beta; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
}
else
{
alphr = alphi * (alphi / alpha->r);
alphr += xnorm * (xnorm / alpha->r);
r__1 = alphr / beta;
r__2 = -alphi / beta;
q__1.r = r__1;
q__1.i = r__2; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
r__1 = -alphr;
q__1.r = r__1;
q__1.i = alphi; // , expr subst
alpha->r = q__1.r, alpha->i = q__1.i;
}
cladiv_(&q__1, &c_b5, alpha);
alpha->r = q__1.r, alpha->i = q__1.i;
if (c_abs(tau) <= smlnum)
{
/* In the case where the computed TAU ends up being a denormalized number, */
/* it loses relative accuracy. This is a BIG problem. Solution: flush TAU */
/* to ZERO (or TWO or whatever makes a nonnegative real number for BETA). */
/* (Bug report provided by Pat Quillen from MathWorks on Jul 29, 2009.) */
/* (Thanks Pat. Thanks MathWorks.) */
alphr = savealpha.r;
alphi = r_imag(&savealpha);
if (alphi == 0.f)
{
if (alphr >= 0.f)
{
tau->r = 0.f, tau->i = 0.f;
}
else
{
tau->r = 2.f, tau->i = 0.f;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
q__1.r = -savealpha.r;
q__1.i = -savealpha.i; // , expr subst
beta = q__1.r;
}
}
else
{
xnorm = slapy2_(&alphr, &alphi);
r__1 = 1.f - alphr / xnorm;
r__2 = -alphi / xnorm;
q__1.r = r__1;
q__1.i = r__2; // , expr subst
tau->r = q__1.r, tau->i = q__1.i;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = (j - 1) * *incx + 1;
x[i__2].r = 0.f;
x[i__2].i = 0.f; // , expr subst
}
beta = xnorm;
}
}
else
{
/* This is the general case. */
i__1 = *n - 1;
cscal_(&i__1, alpha, &x[1], incx);
}
/* If BETA is subnormal, it may lose relative accuracy */
i__1 = knt;
for (j = 1;
j <= i__1;
++j)
{
beta *= smlnum;
/* L20: */
}
alpha->r = beta, alpha->i = 0.f;
}
return 0;
/* End of CLARFGP */
}
/* Subroutine */ int slacn2_(integer *n, real *v, real *x, integer *isgn,
real *est, integer *kase, integer *isave)
{
/* System generated locals */
integer i__1;
real r__1;
/* Builtin functions */
double r_sign(real *, real *);
integer i_nint(real *);
/* Local variables */
integer i__;
real temp;
integer jlast;
extern doublereal sasum_(integer *, real *, integer *);
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
extern integer isamax_(integer *, real *, integer *);
real altsgn, estold;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLACN2 estimates the 1-norm of a square, real matrix A. */
/* Reverse communication is used for evaluating matrix-vector products. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix. N >= 1. */
/* V (workspace) REAL array, dimension (N) */
/* On the final return, V = A*W, where EST = norm(V)/norm(W) */
/* (W is not returned). */
/* X (input/output) REAL array, dimension (N) */
/* On an intermediate return, X should be overwritten by */
/* A * X, if KASE=1, */
/* A' * X, if KASE=2, */
/* and SLACN2 must be re-called with all the other parameters */
/* unchanged. */
/* ISGN (workspace) INTEGER array, dimension (N) */
/* EST (input/output) REAL */
/* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be */
/* unchanged from the previous call to SLACN2. */
/* On exit, EST is an estimate (a lower bound) for norm(A). */
/* KASE (input/output) INTEGER */
/* On the initial call to SLACN2, KASE should be 0. */
/* On an intermediate return, KASE will be 1 or 2, indicating */
/* whether X should be overwritten by A * X or A' * X. */
/* On the final return from SLACN2, KASE will again be 0. */
/* ISAVE (input/output) INTEGER array, dimension (3) */
/* ISAVE is used to save variables between calls to SLACN2 */
/* Further Details */
/* ======= ======= */
/* Contributed by Nick Higham, University of Manchester. */
/* Originally named SONEST, dated March 16, 1988. */
/* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */
/* a real or complex matrix, with applications to condition estimation", */
/* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */
/* This is a thread safe version of SLACON, which uses the array ISAVE */
/* in place of a SAVE statement, as follows: */
/* SLACON SLACN2 */
/* JUMP ISAVE(1) */
/* J ISAVE(2) */
/* ITER ISAVE(3) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--isave;
--isgn;
--x;
--v;
/* Function Body */
if (*kase == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = 1.f / (real) (*n);
/* L10: */
}
*kase = 1;
isave[1] = 1;
return 0;
}
switch (isave[1]) {
case 1: goto L20;
case 2: goto L40;
case 3: goto L70;
case 4: goto L110;
case 5: goto L140;
}
/* ................ ENTRY (ISAVE( 1 ) = 1) */
/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */
L20:
if (*n == 1) {
v[1] = x[1];
*est = dabs(v[1]);
/* ... QUIT */
goto L150;
}
*est = sasum_(n, &x[1], &c__1);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = r_sign(&c_b11, &x[i__]);
isgn[i__] = i_nint(&x[i__]);
/* L30: */
}
*kase = 2;
isave[1] = 2;
return 0;
/* ................ ENTRY (ISAVE( 1 ) = 2) */
/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
L40:
isave[2] = isamax_(n, &x[1], &c__1);
isave[3] = 2;
/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */
L50:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = 0.f;
/* L60: */
}
x[isave[2]] = 1.f;
*kase = 1;
isave[1] = 3;
return 0;
/* ................ ENTRY (ISAVE( 1 ) = 3) */
/* X HAS BEEN OVERWRITTEN BY A*X. */
L70:
scopy_(n, &x[1], &c__1, &v[1], &c__1);
estold = *est;
*est = sasum_(n, &v[1], &c__1);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
r__1 = r_sign(&c_b11, &x[i__]);
if (i_nint(&r__1) != isgn[i__]) {
goto L90;
}
/* L80: */
}
/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
goto L120;
L90:
/* TEST FOR CYCLING. */
if (*est <= estold) {
goto L120;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = r_sign(&c_b11, &x[i__]);
isgn[i__] = i_nint(&x[i__]);
/* L100: */
}
*kase = 2;
isave[1] = 4;
return 0;
/* ................ ENTRY (ISAVE( 1 ) = 4) */
/* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
L110:
jlast = isave[2];
isave[2] = isamax_(n, &x[1], &c__1);
if (x[jlast] != (r__1 = x[isave[2]], dabs(r__1)) && isave[3] < 5) {
++isave[3];
goto L50;
}
/* ITERATION COMPLETE. FINAL STAGE. */
L120:
altsgn = 1.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = altsgn * ((real) (i__ - 1) / (real) (*n - 1) + 1.f);
altsgn = -altsgn;
/* L130: */
}
*kase = 1;
isave[1] = 5;
return 0;
/* ................ ENTRY (ISAVE( 1 ) = 5) */
/* X HAS BEEN OVERWRITTEN BY A*X. */
L140:
temp = sasum_(n, &x[1], &c__1) / (real) (*n * 3) * 2.f;
if (temp > *est) {
scopy_(n, &x[1], &c__1, &v[1], &c__1);
*est = temp;
}
L150:
*kase = 0;
return 0;
/* End of SLACN2 */
} /* slacn2_ */
int cggbal_(char *job, int *n, complex *a, int *lda,
complex *b, int *ldb, int *ilo, int *ihi, float *lscale,
float *rscale, float *work, int *info)
{
/* System generated locals */
int a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
float r__1, r__2, r__3;
/* Builtin functions */
double r_lg10(float *), r_imag(complex *), c_abs(complex *), r_sign(float *,
float *), pow_ri(float *, int *);
/* Local variables */
int i__, j, k, l, m;
float t;
int jc;
float ta, tb, tc;
int ir;
float ew;
int it, nr, ip1, jp1, lm1;
float cab, rab, ewc, cor, sum;
int nrp2, icab, lcab;
float beta, coef;
int irab, lrab;
float basl, cmax;
extern double sdot_(int *, float *, int *, float *, int *);
float coef2, coef5, gamma, alpha;
extern int lsame_(char *, char *);
extern int sscal_(int *, float *, float *, int *);
float sfmin;
extern int cswap_(int *, complex *, int *,
complex *, int *);
float sfmax;
int iflow, kount;
extern int saxpy_(int *, float *, float *, int *,
float *, int *);
float pgamma;
extern int icamax_(int *, complex *, int *);
extern double slamch_(char *);
extern int csscal_(int *, float *, complex *, int
*), xerbla_(char *, int *);
int lsfmin, lsfmax;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGGBAL balances a pair of general complex matrices (A,B). This */
/* involves, first, permuting A and B by similarity transformations to */
/* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N */
/* elements on the diagonal; and second, applying a diagonal similarity */
/* transformation to rows and columns ILO to IHI to make the rows */
/* and columns as close in norm as possible. Both steps are optional. */
/* Balancing may reduce the 1-norm of the matrices, and improve the */
/* accuracy of the computed eigenvalues and/or eigenvectors in the */
/* generalized eigenvalue problem A*x = lambda*B*x. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies the operations to be performed on A and B: */
/* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0 */
/* and RSCALE(I) = 1.0 for i=1,...,N; */
/* = 'P': permute only; */
/* = 'S': scale only; */
/* = 'B': both permute and scale. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the input matrix A. */
/* On exit, A is overwritten by the balanced matrix. */
/* If JOB = 'N', A is not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* B (input/output) COMPLEX array, dimension (LDB,N) */
/* On entry, the input matrix B. */
/* On exit, B is overwritten by the balanced matrix. */
/* If JOB = 'N', B is not referenced. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= MAX(1,N). */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are set to ints such that on exit */
/* A(i,j) = 0 and B(i,j) = 0 if i > j and */
/* j = 1,...,ILO-1 or i = IHI+1,...,N. */
/* If JOB = 'N' or 'S', ILO = 1 and IHI = N. */
/* LSCALE (output) REAL array, dimension (N) */
/* Details of the permutations and scaling factors applied */
/* to the left side of A and B. If P(j) is the index of the */
/* row interchanged with row j, and D(j) is the scaling factor */
/* applied to row j, then */
/* LSCALE(j) = P(j) for J = 1,...,ILO-1 */
/* = D(j) for J = ILO,...,IHI */
/* = P(j) for J = IHI+1,...,N. */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* RSCALE (output) REAL array, dimension (N) */
/* Details of the permutations and scaling factors applied */
/* to the right side of A and B. If P(j) is the index of the */
/* column interchanged with column j, and D(j) is the scaling */
/* factor applied to column j, then */
/* RSCALE(j) = P(j) for J = 1,...,ILO-1 */
/* = D(j) for J = ILO,...,IHI */
/* = P(j) for J = IHI+1,...,N. */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* WORK (workspace) REAL array, dimension (lwork) */
/* lwork must be at least MAX(1,6*N) when JOB = 'S' or 'B', and */
/* at least 1 when JOB = 'N' or 'P'. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* See R.C. WARD, Balancing the generalized eigenvalue problem, */
/* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--lscale;
--rscale;
--work;
/* Function Body */
*info = 0;
if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
&& ! lsame_(job, "B")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < MAX(1,*n)) {
*info = -4;
} else if (*ldb < MAX(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGGBAL", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*ilo = 1;
*ihi = *n;
return 0;
}
if (*n == 1) {
*ilo = 1;
*ihi = *n;
lscale[1] = 1.f;
rscale[1] = 1.f;
return 0;
}
if (lsame_(job, "N")) {
*ilo = 1;
*ihi = *n;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
lscale[i__] = 1.f;
rscale[i__] = 1.f;
/* L10: */
}
return 0;
}
k = 1;
l = *n;
if (lsame_(job, "S")) {
goto L190;
}
goto L30;
/* Permute the matrices A and B to isolate the eigenvalues. */
/* Find row with one nonzero in columns 1 through L */
L20:
l = lm1;
if (l != 1) {
goto L30;
}
rscale[1] = 1.f;
lscale[1] = 1.f;
goto L190;
L30:
lm1 = l - 1;
for (i__ = l; i__ >= 1; --i__) {
i__1 = lm1;
for (j = 1; j <= i__1; ++j) {
jp1 = j + 1;
i__2 = i__ + j * a_dim1;
i__3 = i__ + j * b_dim1;
if (a[i__2].r != 0.f || a[i__2].i != 0.f || (b[i__3].r != 0.f ||
b[i__3].i != 0.f)) {
goto L50;
}
/* L40: */
}
j = l;
goto L70;
L50:
i__1 = l;
for (j = jp1; j <= i__1; ++j) {
i__2 = i__ + j * a_dim1;
i__3 = i__ + j * b_dim1;
if (a[i__2].r != 0.f || a[i__2].i != 0.f || (b[i__3].r != 0.f ||
b[i__3].i != 0.f)) {
goto L80;
}
/* L60: */
}
j = jp1 - 1;
L70:
m = l;
iflow = 1;
goto L160;
L80:
;
}
goto L100;
/* Find column with one nonzero in rows K through N */
L90:
++k;
L100:
i__1 = l;
for (j = k; j <= i__1; ++j) {
i__2 = lm1;
for (i__ = k; i__ <= i__2; ++i__) {
ip1 = i__ + 1;
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * b_dim1;
if (a[i__3].r != 0.f || a[i__3].i != 0.f || (b[i__4].r != 0.f ||
b[i__4].i != 0.f)) {
goto L120;
}
/* L110: */
}
i__ = l;
goto L140;
L120:
i__2 = l;
for (i__ = ip1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * b_dim1;
if (a[i__3].r != 0.f || a[i__3].i != 0.f || (b[i__4].r != 0.f ||
b[i__4].i != 0.f)) {
goto L150;
}
/* L130: */
}
i__ = ip1 - 1;
L140:
m = k;
iflow = 2;
goto L160;
L150:
;
}
goto L190;
/* Permute rows M and I */
L160:
lscale[m] = (float) i__;
if (i__ == m) {
goto L170;
}
i__1 = *n - k + 1;
cswap_(&i__1, &a[i__ + k * a_dim1], lda, &a[m + k * a_dim1], lda);
i__1 = *n - k + 1;
cswap_(&i__1, &b[i__ + k * b_dim1], ldb, &b[m + k * b_dim1], ldb);
/* Permute columns M and J */
L170:
rscale[m] = (float) j;
if (j == m) {
goto L180;
}
cswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
cswap_(&l, &b[j * b_dim1 + 1], &c__1, &b[m * b_dim1 + 1], &c__1);
L180:
switch (iflow) {
case 1: goto L20;
case 2: goto L90;
}
L190:
*ilo = k;
*ihi = l;
if (lsame_(job, "P")) {
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
lscale[i__] = 1.f;
rscale[i__] = 1.f;
/* L195: */
}
return 0;
}
if (*ilo == *ihi) {
return 0;
}
/* Balance the submatrix in rows ILO to IHI. */
nr = *ihi - *ilo + 1;
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
rscale[i__] = 0.f;
lscale[i__] = 0.f;
work[i__] = 0.f;
work[i__ + *n] = 0.f;
work[i__ + (*n << 1)] = 0.f;
work[i__ + *n * 3] = 0.f;
work[i__ + (*n << 2)] = 0.f;
work[i__ + *n * 5] = 0.f;
/* L200: */
}
/* Compute right side vector in resulting linear equations */
basl = r_lg10(&c_b36);
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
i__2 = *ihi;
for (j = *ilo; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
if (a[i__3].r == 0.f && a[i__3].i == 0.f) {
ta = 0.f;
goto L210;
}
i__3 = i__ + j * a_dim1;
r__3 = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 = r_imag(&a[i__ + j
* a_dim1]), ABS(r__2));
ta = r_lg10(&r__3) / basl;
L210:
i__3 = i__ + j * b_dim1;
if (b[i__3].r == 0.f && b[i__3].i == 0.f) {
tb = 0.f;
goto L220;
}
i__3 = i__ + j * b_dim1;
r__3 = (r__1 = b[i__3].r, ABS(r__1)) + (r__2 = r_imag(&b[i__ + j
* b_dim1]), ABS(r__2));
tb = r_lg10(&r__3) / basl;
L220:
work[i__ + (*n << 2)] = work[i__ + (*n << 2)] - ta - tb;
work[j + *n * 5] = work[j + *n * 5] - ta - tb;
/* L230: */
}
/* L240: */
}
coef = 1.f / (float) (nr << 1);
coef2 = coef * coef;
coef5 = coef2 * .5f;
nrp2 = nr + 2;
beta = 0.f;
it = 1;
/* Start generalized conjugate gradient iteration */
L250:
gamma = sdot_(&nr, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + (*n << 2)]
, &c__1) + sdot_(&nr, &work[*ilo + *n * 5], &c__1, &work[*ilo + *
n * 5], &c__1);
ew = 0.f;
ewc = 0.f;
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
ew += work[i__ + (*n << 2)];
ewc += work[i__ + *n * 5];
/* L260: */
}
/* Computing 2nd power */
r__1 = ew;
/* Computing 2nd power */
r__2 = ewc;
/* Computing 2nd power */
r__3 = ew - ewc;
gamma = coef * gamma - coef2 * (r__1 * r__1 + r__2 * r__2) - coef5 * (
r__3 * r__3);
if (gamma == 0.f) {
goto L350;
}
if (it != 1) {
beta = gamma / pgamma;
}
t = coef5 * (ewc - ew * 3.f);
tc = coef5 * (ew - ewc * 3.f);
sscal_(&nr, &beta, &work[*ilo], &c__1);
sscal_(&nr, &beta, &work[*ilo + *n], &c__1);
saxpy_(&nr, &coef, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + *n], &
c__1);
saxpy_(&nr, &coef, &work[*ilo + *n * 5], &c__1, &work[*ilo], &c__1);
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
work[i__] += tc;
work[i__ + *n] += t;
/* L270: */
}
/* Apply matrix to vector */
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
kount = 0;
sum = 0.f;
i__2 = *ihi;
for (j = *ilo; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
if (a[i__3].r == 0.f && a[i__3].i == 0.f) {
goto L280;
}
++kount;
sum += work[j];
L280:
i__3 = i__ + j * b_dim1;
if (b[i__3].r == 0.f && b[i__3].i == 0.f) {
goto L290;
}
++kount;
sum += work[j];
L290:
;
}
work[i__ + (*n << 1)] = (float) kount * work[i__ + *n] + sum;
/* L300: */
}
i__1 = *ihi;
for (j = *ilo; j <= i__1; ++j) {
kount = 0;
sum = 0.f;
i__2 = *ihi;
for (i__ = *ilo; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
if (a[i__3].r == 0.f && a[i__3].i == 0.f) {
goto L310;
}
++kount;
sum += work[i__ + *n];
L310:
i__3 = i__ + j * b_dim1;
if (b[i__3].r == 0.f && b[i__3].i == 0.f) {
goto L320;
}
++kount;
sum += work[i__ + *n];
L320:
;
}
work[j + *n * 3] = (float) kount * work[j] + sum;
/* L330: */
}
sum = sdot_(&nr, &work[*ilo + *n], &c__1, &work[*ilo + (*n << 1)], &c__1)
+ sdot_(&nr, &work[*ilo], &c__1, &work[*ilo + *n * 3], &c__1);
alpha = gamma / sum;
/* Determine correction to current iteration */
cmax = 0.f;
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
cor = alpha * work[i__ + *n];
if (ABS(cor) > cmax) {
cmax = ABS(cor);
}
lscale[i__] += cor;
cor = alpha * work[i__];
if (ABS(cor) > cmax) {
cmax = ABS(cor);
}
rscale[i__] += cor;
/* L340: */
}
if (cmax < .5f) {
goto L350;
}
r__1 = -alpha;
saxpy_(&nr, &r__1, &work[*ilo + (*n << 1)], &c__1, &work[*ilo + (*n << 2)]
, &c__1);
r__1 = -alpha;
saxpy_(&nr, &r__1, &work[*ilo + *n * 3], &c__1, &work[*ilo + *n * 5], &
c__1);
pgamma = gamma;
++it;
if (it <= nrp2) {
goto L250;
}
/* End generalized conjugate gradient iteration */
L350:
sfmin = slamch_("S");
sfmax = 1.f / sfmin;
lsfmin = (int) (r_lg10(&sfmin) / basl + 1.f);
lsfmax = (int) (r_lg10(&sfmax) / basl);
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
i__2 = *n - *ilo + 1;
irab = icamax_(&i__2, &a[i__ + *ilo * a_dim1], lda);
rab = c_abs(&a[i__ + (irab + *ilo - 1) * a_dim1]);
i__2 = *n - *ilo + 1;
irab = icamax_(&i__2, &b[i__ + *ilo * b_dim1], ldb);
/* Computing MAX */
r__1 = rab, r__2 = c_abs(&b[i__ + (irab + *ilo - 1) * b_dim1]);
rab = MAX(r__1,r__2);
r__1 = rab + sfmin;
lrab = (int) (r_lg10(&r__1) / basl + 1.f);
ir = lscale[i__] + r_sign(&c_b72, &lscale[i__]);
/* Computing MIN */
i__2 = MAX(ir,lsfmin), i__2 = MIN(i__2,lsfmax), i__3 = lsfmax - lrab;
ir = MIN(i__2,i__3);
lscale[i__] = pow_ri(&c_b36, &ir);
icab = icamax_(ihi, &a[i__ * a_dim1 + 1], &c__1);
cab = c_abs(&a[icab + i__ * a_dim1]);
icab = icamax_(ihi, &b[i__ * b_dim1 + 1], &c__1);
/* Computing MAX */
r__1 = cab, r__2 = c_abs(&b[icab + i__ * b_dim1]);
cab = MAX(r__1,r__2);
r__1 = cab + sfmin;
lcab = (int) (r_lg10(&r__1) / basl + 1.f);
jc = rscale[i__] + r_sign(&c_b72, &rscale[i__]);
/* Computing MIN */
i__2 = MAX(jc,lsfmin), i__2 = MIN(i__2,lsfmax), i__3 = lsfmax - lcab;
jc = MIN(i__2,i__3);
rscale[i__] = pow_ri(&c_b36, &jc);
/* L360: */
}
/* Row scaling of matrices A and B */
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
i__2 = *n - *ilo + 1;
csscal_(&i__2, &lscale[i__], &a[i__ + *ilo * a_dim1], lda);
i__2 = *n - *ilo + 1;
csscal_(&i__2, &lscale[i__], &b[i__ + *ilo * b_dim1], ldb);
/* L370: */
}
/* Column scaling of matrices A and B */
i__1 = *ihi;
for (j = *ilo; j <= i__1; ++j) {
csscal_(ihi, &rscale[j], &a[j * a_dim1 + 1], &c__1);
csscal_(ihi, &rscale[j], &b[j * b_dim1 + 1], &c__1);
/* L380: */
}
return 0;
/* End of CGGBAL */
} /* cggbal_ */
