/* Subroutine */ int slaqtr_(logical *ltran, logical *lreal, integer *n, real *t, integer *ldt, real *b, real *w, real *scale, real *x, real *work, integer *info) { /* System generated locals */ integer t_dim1, t_offset, i__1, i__2; real r__1, r__2, r__3, r__4, r__5, r__6; /* Local variables */ real d__[4] /* was [2][2] */; integer i__, j, k; real v[4] /* was [2][2] */, z__; integer j1, j2, n1, n2; real si, xj, sr, rec, eps, tjj, tmp; integer ierr; real smin; extern doublereal sdot_(integer *, real *, integer *, real *, integer *); real xmax; extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); integer jnext; extern doublereal sasum_(integer *, real *, integer *); real sminw, xnorm; extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, real *, integer *), slaln2_(logical *, integer *, integer *, real *, real *, real *, integer *, real *, real *, real *, integer *, real *, real *, real *, integer *, real *, real *, integer *); real scaloc; extern doublereal slamch_(char *), slange_(char *, integer *, integer *, real *, integer *, real *); real bignum; extern integer isamax_(integer *, real *, integer *); extern /* Subroutine */ int sladiv_(real *, real *, real *, real *, real * , real *); logical notran; real smlnum; /* -- LAPACK auxiliary routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SLAQTR solves the real quasi-triangular system */ /* op(T)*p = scale*c, if LREAL = .TRUE. */ /* or the complex quasi-triangular systems */ /* op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE. */ /* in real arithmetic, where T is upper quasi-triangular. */ /* If LREAL = .FALSE., then the first diagonal block of T must be */ /* 1 by 1, B is the specially structured matrix */ /* B = [ b(1) b(2) ... b(n) ] */ /* [ w ] */ /* [ w ] */ /* [ . ] */ /* [ w ] */ /* op(A) = A or A', A' denotes the conjugate transpose of */ /* matrix A. */ /* On input, X = [ c ]. On output, X = [ p ]. */ /* [ d ] [ q ] */ /* This subroutine is designed for the condition number estimation */ /* in routine STRSNA. */ /* Arguments */ /* ========= */ /* LTRAN (input) LOGICAL */ /* On entry, LTRAN specifies the option of conjugate transpose: */ /* = .FALSE., op(T+i*B) = T+i*B, */ /* = .TRUE., op(T+i*B) = (T+i*B)'. */ /* LREAL (input) LOGICAL */ /* On entry, LREAL specifies the input matrix structure: */ /* = .FALSE., the input is complex */ /* = .TRUE., the input is real */ /* N (input) INTEGER */ /* On entry, N specifies the order of T+i*B. N >= 0. */ /* T (input) REAL array, dimension (LDT,N) */ /* On entry, T contains a matrix in Schur canonical form. */ /* If LREAL = .FALSE., then the first diagonal block of T must */ /* be 1 by 1. */ /* LDT (input) INTEGER */ /* The leading dimension of the matrix T. LDT >= max(1,N). */ /* B (input) REAL array, dimension (N) */ /* On entry, B contains the elements to form the matrix */ /* B as described above. */ /* If LREAL = .TRUE., B is not referenced. */ /* W (input) REAL */ /* On entry, W is the diagonal element of the matrix B. */ /* If LREAL = .TRUE., W is not referenced. */ /* SCALE (output) REAL */ /* On exit, SCALE is the scale factor. */ /* X (input/output) REAL array, dimension (2*N) */ /* On entry, X contains the right hand side of the system. */ /* On exit, X is overwritten by the solution. */ /* WORK (workspace) REAL array, dimension (N) */ /* INFO (output) INTEGER */ /* On exit, INFO is set to */ /* 0: successful exit. */ /* 1: the some diagonal 1 by 1 block has been perturbed by */ /* a small number SMIN to keep nonsingularity. */ /* 2: the some diagonal 2 by 2 block has been perturbed by */ /* a small number in SLALN2 to keep nonsingularity. */ /* NOTE: In the interests of speed, this routine does not */ /* check the inputs for errors. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Do not test the input parameters for errors */ /* Parameter adjustments */ t_dim1 = *ldt; t_offset = 1 + t_dim1; t -= t_offset; --b; --x; --work; /* Function Body */ notran = ! (*ltran); *info = 0; /* Quick return if possible */ if (*n == 0) { return 0; } /* Set constants to control overflow */ eps = slamch_("P"); smlnum = slamch_("S") / eps; bignum = 1.f / smlnum; xnorm = slange_("M", n, n, &t[t_offset], ldt, d__); if (! (*lreal)) { /* Computing MAX */ r__1 = xnorm, r__2 = dabs(*w), r__1 = max(r__1,r__2), r__2 = slange_( "M", n, &c__1, &b[1], n, d__); xnorm = dmax(r__1,r__2); } /* Computing MAX */ r__1 = smlnum, r__2 = eps * xnorm; smin = dmax(r__1,r__2); /* Compute 1-norm of each column of strictly upper triangular */ /* part of T to control overflow in triangular solver. */ work[1] = 0.f; i__1 = *n; for (j = 2; j <= i__1; ++j) { i__2 = j - 1; work[j] = sasum_(&i__2, &t[j * t_dim1 + 1], &c__1); /* L10: */ } if (! (*lreal)) { i__1 = *n; for (i__ = 2; i__ <= i__1; ++i__) { work[i__] += (r__1 = b[i__], dabs(r__1)); /* L20: */ } } n2 = *n << 1; n1 = *n; if (! (*lreal)) { n1 = n2; } k = isamax_(&n1, &x[1], &c__1); xmax = (r__1 = x[k], dabs(r__1)); *scale = 1.f; if (xmax > bignum) { *scale = bignum / xmax; sscal_(&n1, scale, &x[1], &c__1); xmax = bignum; } if (*lreal) { if (notran) { /* Solve T*p = scale*c */ jnext = *n; for (j = *n; j >= 1; --j) { if (j > jnext) { goto L30; } j1 = j; j2 = j; jnext = j - 1; if (j > 1) { if (t[j + (j - 1) * t_dim1] != 0.f) { j1 = j - 1; jnext = j - 2; } } if (j1 == j2) { /* Meet 1 by 1 diagonal block */ /* Scale to avoid overflow when computing */ /* x(j) = b(j)/T(j,j) */ xj = (r__1 = x[j1], dabs(r__1)); tjj = (r__1 = t[j1 + j1 * t_dim1], dabs(r__1)); tmp = t[j1 + j1 * t_dim1]; if (tjj < smin) { tmp = smin; tjj = smin; *info = 1; } if (xj == 0.f) { goto L30; } if (tjj < 1.f) { if (xj > bignum * tjj) { rec = 1.f / xj; sscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } x[j1] /= tmp; xj = (r__1 = x[j1], dabs(r__1)); /* Scale x if necessary to avoid overflow when adding a */ /* multiple of column j1 of T. */ if (xj > 1.f) { rec = 1.f / xj; if (work[j1] > (bignum - xmax) * rec) { sscal_(n, &rec, &x[1], &c__1); *scale *= rec; } } if (j1 > 1) { i__1 = j1 - 1; r__1 = -x[j1]; saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] , &c__1); i__1 = j1 - 1; k = isamax_(&i__1, &x[1], &c__1); xmax = (r__1 = x[k], dabs(r__1)); } } else { /* Meet 2 by 2 diagonal block */ /* Call 2 by 2 linear system solve, to take */ /* care of possible overflow by scaling factor. */ d__[0] = x[j1]; d__[1] = x[j2]; slaln2_(&c_false, &c__2, &c__1, &smin, &c_b21, &t[j1 + j1 * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, & c_b25, &c_b25, v, &c__2, &scaloc, &xnorm, &ierr); if (ierr != 0) { *info = 2; } if (scaloc != 1.f) { sscal_(n, &scaloc, &x[1], &c__1); *scale *= scaloc; } x[j1] = v[0]; x[j2] = v[1]; /* Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2)) */ /* to avoid overflow in updating right-hand side. */ /* Computing MAX */ r__1 = dabs(v[0]), r__2 = dabs(v[1]); xj = dmax(r__1,r__2); if (xj > 1.f) { rec = 1.f / xj; /* Computing MAX */ r__1 = work[j1], r__2 = work[j2]; if (dmax(r__1,r__2) > (bignum - xmax) * rec) { sscal_(n, &rec, &x[1], &c__1); *scale *= rec; } } /* Update right-hand side */ if (j1 > 1) { i__1 = j1 - 1; r__1 = -x[j1]; saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] , &c__1); i__1 = j1 - 1; r__1 = -x[j2]; saxpy_(&i__1, &r__1, &t[j2 * t_dim1 + 1], &c__1, &x[1] , &c__1); i__1 = j1 - 1; k = isamax_(&i__1, &x[1], &c__1); xmax = (r__1 = x[k], dabs(r__1)); } } L30: ; } } else { /* Solve T'*p = scale*c */ jnext = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (j < jnext) { goto L40; } j1 = j; j2 = j; jnext = j + 1; if (j < *n) { if (t[j + 1 + j * t_dim1] != 0.f) { j2 = j + 1; jnext = j + 2; } } if (j1 == j2) { /* 1 by 1 diagonal block */ /* Scale if necessary to avoid overflow in forming the */ /* right-hand side element by inner product. */ xj = (r__1 = x[j1], dabs(r__1)); if (xmax > 1.f) { rec = 1.f / xmax; if (work[j1] > (bignum - xj) * rec) { sscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__2 = j1 - 1; x[j1] -= sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], & c__1); xj = (r__1 = x[j1], dabs(r__1)); tjj = (r__1 = t[j1 + j1 * t_dim1], dabs(r__1)); tmp = t[j1 + j1 * t_dim1]; if (tjj < smin) { tmp = smin; tjj = smin; *info = 1; } if (tjj < 1.f) { if (xj > bignum * tjj) { rec = 1.f / xj; sscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } x[j1] /= tmp; /* Computing MAX */ r__2 = xmax, r__3 = (r__1 = x[j1], dabs(r__1)); xmax = dmax(r__2,r__3); } else { /* 2 by 2 diagonal block */ /* Scale if necessary to avoid overflow in forming the */ /* right-hand side elements by inner product. */ /* Computing MAX */ r__3 = (r__1 = x[j1], dabs(r__1)), r__4 = (r__2 = x[j2], dabs(r__2)); xj = dmax(r__3,r__4); if (xmax > 1.f) { rec = 1.f / xmax; /* Computing MAX */ r__1 = work[j2], r__2 = work[j1]; if (dmax(r__1,r__2) > (bignum - xj) * rec) { sscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__2 = j1 - 1; d__[0] = x[j1] - sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], &c__1); i__2 = j1 - 1; d__[1] = x[j2] - sdot_(&i__2, &t[j2 * t_dim1 + 1], &c__1, &x[1], &c__1); slaln2_(&c_true, &c__2, &c__1, &smin, &c_b21, &t[j1 + j1 * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &c_b25, &c_b25, v, &c__2, &scaloc, &xnorm, &ierr); if (ierr != 0) { *info = 2; } if (scaloc != 1.f) { sscal_(n, &scaloc, &x[1], &c__1); *scale *= scaloc; } x[j1] = v[0]; x[j2] = v[1]; /* Computing MAX */ r__3 = (r__1 = x[j1], dabs(r__1)), r__4 = (r__2 = x[j2], dabs(r__2)), r__3 = max(r__3,r__4); xmax = dmax(r__3,xmax); } L40: ; } } } else { /* Computing MAX */ r__1 = eps * dabs(*w); sminw = dmax(r__1,smin); if (notran) { /* Solve (T + iB)*(p+iq) = c+id */ jnext = *n; for (j = *n; j >= 1; --j) { if (j > jnext) { goto L70; } j1 = j; j2 = j; jnext = j - 1; if (j > 1) { if (t[j + (j - 1) * t_dim1] != 0.f) { j1 = j - 1; jnext = j - 2; } } if (j1 == j2) { /* 1 by 1 diagonal block */ /* Scale if necessary to avoid overflow in division */ z__ = *w; if (j1 == 1) { z__ = b[1]; } xj = (r__1 = x[j1], dabs(r__1)) + (r__2 = x[*n + j1], dabs(r__2)); tjj = (r__1 = t[j1 + j1 * t_dim1], dabs(r__1)) + dabs(z__) ; tmp = t[j1 + j1 * t_dim1]; if (tjj < sminw) { tmp = sminw; tjj = sminw; *info = 1; } if (xj == 0.f) { goto L70; } if (tjj < 1.f) { if (xj > bignum * tjj) { rec = 1.f / xj; sscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } sladiv_(&x[j1], &x[*n + j1], &tmp, &z__, &sr, &si); x[j1] = sr; x[*n + j1] = si; xj = (r__1 = x[j1], dabs(r__1)) + (r__2 = x[*n + j1], dabs(r__2)); /* Scale x if necessary to avoid overflow when adding a */ /* multiple of column j1 of T. */ if (xj > 1.f) { rec = 1.f / xj; if (work[j1] > (bignum - xmax) * rec) { sscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; } } if (j1 > 1) { i__1 = j1 - 1; r__1 = -x[j1]; saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] , &c__1); i__1 = j1 - 1; r__1 = -x[*n + j1]; saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[* n + 1], &c__1); x[1] += b[j1] * x[*n + j1]; x[*n + 1] -= b[j1] * x[j1]; xmax = 0.f; i__1 = j1 - 1; for (k = 1; k <= i__1; ++k) { /* Computing MAX */ r__3 = xmax, r__4 = (r__1 = x[k], dabs(r__1)) + ( r__2 = x[k + *n], dabs(r__2)); xmax = dmax(r__3,r__4); /* L50: */ } } } else { /* Meet 2 by 2 diagonal block */ d__[0] = x[j1]; d__[1] = x[j2]; d__[2] = x[*n + j1]; d__[3] = x[*n + j2]; r__1 = -(*w); slaln2_(&c_false, &c__2, &c__2, &sminw, &c_b21, &t[j1 + j1 * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, & c_b25, &r__1, v, &c__2, &scaloc, &xnorm, &ierr); if (ierr != 0) { *info = 2; } if (scaloc != 1.f) { i__1 = *n << 1; sscal_(&i__1, &scaloc, &x[1], &c__1); *scale = scaloc * *scale; } x[j1] = v[0]; x[j2] = v[1]; x[*n + j1] = v[2]; x[*n + j2] = v[3]; /* Scale X(J1), .... to avoid overflow in */ /* updating right hand side. */ /* Computing MAX */ r__1 = dabs(v[0]) + dabs(v[2]), r__2 = dabs(v[1]) + dabs( v[3]); xj = dmax(r__1,r__2); if (xj > 1.f) { rec = 1.f / xj; /* Computing MAX */ r__1 = work[j1], r__2 = work[j2]; if (dmax(r__1,r__2) > (bignum - xmax) * rec) { sscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; } } /* Update the right-hand side. */ if (j1 > 1) { i__1 = j1 - 1; r__1 = -x[j1]; saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] , &c__1); i__1 = j1 - 1; r__1 = -x[j2]; saxpy_(&i__1, &r__1, &t[j2 * t_dim1 + 1], &c__1, &x[1] , &c__1); i__1 = j1 - 1; r__1 = -x[*n + j1]; saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[* n + 1], &c__1); i__1 = j1 - 1; r__1 = -x[*n + j2]; saxpy_(&i__1, &r__1, &t[j2 * t_dim1 + 1], &c__1, &x[* n + 1], &c__1); x[1] = x[1] + b[j1] * x[*n + j1] + b[j2] * x[*n + j2]; x[*n + 1] = x[*n + 1] - b[j1] * x[j1] - b[j2] * x[j2]; xmax = 0.f; i__1 = j1 - 1; for (k = 1; k <= i__1; ++k) { /* Computing MAX */ r__3 = (r__1 = x[k], dabs(r__1)) + (r__2 = x[k + * n], dabs(r__2)); xmax = dmax(r__3,xmax); /* L60: */ } } } L70: ; } } else { /* Solve (T + iB)'*(p+iq) = c+id */ jnext = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (j < jnext) { goto L80; } j1 = j; j2 = j; jnext = j + 1; if (j < *n) { if (t[j + 1 + j * t_dim1] != 0.f) { j2 = j + 1; jnext = j + 2; } } if (j1 == j2) { /* 1 by 1 diagonal block */ /* Scale if necessary to avoid overflow in forming the */ /* right-hand side element by inner product. */ xj = (r__1 = x[j1], dabs(r__1)) + (r__2 = x[j1 + *n], dabs(r__2)); if (xmax > 1.f) { rec = 1.f / xmax; if (work[j1] > (bignum - xj) * rec) { sscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__2 = j1 - 1; x[j1] -= sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], & c__1); i__2 = j1 - 1; x[*n + j1] -= sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[ *n + 1], &c__1); if (j1 > 1) { x[j1] -= b[j1] * x[*n + 1]; x[*n + j1] += b[j1] * x[1]; } xj = (r__1 = x[j1], dabs(r__1)) + (r__2 = x[j1 + *n], dabs(r__2)); z__ = *w; if (j1 == 1) { z__ = b[1]; } /* Scale if necessary to avoid overflow in */ /* complex division */ tjj = (r__1 = t[j1 + j1 * t_dim1], dabs(r__1)) + dabs(z__) ; tmp = t[j1 + j1 * t_dim1]; if (tjj < sminw) { tmp = sminw; tjj = sminw; *info = 1; } if (tjj < 1.f) { if (xj > bignum * tjj) { rec = 1.f / xj; sscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } r__1 = -z__; sladiv_(&x[j1], &x[*n + j1], &tmp, &r__1, &sr, &si); x[j1] = sr; x[j1 + *n] = si; /* Computing MAX */ r__3 = (r__1 = x[j1], dabs(r__1)) + (r__2 = x[j1 + *n], dabs(r__2)); xmax = dmax(r__3,xmax); } else { /* 2 by 2 diagonal block */ /* Scale if necessary to avoid overflow in forming the */ /* right-hand side element by inner product. */ /* Computing MAX */ r__5 = (r__1 = x[j1], dabs(r__1)) + (r__2 = x[*n + j1], dabs(r__2)), r__6 = (r__3 = x[j2], dabs(r__3)) + ( r__4 = x[*n + j2], dabs(r__4)); xj = dmax(r__5,r__6); if (xmax > 1.f) { rec = 1.f / xmax; /* Computing MAX */ r__1 = work[j1], r__2 = work[j2]; if (dmax(r__1,r__2) > (bignum - xj) / xmax) { sscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__2 = j1 - 1; d__[0] = x[j1] - sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], &c__1); i__2 = j1 - 1; d__[1] = x[j2] - sdot_(&i__2, &t[j2 * t_dim1 + 1], &c__1, &x[1], &c__1); i__2 = j1 - 1; d__[2] = x[*n + j1] - sdot_(&i__2, &t[j1 * t_dim1 + 1], & c__1, &x[*n + 1], &c__1); i__2 = j1 - 1; d__[3] = x[*n + j2] - sdot_(&i__2, &t[j2 * t_dim1 + 1], & c__1, &x[*n + 1], &c__1); d__[0] -= b[j1] * x[*n + 1]; d__[1] -= b[j2] * x[*n + 1]; d__[2] += b[j1] * x[1]; d__[3] += b[j2] * x[1]; slaln2_(&c_true, &c__2, &c__2, &sminw, &c_b21, &t[j1 + j1 * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, & c_b25, w, v, &c__2, &scaloc, &xnorm, &ierr); if (ierr != 0) { *info = 2; } if (scaloc != 1.f) { sscal_(&n2, &scaloc, &x[1], &c__1); *scale = scaloc * *scale; } x[j1] = v[0]; x[j2] = v[1]; x[*n + j1] = v[2]; x[*n + j2] = v[3]; /* Computing MAX */ r__5 = (r__1 = x[j1], dabs(r__1)) + (r__2 = x[*n + j1], dabs(r__2)), r__6 = (r__3 = x[j2], dabs(r__3)) + ( r__4 = x[*n + j2], dabs(r__4)), r__5 = max(r__5, r__6); xmax = dmax(r__5,xmax); } L80: ; } } } return 0; /* End of SLAQTR */ } /* slaqtr_ */
/* Subroutine */ int sget31_(real *rmax, integer *lmax, integer *ninfo, integer *knt) { /* Initialized data */ static logical ltrans[2] = { FALSE_,TRUE_ }; /* System generated locals */ real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10, r__11, r__12, r__13, r__14, r__15, r__16, r__17; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static integer info; static real unfl, smin, a[4] /* was [2][2] */, b[4] /* was [2][2] */, scale, x[4] /* was [2][2] */; static integer ismin; static real d1, d2, vsmin[4], xnorm; extern /* Subroutine */ int slaln2_(logical *, integer *, integer *, real *, real *, real *, integer *, real *, real *, real *, integer *, real *, real *, real *, integer *, real *, real *, integer *); static real ca; static integer ia, ib, na; extern /* Subroutine */ int slabad_(real *, real *); static real wi; static integer nw; extern doublereal slamch_(char *); static real wr, bignum; static integer id1, id2, itrans; static real smlnum; static integer ica; static real den, vab[3], vca[5], vdd[4], eps; static integer iwi; static real res, tmp; static integer iwr; static real vwi[4], vwr[4]; #define a_ref(a_1,a_2) a[(a_2)*2 + a_1 - 3] #define b_ref(a_1,a_2) b[(a_2)*2 + a_1 - 3] #define x_ref(a_1,a_2) x[(a_2)*2 + a_1 - 3] /* -- 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 ======= SGET31 tests SLALN2, a routine for solving (ca A - w D)X = sB where A is an NA by NA matrix (NA=1 or 2 only), w is a real (NW=1) or complex (NW=2) constant, ca is a real constant, D is an NA by NA real diagonal matrix, and B is an NA by NW matrix (when NW=2 the second column of B contains the imaginary part of the solution). The code returns X and s, where s is a scale factor, less than or equal to 1, which is chosen to avoid overflow in X. If any singular values of ca A-w D are less than another input parameter SMIN, they are perturbed up to SMIN. The test condition is that the scaled residual norm( (ca A-w D)*X - s*B ) / ( max( ulp*norm(ca A-w D), SMIN )*norm(X) ) should be on the order of 1. Here, ulp is the machine precision. Also, it is verified that SCALE is less than or equal to 1, and that XNORM = infinity-norm(X). Arguments ========== RMAX (output) REAL Value of the largest test ratio. LMAX (output) INTEGER Example number where largest test ratio achieved. NINFO (output) INTEGER array, dimension (3) NINFO(1) = number of examples with INFO less than 0 NINFO(2) = number of examples with INFO greater than 0 KNT (output) INTEGER Total number of examples tested. ===================================================================== Parameter adjustments */ --ninfo; /* Function Body Get machine parameters */ eps = slamch_("P"); unfl = slamch_("U"); smlnum = slamch_("S") / eps; bignum = 1.f / smlnum; slabad_(&smlnum, &bignum); /* Set up test case parameters */ vsmin[0] = smlnum; vsmin[1] = eps; vsmin[2] = .01f; vsmin[3] = 1.f / eps; vab[0] = sqrt(smlnum); vab[1] = 1.f; vab[2] = sqrt(bignum); vwr[0] = 0.f; vwr[1] = .5f; vwr[2] = 2.f; vwr[3] = 1.f; vwi[0] = smlnum; vwi[1] = eps; vwi[2] = 1.f; vwi[3] = 2.f; vdd[0] = sqrt(smlnum); vdd[1] = 1.f; vdd[2] = 2.f; vdd[3] = sqrt(bignum); vca[0] = 0.f; vca[1] = sqrt(smlnum); vca[2] = eps; vca[3] = .5f; vca[4] = 1.f; *knt = 0; ninfo[1] = 0; ninfo[2] = 0; *lmax = 0; *rmax = 0.f; /* Begin test loop */ for (id1 = 1; id1 <= 4; ++id1) { d1 = vdd[id1 - 1]; for (id2 = 1; id2 <= 4; ++id2) { d2 = vdd[id2 - 1]; for (ica = 1; ica <= 5; ++ica) { ca = vca[ica - 1]; for (itrans = 0; itrans <= 1; ++itrans) { for (ismin = 1; ismin <= 4; ++ismin) { smin = vsmin[ismin - 1]; na = 1; nw = 1; for (ia = 1; ia <= 3; ++ia) { a_ref(1, 1) = vab[ia - 1]; for (ib = 1; ib <= 3; ++ib) { b_ref(1, 1) = vab[ib - 1]; for (iwr = 1; iwr <= 4; ++iwr) { if (d1 == 1.f && d2 == 1.f && ca == 1.f) { wr = vwr[iwr - 1] * a_ref(1, 1); } else { wr = vwr[iwr - 1]; } wi = 0.f; slaln2_(<rans[itrans], &na, &nw, &smin, &ca, a, &c__2, &d1, &d2, b, &c__2, &wr, &wi, x, &c__2, &scale, & xnorm, &info); if (info < 0) { ++ninfo[1]; } if (info > 0) { ++ninfo[2]; } res = (r__1 = (ca * a_ref(1, 1) - wr * d1) * x_ref(1, 1) - scale * b_ref(1, 1), dabs(r__1)); if (info == 0) { /* Computing MAX */ r__2 = eps * (r__1 = (ca * a_ref(1, 1) - wr * d1) * x_ref(1, 1), dabs(r__1)); den = dmax(r__2,smlnum); } else { /* Computing MAX */ r__2 = smin * (r__1 = x_ref(1, 1), dabs(r__1)); den = dmax(r__2,smlnum); } res /= den; if ((r__1 = x_ref(1, 1), dabs(r__1)) < unfl && (r__3 = b_ref(1, 1), dabs( r__3)) <= smlnum * (r__2 = ca * a_ref(1, 1) - wr * d1, dabs(r__2)) ) { res = 0.f; } if (scale > 1.f) { res += 1.f / eps; } res += (r__2 = xnorm - (r__1 = x_ref(1, 1) , dabs(r__1)), dabs(r__2)) / dmax( smlnum,xnorm) / eps; if (info != 0 && info != 1) { res += 1.f / eps; } ++(*knt); if (res > *rmax) { *lmax = *knt; *rmax = res; } /* L10: */ } /* L20: */ } /* L30: */ } na = 1; nw = 2; for (ia = 1; ia <= 3; ++ia) { a_ref(1, 1) = vab[ia - 1]; for (ib = 1; ib <= 3; ++ib) { b_ref(1, 1) = vab[ib - 1]; b_ref(1, 2) = vab[ib - 1] * -.5f; for (iwr = 1; iwr <= 4; ++iwr) { if (d1 == 1.f && d2 == 1.f && ca == 1.f) { wr = vwr[iwr - 1] * a_ref(1, 1); } else { wr = vwr[iwr - 1]; } for (iwi = 1; iwi <= 4; ++iwi) { if (d1 == 1.f && d2 == 1.f && ca == 1.f) { wi = vwi[iwi - 1] * a_ref(1, 1); } else { wi = vwi[iwi - 1]; } slaln2_(<rans[itrans], &na, &nw, & smin, &ca, a, &c__2, &d1, &d2, b, &c__2, &wr, &wi, x, &c__2, &scale, &xnorm, &info); if (info < 0) { ++ninfo[1]; } if (info > 0) { ++ninfo[2]; } res = (r__1 = (ca * a_ref(1, 1) - wr * d1) * x_ref(1, 1) + wi * d1 * x_ref(1, 2) - scale * b_ref( 1, 1), dabs(r__1)); res += (r__1 = -wi * d1 * x_ref(1, 1) + (ca * a_ref(1, 1) - wr * d1) * x_ref(1, 2) - scale * b_ref(1, 2), dabs(r__1)); if (info == 0) { /* Computing MAX Computing MAX */ r__6 = (r__3 = ca * a_ref(1, 1) - wr * d1, dabs(r__3)), r__7 = (r__4 = d1 * wi, dabs(r__4)); r__5 = eps * (dmax(r__6,r__7) * (( r__1 = x_ref(1, 1), dabs( r__1)) + (r__2 = x_ref(1, 2), dabs(r__2)))); den = dmax(r__5,smlnum); } else { /* Computing MAX */ r__3 = smin * ((r__1 = x_ref(1, 1) , dabs(r__1)) + (r__2 = x_ref(1, 2), dabs(r__2))); den = dmax(r__3,smlnum); } res /= den; if ((r__1 = x_ref(1, 1), dabs(r__1)) < unfl && (r__2 = x_ref(1, 2), dabs(r__2)) < unfl && (r__4 = b_ref(1, 1), dabs(r__4)) <= smlnum * (r__3 = ca * a_ref(1, 1) - wr * d1, dabs(r__3))) { res = 0.f; } if (scale > 1.f) { res += 1.f / eps; } res += (r__3 = xnorm - (r__1 = x_ref( 1, 1), dabs(r__1)) - (r__2 = x_ref(1, 2), dabs(r__2)), dabs(r__3)) / dmax(smlnum, xnorm) / eps; if (info != 0 && info != 1) { res += 1.f / eps; } ++(*knt); if (res > *rmax) { *lmax = *knt; *rmax = res; } /* L40: */ } /* L50: */ } /* L60: */ } /* L70: */ } na = 2; nw = 1; for (ia = 1; ia <= 3; ++ia) { a_ref(1, 1) = vab[ia - 1]; a_ref(1, 2) = vab[ia - 1] * -3.f; a_ref(2, 1) = vab[ia - 1] * -7.f; a_ref(2, 2) = vab[ia - 1] * 21.f; for (ib = 1; ib <= 3; ++ib) { b_ref(1, 1) = vab[ib - 1]; b_ref(2, 1) = vab[ib - 1] * -2.f; for (iwr = 1; iwr <= 4; ++iwr) { if (d1 == 1.f && d2 == 1.f && ca == 1.f) { wr = vwr[iwr - 1] * a_ref(1, 1); } else { wr = vwr[iwr - 1]; } wi = 0.f; slaln2_(<rans[itrans], &na, &nw, &smin, &ca, a, &c__2, &d1, &d2, b, &c__2, &wr, &wi, x, &c__2, &scale, & xnorm, &info); if (info < 0) { ++ninfo[1]; } if (info > 0) { ++ninfo[2]; } if (itrans == 1) { tmp = a_ref(1, 2); a_ref(1, 2) = a_ref(2, 1); a_ref(2, 1) = tmp; } res = (r__1 = (ca * a_ref(1, 1) - wr * d1) * x_ref(1, 1) + ca * a_ref(1, 2) * x_ref(2, 1) - scale * b_ref(1, 1), dabs(r__1)); res += (r__1 = ca * a_ref(2, 1) * x_ref(1, 1) + (ca * a_ref(2, 2) - wr * d2) * x_ref(2, 1) - scale * b_ref(2, 1), dabs(r__1)); if (info == 0) { /* Computing MAX Computing MAX */ r__8 = (r__1 = ca * a_ref(1, 1) - wr * d1, dabs(r__1)) + (r__2 = ca * a_ref(1, 2), dabs(r__2)), r__9 = (r__3 = ca * a_ref(2, 1), dabs(r__3)) + (r__4 = ca * a_ref(2, 2) - wr * d2, dabs( r__4)); /* Computing MAX */ r__10 = (r__5 = x_ref(1, 1), dabs( r__5)), r__11 = (r__6 = x_ref( 2, 1), dabs(r__6)); r__7 = eps * (dmax(r__8,r__9) * dmax( r__10,r__11)); den = dmax(r__7,smlnum); } else { /* Computing MAX Computing MAX Computing MAX */ r__10 = (r__1 = ca * a_ref(1, 1) - wr * d1, dabs(r__1)) + (r__2 = ca * a_ref(1, 2), dabs(r__2)), r__11 = (r__3 = ca * a_ref(2, 1), dabs(r__3)) + (r__4 = ca * a_ref(2, 2) - wr * d2, dabs( r__4)); r__8 = smin / eps, r__9 = dmax(r__10, r__11); /* Computing MAX */ r__12 = (r__5 = x_ref(1, 1), dabs( r__5)), r__13 = (r__6 = x_ref( 2, 1), dabs(r__6)); r__7 = eps * (dmax(r__8,r__9) * dmax( r__12,r__13)); den = dmax(r__7,smlnum); } res /= den; if ((r__1 = x_ref(1, 1), dabs(r__1)) < unfl && (r__2 = x_ref(2, 1), dabs( r__2)) < unfl && (r__3 = b_ref(1, 1), dabs(r__3)) + (r__4 = b_ref(2, 1), dabs(r__4)) <= smlnum * (( r__5 = ca * a_ref(1, 1) - wr * d1, dabs(r__5)) + (r__6 = ca * a_ref( 1, 2), dabs(r__6)) + (r__7 = ca * a_ref(2, 1), dabs(r__7)) + (r__8 = ca * a_ref(2, 2) - wr * d2, dabs( r__8)))) { res = 0.f; } if (scale > 1.f) { res += 1.f / eps; } /* Computing MAX */ r__4 = (r__1 = x_ref(1, 1), dabs(r__1)), r__5 = (r__2 = x_ref(2, 1), dabs( r__2)); res += (r__3 = xnorm - dmax(r__4,r__5), dabs(r__3)) / dmax(smlnum,xnorm) / eps; if (info != 0 && info != 1) { res += 1.f / eps; } ++(*knt); if (res > *rmax) { *lmax = *knt; *rmax = res; } /* L80: */ } /* L90: */ } /* L100: */ } na = 2; nw = 2; for (ia = 1; ia <= 3; ++ia) { a_ref(1, 1) = vab[ia - 1] * 2.f; a_ref(1, 2) = vab[ia - 1] * -3.f; a_ref(2, 1) = vab[ia - 1] * -7.f; a_ref(2, 2) = vab[ia - 1] * 21.f; for (ib = 1; ib <= 3; ++ib) { b_ref(1, 1) = vab[ib - 1]; b_ref(2, 1) = vab[ib - 1] * -2.f; b_ref(1, 2) = vab[ib - 1] * 4.f; b_ref(2, 2) = vab[ib - 1] * -7.f; for (iwr = 1; iwr <= 4; ++iwr) { if (d1 == 1.f && d2 == 1.f && ca == 1.f) { wr = vwr[iwr - 1] * a_ref(1, 1); } else { wr = vwr[iwr - 1]; } for (iwi = 1; iwi <= 4; ++iwi) { if (d1 == 1.f && d2 == 1.f && ca == 1.f) { wi = vwi[iwi - 1] * a_ref(1, 1); } else { wi = vwi[iwi - 1]; } slaln2_(<rans[itrans], &na, &nw, & smin, &ca, a, &c__2, &d1, &d2, b, &c__2, &wr, &wi, x, &c__2, &scale, &xnorm, &info); if (info < 0) { ++ninfo[1]; } if (info > 0) { ++ninfo[2]; } if (itrans == 1) { tmp = a_ref(1, 2); a_ref(1, 2) = a_ref(2, 1); a_ref(2, 1) = tmp; } res = (r__1 = (ca * a_ref(1, 1) - wr * d1) * x_ref(1, 1) + ca * a_ref(1, 2) * x_ref(2, 1) + wi * d1 * x_ref(1, 2) - scale * b_ref(1, 1), dabs(r__1)); res += (r__1 = (ca * a_ref(1, 1) - wr * d1) * x_ref(1, 2) + ca * a_ref(1, 2) * x_ref(2, 2) - wi * d1 * x_ref(1, 1) - scale * b_ref(1, 2), dabs(r__1)); res += (r__1 = ca * a_ref(2, 1) * x_ref(1, 1) + (ca * a_ref(2, 2) - wr * d2) * x_ref(2, 1) + wi * d2 * x_ref(2, 2) - scale * b_ref(2, 1), dabs(r__1)); res += (r__1 = ca * a_ref(2, 1) * x_ref(1, 2) + (ca * a_ref(2, 2) - wr * d2) * x_ref(2, 2) - wi * d2 * x_ref(2, 1) - scale * b_ref(2, 2), dabs(r__1)); if (info == 0) { /* Computing MAX Computing MAX */ r__12 = (r__1 = ca * a_ref(1, 1) - wr * d1, dabs(r__1)) + ( r__2 = ca * a_ref(1, 2), dabs(r__2)) + (r__3 = wi * d1, dabs(r__3)), r__13 = (r__4 = ca * a_ref(2, 1), dabs(r__4)) + (r__5 = ca * a_ref(2, 2) - wr * d2, dabs(r__5)) + (r__6 = wi * d2, dabs(r__6)); /* Computing MAX */ r__14 = (r__7 = x_ref(1, 1), dabs( r__7)) + (r__8 = x_ref(2, 1), dabs(r__8)), r__15 = ( r__9 = x_ref(1, 2), dabs( r__9)) + (r__10 = x_ref(2, 2), dabs(r__10)); r__11 = eps * (dmax(r__12,r__13) * dmax(r__14,r__15)); den = dmax(r__11,smlnum); } else { /* Computing MAX Computing MAX Computing MAX */ r__14 = (r__1 = ca * a_ref(1, 1) - wr * d1, dabs(r__1)) + ( r__2 = ca * a_ref(1, 2), dabs(r__2)) + (r__3 = wi * d1, dabs(r__3)), r__15 = (r__4 = ca * a_ref(2, 1), dabs(r__4)) + (r__5 = ca * a_ref(2, 2) - wr * d2, dabs(r__5)) + (r__6 = wi * d2, dabs(r__6)); r__12 = smin / eps, r__13 = dmax( r__14,r__15); /* Computing MAX */ r__16 = (r__7 = x_ref(1, 1), dabs( r__7)) + (r__8 = x_ref(2, 1), dabs(r__8)), r__17 = ( r__9 = x_ref(1, 2), dabs( r__9)) + (r__10 = x_ref(2, 2), dabs(r__10)); r__11 = eps * (dmax(r__12,r__13) * dmax(r__16,r__17)); den = dmax(r__11,smlnum); } res /= den; if ((r__1 = x_ref(1, 1), dabs(r__1)) < unfl && (r__2 = x_ref(2, 1), dabs(r__2)) < unfl && (r__3 = x_ref(1, 2), dabs(r__3)) < unfl && (r__4 = x_ref(2, 2), dabs(r__4)) < unfl && (r__5 = b_ref(1, 1), dabs(r__5)) + ( r__6 = b_ref(2, 1), dabs(r__6) ) <= smlnum * ((r__7 = ca * a_ref(1, 1) - wr * d1, dabs( r__7)) + (r__8 = ca * a_ref(1, 2), dabs(r__8)) + (r__9 = ca * a_ref(2, 1), dabs(r__9)) + ( r__10 = ca * a_ref(2, 2) - wr * d2, dabs(r__10)) + (r__11 = wi * d2, dabs(r__11)) + ( r__12 = wi * d1, dabs(r__12))) ) { res = 0.f; } if (scale > 1.f) { res += 1.f / eps; } /* Computing MAX */ r__6 = (r__1 = x_ref(1, 1), dabs(r__1) ) + (r__2 = x_ref(1, 2), dabs( r__2)), r__7 = (r__3 = x_ref( 2, 1), dabs(r__3)) + (r__4 = x_ref(2, 2), dabs(r__4)); res += (r__5 = xnorm - dmax(r__6,r__7) , dabs(r__5)) / dmax(smlnum, xnorm) / eps; if (info != 0 && info != 1) { res += 1.f / eps; } ++(*knt); if (res > *rmax) { *lmax = *knt; *rmax = res; } /* L110: */ } /* L120: */ } /* L130: */ } /* L140: */ } /* L150: */ } /* L160: */ } /* L170: */ } /* L180: */ } /* L190: */ } return 0; /* End of SGET31 */ } /* sget31_ */
/* Subroutine */ int stgevc_(char *side, char *howmny, logical *select, integer *n, real *s, integer *lds, real *p, integer *ldp, real *vl, integer *ldvl, real *vr, integer *ldvr, integer *mm, integer *m, real *work, integer *info) { /* System generated locals */ integer p_dim1, p_offset, s_dim1, s_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4, i__5; real r__1, r__2, r__3, r__4, r__5, r__6; /* Local variables */ integer i__, j, ja, jc, je, na, im, jr, jw, nw; real big; logical lsa, lsb; real ulp, sum[4] /* was [2][2] */; integer ibeg, ieig, iend; real dmin__, temp, xmax, sump[4] /* was [2][2] */, sums[4] /* was [2][2] */, cim2a, cim2b, cre2a, cre2b; real temp2, bdiag[2], acoef, scale; logical ilall; integer iside; real sbeta; logical il2by2; integer iinfo; real small; logical compl; real anorm, bnorm; logical compr; real temp2i, temp2r; logical ilabad, ilbbad; real acoefa, bcoefa, cimaga, cimagb; logical ilback; real bcoefi, ascale, bscale, creala, crealb, bcoefr; real salfar, safmin; real xscale, bignum; logical ilcomp, ilcplx; integer ihwmny; /* -- LAPACK routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* STGEVC computes some or all of the right and/or left eigenvectors of */ /* a pair of real matrices (S,P), where S is a quasi-triangular matrix */ /* and P is upper triangular. Matrix pairs of this type are produced by */ /* the generalized Schur factorization of a matrix pair (A,B): */ /* A = Q*S*Z**T, B = Q*P*Z**T */ /* as computed by SGGHRD + SHGEQZ. */ /* The right eigenvector x and the left eigenvector y of (S,P) */ /* corresponding to an eigenvalue w are defined by: */ /* S*x = w*P*x, (y**H)*S = w*(y**H)*P, */ /* where y**H denotes the conjugate tranpose of y. */ /* The eigenvalues are not input to this routine, but are computed */ /* directly from the diagonal blocks of S and P. */ /* This routine returns the matrices X and/or Y of right and left */ /* eigenvectors of (S,P), or the products Z*X and/or Q*Y, */ /* where Z and Q are input matrices. */ /* If Q and Z are the orthogonal factors from the generalized Schur */ /* factorization of a matrix pair (A,B), then Z*X and Q*Y */ /* are the matrices of right and left eigenvectors of (A,B). */ /* Arguments */ /* ========= */ /* SIDE (input) CHARACTER*1 */ /* = 'R': compute right eigenvectors only; */ /* = 'L': compute left eigenvectors only; */ /* = 'B': compute both right and left eigenvectors. */ /* HOWMNY (input) CHARACTER*1 */ /* = 'A': compute all right and/or left eigenvectors; */ /* = 'B': compute all right and/or left eigenvectors, */ /* backtransformed by the matrices in VR and/or VL; */ /* = 'S': compute selected right and/or left eigenvectors, */ /* specified by the logical array SELECT. */ /* SELECT (input) LOGICAL array, dimension (N) */ /* If HOWMNY='S', SELECT specifies the eigenvectors to be */ /* computed. If w(j) is a real eigenvalue, the corresponding */ /* If w(j) and w(j+1) are the real and imaginary parts of a */ /* complex eigenvalue, the corresponding complex eigenvector */ /* is computed if either SELECT(j) or SELECT(j+1) is .TRUE., */ /* and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is */ /* Not referenced if HOWMNY = 'A' or 'B'. */ /* N (input) INTEGER */ /* The order of the matrices S and P. N >= 0. */ /* S (input) REAL array, dimension (LDS,N) */ /* The upper quasi-triangular matrix S from a generalized Schur */ /* factorization, as computed by SHGEQZ. */ /* LDS (input) INTEGER */ /* The leading dimension of array S. LDS >= max(1,N). */ /* P (input) REAL array, dimension (LDP,N) */ /* The upper triangular matrix P from a generalized Schur */ /* factorization, as computed by SHGEQZ. */ /* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks */ /* of S must be in positive diagonal form. */ /* LDP (input) INTEGER */ /* The leading dimension of array P. LDP >= max(1,N). */ /* VL (input/output) REAL array, dimension (LDVL,MM) */ /* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */ /* contain an N-by-N matrix Q (usually the orthogonal matrix Q */ /* of left Schur vectors returned by SHGEQZ). */ /* On exit, if SIDE = 'L' or 'B', VL contains: */ /* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); */ /* if HOWMNY = 'B', the matrix Q*Y; */ /* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by */ /* SELECT, stored consecutively in the columns of */ /* VL, in the same order as their eigenvalues. */ /* A complex eigenvector corresponding to a complex eigenvalue */ /* is stored in two consecutive columns, the first holding the */ /* real part, and the second the imaginary part. */ /* Not referenced if SIDE = 'R'. */ /* LDVL (input) INTEGER */ /* The leading dimension of array VL. LDVL >= 1, and if */ /* SIDE = 'L' or 'B', LDVL >= N. */ /* VR (input/output) REAL array, dimension (LDVR,MM) */ /* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */ /* contain an N-by-N matrix Z (usually the orthogonal matrix Z */ /* of right Schur vectors returned by SHGEQZ). */ /* On exit, if SIDE = 'R' or 'B', VR contains: */ /* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); */ /* if HOWMNY = 'B' or 'b', the matrix Z*X; */ /* if HOWMNY = 'S' or 's', the right eigenvectors of (S,P) */ /* specified by SELECT, stored consecutively in the */ /* columns of VR, in the same order as their */ /* eigenvalues. */ /* A complex eigenvector corresponding to a complex eigenvalue */ /* is stored in two consecutive columns, the first holding the */ /* real part and the second the imaginary part. */ /* Not referenced if SIDE = 'L'. */ /* LDVR (input) INTEGER */ /* The leading dimension of the array VR. LDVR >= 1, and if */ /* SIDE = 'R' or 'B', LDVR >= N. */ /* MM (input) INTEGER */ /* The number of columns in the arrays VL and/or VR. MM >= M. */ /* M (output) INTEGER */ /* The number of columns in the arrays VL and/or VR actually */ /* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M */ /* is set to N. Each selected real eigenvector occupies one */ /* column and each selected complex eigenvector occupies two */ /* columns. */ /* WORK (workspace) REAL array, dimension (6*N) */ /* INFO (output) INTEGER */ /* = 0: successful exit. */ /* < 0: if INFO = -i, the i-th argument had an illegal value. */ /* > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex */ /* eigenvalue. */ /* Further Details */ /* =============== */ /* Allocation of workspace: */ /* ---------- -- --------- */ /* WORK( j ) = 1-norm of j-th column of A, above the diagonal */ /* WORK( N+j ) = 1-norm of j-th column of B, above the diagonal */ /* WORK( 2*N+1:3*N ) = real part of eigenvector */ /* WORK( 3*N+1:4*N ) = imaginary part of eigenvector */ /* WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector */ /* WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector */ /* Rowwise vs. columnwise solution methods: */ /* ------- -- ---------- -------- ------- */ /* Finding a generalized eigenvector consists basically of solving the */ /* singular triangular system */ /* (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left) */ /* Consider finding the i-th right eigenvector (assume all eigenvalues */ /* are real). The equation to be solved is: */ /* n i */ /* 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1 */ /* k=j k=j */ /* where C = (A - w B) (The components v(i+1:n) are 0.) */ /* The "rowwise" method is: */ /* (1) v(i) := 1 */ /* for j = i-1,. . .,1: */ /* i */ /* (2) compute s = - sum C(j,k) v(k) and */ /* k=j+1 */ /* (3) v(j) := s / C(j,j) */ /* Step 2 is sometimes called the "dot product" step, since it is an */ /* inner product between the j-th row and the portion of the eigenvector */ /* that has been computed so far. */ /* The "columnwise" method consists basically in doing the sums */ /* for all the rows in parallel. As each v(j) is computed, the */ /* contribution of v(j) times the j-th column of C is added to the */ /* partial sums. Since FORTRAN arrays are stored columnwise, this has */ /* the advantage that at each step, the elements of C that are accessed */ /* are adjacent to one another, whereas with the rowwise method, the */ /* elements accessed at a step are spaced LDS (and LDP) words apart. */ /* When finding left eigenvectors, the matrix in question is the */ /* transpose of the one in storage, so the rowwise method then */ /* actually accesses columns of A and B at each step, and so is the */ /* preferred method. */ /* ===================================================================== */ /* Decode and Test the input parameters */ /* Parameter adjustments */ --select; s_dim1 = *lds; s_offset = 1 + s_dim1; s -= s_offset; p_dim1 = *ldp; p_offset = 1 + p_dim1; p -= p_offset; vl_dim1 = *ldvl; vl_offset = 1 + vl_dim1; vl -= vl_offset; vr_dim1 = *ldvr; vr_offset = 1 + vr_dim1; vr -= vr_offset; --work; /* Function Body */ if (lsame_(howmny, "A")) { ihwmny = 1; ilall = TRUE_; ilback = FALSE_; } else if (lsame_(howmny, "S")) { ihwmny = 2; ilall = FALSE_; ilback = FALSE_; } else if (lsame_(howmny, "B")) { ihwmny = 3; ilall = TRUE_; ilback = TRUE_; } else { ihwmny = -1; ilall = TRUE_; } if (lsame_(side, "R")) { iside = 1; compl = FALSE_; compr = TRUE_; } else if (lsame_(side, "L")) { iside = 2; compl = TRUE_; compr = FALSE_; } else if (lsame_(side, "B")) { iside = 3; compl = TRUE_; compr = TRUE_; } else { iside = -1; } *info = 0; if (iside < 0) { *info = -1; } else if (ihwmny < 0) { *info = -2; } else if (*n < 0) { *info = -4; } else if (*lds < max(1,*n)) { *info = -6; } else if (*ldp < max(1,*n)) { *info = -8; } if (*info != 0) { i__1 = -(*info); xerbla_("STGEVC", &i__1); return 0; } /* Count the number of eigenvectors to be computed */ if (! ilall) { im = 0; ilcplx = FALSE_; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (ilcplx) { ilcplx = FALSE_; goto L10; } if (j < *n) { if (s[j + 1 + j * s_dim1] != 0.f) { ilcplx = TRUE_; } } if (ilcplx) { if (select[j] || select[j + 1]) { im += 2; } } else { if (select[j]) { ++im; } } L10: ; } } else { im = *n; } /* Check 2-by-2 diagonal blocks of A, B */ ilabad = FALSE_; ilbbad = FALSE_; i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { if (s[j + 1 + j * s_dim1] != 0.f) { if (p[j + j * p_dim1] == 0.f || p[j + 1 + (j + 1) * p_dim1] == 0.f || p[j + (j + 1) * p_dim1] != 0.f) { ilbbad = TRUE_; } if (j < *n - 1) { if (s[j + 2 + (j + 1) * s_dim1] != 0.f) { ilabad = TRUE_; } } } } if (ilabad) { *info = -5; } else if (ilbbad) { *info = -7; } else if (compl && *ldvl < *n || *ldvl < 1) { *info = -10; } else if (compr && *ldvr < *n || *ldvr < 1) { *info = -12; } else if (*mm < im) { *info = -13; } if (*info != 0) { i__1 = -(*info); xerbla_("STGEVC", &i__1); return 0; } /* Quick return if possible */ *m = im; if (*n == 0) { return 0; } /* Machine Constants */ safmin = slamch_("Safe minimum"); big = 1.f / safmin; slabad_(&safmin, &big); ulp = slamch_("Epsilon") * slamch_("Base"); small = safmin * *n / ulp; big = 1.f / small; bignum = 1.f / (safmin * *n); /* Compute the 1-norm of each column of the strictly upper triangular */ /* part (i.e., excluding all elements belonging to the diagonal */ /* blocks) of A and B to check for possible overflow in the */ /* triangular solver. */ anorm = (r__1 = s[s_dim1 + 1], dabs(r__1)); if (*n > 1) { anorm += (r__1 = s[s_dim1 + 2], dabs(r__1)); } bnorm = (r__1 = p[p_dim1 + 1], dabs(r__1)); work[1] = 0.f; work[*n + 1] = 0.f; i__1 = *n; for (j = 2; j <= i__1; ++j) { temp = 0.f; temp2 = 0.f; if (s[j + (j - 1) * s_dim1] == 0.f) { iend = j - 1; } else { iend = j - 2; } i__2 = iend; for (i__ = 1; i__ <= i__2; ++i__) { temp += (r__1 = s[i__ + j * s_dim1], dabs(r__1)); temp2 += (r__1 = p[i__ + j * p_dim1], dabs(r__1)); } work[j] = temp; work[*n + j] = temp2; /* Computing MIN */ i__3 = j + 1; i__2 = min(i__3,*n); for (i__ = iend + 1; i__ <= i__2; ++i__) { temp += (r__1 = s[i__ + j * s_dim1], dabs(r__1)); temp2 += (r__1 = p[i__ + j * p_dim1], dabs(r__1)); } anorm = dmax(anorm,temp); bnorm = dmax(bnorm,temp2); } ascale = 1.f / dmax(anorm,safmin); bscale = 1.f / dmax(bnorm,safmin); /* Left eigenvectors */ if (compl) { ieig = 0; /* Main loop over eigenvalues */ ilcplx = FALSE_; i__1 = *n; for (je = 1; je <= i__1; ++je) { /* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or */ /* (b) this would be the second of a complex pair. */ /* Check for complex eigenvalue, so as to be sure of which */ /* entry(-ies) of SELECT to look at. */ if (ilcplx) { ilcplx = FALSE_; goto L220; } nw = 1; if (je < *n) { if (s[je + 1 + je * s_dim1] != 0.f) { ilcplx = TRUE_; nw = 2; } } if (ilall) { ilcomp = TRUE_; } else if (ilcplx) { ilcomp = select[je] || select[je + 1]; } else { ilcomp = select[je]; } if (! ilcomp) { goto L220; } /* Decide if (a) singular pencil, (b) real eigenvalue, or */ /* (c) complex eigenvalue. */ if (! ilcplx) { if ((r__1 = s[je + je * s_dim1], dabs(r__1)) <= safmin && ( r__2 = p[je + je * p_dim1], dabs(r__2)) <= safmin) { /* Singular matrix pencil -- return unit eigenvector */ ++ieig; i__2 = *n; for (jr = 1; jr <= i__2; ++jr) { vl[jr + ieig * vl_dim1] = 0.f; } vl[ieig + ieig * vl_dim1] = 1.f; goto L220; } } /* Clear vector */ i__2 = nw * *n; for (jr = 1; jr <= i__2; ++jr) { work[(*n << 1) + jr] = 0.f; } /* T */ /* Compute coefficients in ( a A - b B ) y = 0 */ /* a is ACOEF */ /* b is BCOEFR + i*BCOEFI */ if (! ilcplx) { /* Real eigenvalue */ /* Computing MAX */ r__3 = (r__1 = s[je + je * s_dim1], dabs(r__1)) * ascale, r__4 = (r__2 = p[je + je * p_dim1], dabs(r__2)) * bscale, r__3 = max(r__3,r__4); temp = 1.f / dmax(r__3,safmin); salfar = temp * s[je + je * s_dim1] * ascale; sbeta = temp * p[je + je * p_dim1] * bscale; acoef = sbeta * ascale; bcoefr = salfar * bscale; bcoefi = 0.f; /* Scale to avoid underflow */ scale = 1.f; lsa = dabs(sbeta) >= safmin && dabs(acoef) < small; lsb = dabs(salfar) >= safmin && dabs(bcoefr) < small; if (lsa) { scale = small / dabs(sbeta) * dmin(anorm,big); } if (lsb) { /* Computing MAX */ r__1 = scale, r__2 = small / dabs(salfar) * dmin(bnorm, big); scale = dmax(r__1,r__2); } if (lsa || lsb) { /* Computing MIN */ /* Computing MAX */ r__3 = 1.f, r__4 = dabs(acoef), r__3 = max(r__3,r__4), r__4 = dabs(bcoefr); r__1 = scale, r__2 = 1.f / (safmin * dmax(r__3,r__4)); scale = dmin(r__1,r__2); if (lsa) { acoef = ascale * (scale * sbeta); } else { acoef = scale * acoef; } if (lsb) { bcoefr = bscale * (scale * salfar); } else { bcoefr = scale * bcoefr; } } acoefa = dabs(acoef); bcoefa = dabs(bcoefr); /* First component is 1 */ work[(*n << 1) + je] = 1.f; xmax = 1.f; } else { /* Complex eigenvalue */ r__1 = safmin * 100.f; slag2_(&s[je + je * s_dim1], lds, &p[je + je * p_dim1], ldp, & r__1, &acoef, &temp, &bcoefr, &temp2, &bcoefi); bcoefi = -bcoefi; if (bcoefi == 0.f) { *info = je; return 0; } /* Scale to avoid over/underflow */ acoefa = dabs(acoef); bcoefa = dabs(bcoefr) + dabs(bcoefi); scale = 1.f; if (acoefa * ulp < safmin && acoefa >= safmin) { scale = safmin / ulp / acoefa; } if (bcoefa * ulp < safmin && bcoefa >= safmin) { /* Computing MAX */ r__1 = scale, r__2 = safmin / ulp / bcoefa; scale = dmax(r__1,r__2); } if (safmin * acoefa > ascale) { scale = ascale / (safmin * acoefa); } if (safmin * bcoefa > bscale) { /* Computing MIN */ r__1 = scale, r__2 = bscale / (safmin * bcoefa); scale = dmin(r__1,r__2); } if (scale != 1.f) { acoef = scale * acoef; acoefa = dabs(acoef); bcoefr = scale * bcoefr; bcoefi = scale * bcoefi; bcoefa = dabs(bcoefr) + dabs(bcoefi); } /* Compute first two components of eigenvector */ temp = acoef * s[je + 1 + je * s_dim1]; temp2r = acoef * s[je + je * s_dim1] - bcoefr * p[je + je * p_dim1]; temp2i = -bcoefi * p[je + je * p_dim1]; if (dabs(temp) > dabs(temp2r) + dabs(temp2i)) { work[(*n << 1) + je] = 1.f; work[*n * 3 + je] = 0.f; work[(*n << 1) + je + 1] = -temp2r / temp; work[*n * 3 + je + 1] = -temp2i / temp; } else { work[(*n << 1) + je + 1] = 1.f; work[*n * 3 + je + 1] = 0.f; temp = acoef * s[je + (je + 1) * s_dim1]; work[(*n << 1) + je] = (bcoefr * p[je + 1 + (je + 1) * p_dim1] - acoef * s[je + 1 + (je + 1) * s_dim1]) / temp; work[*n * 3 + je] = bcoefi * p[je + 1 + (je + 1) * p_dim1] / temp; } /* Computing MAX */ r__5 = (r__1 = work[(*n << 1) + je], dabs(r__1)) + (r__2 = work[*n * 3 + je], dabs(r__2)), r__6 = (r__3 = work[(* n << 1) + je + 1], dabs(r__3)) + (r__4 = work[*n * 3 + je + 1], dabs(r__4)); xmax = dmax(r__5,r__6); } /* Computing MAX */ r__1 = ulp * acoefa * anorm, r__2 = ulp * bcoefa * bnorm, r__1 = max(r__1,r__2); dmin__ = dmax(r__1,safmin); /* T */ /* Triangular solve of (a A - b B) y = 0 */ /* T */ /* (rowwise in (a A - b B) , or columnwise in (a A - b B) ) */ il2by2 = FALSE_; i__2 = *n; for (j = je + nw; j <= i__2; ++j) { if (il2by2) { il2by2 = FALSE_; goto L160; } na = 1; bdiag[0] = p[j + j * p_dim1]; if (j < *n) { if (s[j + 1 + j * s_dim1] != 0.f) { il2by2 = TRUE_; bdiag[1] = p[j + 1 + (j + 1) * p_dim1]; na = 2; } } /* Check whether scaling is necessary for dot products */ xscale = 1.f / dmax(1.f,xmax); /* Computing MAX */ r__1 = work[j], r__2 = work[*n + j], r__1 = max(r__1,r__2), r__2 = acoefa * work[j] + bcoefa * work[*n + j]; temp = dmax(r__1,r__2); if (il2by2) { /* Computing MAX */ r__1 = temp, r__2 = work[j + 1], r__1 = max(r__1,r__2), r__2 = work[*n + j + 1], r__1 = max(r__1,r__2), r__2 = acoefa * work[j + 1] + bcoefa * work[*n + j + 1]; temp = dmax(r__1,r__2); } if (temp > bignum * xscale) { i__3 = nw - 1; for (jw = 0; jw <= i__3; ++jw) { i__4 = j - 1; for (jr = je; jr <= i__4; ++jr) { work[(jw + 2) * *n + jr] = xscale * work[(jw + 2) * *n + jr]; } } xmax *= xscale; } /* Compute dot products */ /* j-1 */ /* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) */ /* k=je */ /* To reduce the op count, this is done as */ /* _ j-1 _ j-1 */ /* a*conjg( sum S(k,j)*x(k) ) - b*conjg( sum P(k,j)*x(k) ) */ /* k=je k=je */ /* which may cause underflow problems if A or B are close */ /* to underflow. (E.g., less than SMALL.) */ /* A series of compiler directives to defeat vectorization */ /* for the next loop */ /* $PL$ CMCHAR=' ' */ /* DIR$ NEXTSCALAR */ /* $DIR SCALAR */ /* DIR$ NEXT SCALAR */ /* VD$L NOVECTOR */ /* DEC$ NOVECTOR */ /* VD$ NOVECTOR */ /* VDIR NOVECTOR */ /* VOCL LOOP,SCALAR */ /* IBM PREFER SCALAR */ /* $PL$ CMCHAR='*' */ i__3 = nw; for (jw = 1; jw <= i__3; ++jw) { /* $PL$ CMCHAR=' ' */ /* DIR$ NEXTSCALAR */ /* $DIR SCALAR */ /* DIR$ NEXT SCALAR */ /* VD$L NOVECTOR */ /* DEC$ NOVECTOR */ /* VD$ NOVECTOR */ /* VDIR NOVECTOR */ /* VOCL LOOP,SCALAR */ /* IBM PREFER SCALAR */ /* $PL$ CMCHAR='*' */ i__4 = na; for (ja = 1; ja <= i__4; ++ja) { sums[ja + (jw << 1) - 3] = 0.f; sump[ja + (jw << 1) - 3] = 0.f; i__5 = j - 1; for (jr = je; jr <= i__5; ++jr) { sums[ja + (jw << 1) - 3] += s[jr + (j + ja - 1) * s_dim1] * work[(jw + 1) * *n + jr]; sump[ja + (jw << 1) - 3] += p[jr + (j + ja - 1) * p_dim1] * work[(jw + 1) * *n + jr]; } } } /* $PL$ CMCHAR=' ' */ /* DIR$ NEXTSCALAR */ /* $DIR SCALAR */ /* DIR$ NEXT SCALAR */ /* VD$L NOVECTOR */ /* DEC$ NOVECTOR */ /* VD$ NOVECTOR */ /* VDIR NOVECTOR */ /* VOCL LOOP,SCALAR */ /* IBM PREFER SCALAR */ /* $PL$ CMCHAR='*' */ i__3 = na; for (ja = 1; ja <= i__3; ++ja) { if (ilcplx) { sum[ja - 1] = -acoef * sums[ja - 1] + bcoefr * sump[ ja - 1] - bcoefi * sump[ja + 1]; sum[ja + 1] = -acoef * sums[ja + 1] + bcoefr * sump[ ja + 1] + bcoefi * sump[ja - 1]; } else { sum[ja - 1] = -acoef * sums[ja - 1] + bcoefr * sump[ ja - 1]; } } /* T */ /* Solve ( a A - b B ) y = SUM(,) */ /* with scaling and perturbation of the denominator */ slaln2_(&c_true, &na, &nw, &dmin__, &acoef, &s[j + j * s_dim1] , lds, bdiag, &bdiag[1], sum, &c__2, &bcoefr, &bcoefi, &work[(*n << 1) + j], n, &scale, &temp, &iinfo); if (scale < 1.f) { i__3 = nw - 1; for (jw = 0; jw <= i__3; ++jw) { i__4 = j - 1; for (jr = je; jr <= i__4; ++jr) { work[(jw + 2) * *n + jr] = scale * work[(jw + 2) * *n + jr]; } } xmax = scale * xmax; } xmax = dmax(xmax,temp); L160: ; } /* Copy eigenvector to VL, back transforming if */ /* HOWMNY='B'. */ ++ieig; if (ilback) { i__2 = nw - 1; for (jw = 0; jw <= i__2; ++jw) { i__3 = *n + 1 - je; sgemv_("N", n, &i__3, &c_b34, &vl[je * vl_dim1 + 1], ldvl, &work[(jw + 2) * *n + je], &c__1, &c_b36, &work[( jw + 4) * *n + 1], &c__1); } slacpy_(" ", n, &nw, &work[(*n << 2) + 1], n, &vl[je * vl_dim1 + 1], ldvl); ibeg = 1; } else { slacpy_(" ", n, &nw, &work[(*n << 1) + 1], n, &vl[ieig * vl_dim1 + 1], ldvl); ibeg = je; } /* Scale eigenvector */ xmax = 0.f; if (ilcplx) { i__2 = *n; for (j = ibeg; j <= i__2; ++j) { /* Computing MAX */ r__3 = xmax, r__4 = (r__1 = vl[j + ieig * vl_dim1], dabs( r__1)) + (r__2 = vl[j + (ieig + 1) * vl_dim1], dabs(r__2)); xmax = dmax(r__3,r__4); } } else { i__2 = *n; for (j = ibeg; j <= i__2; ++j) { /* Computing MAX */ r__2 = xmax, r__3 = (r__1 = vl[j + ieig * vl_dim1], dabs( r__1)); xmax = dmax(r__2,r__3); } } if (xmax > safmin) { xscale = 1.f / xmax; i__2 = nw - 1; for (jw = 0; jw <= i__2; ++jw) { i__3 = *n; for (jr = ibeg; jr <= i__3; ++jr) { vl[jr + (ieig + jw) * vl_dim1] = xscale * vl[jr + ( ieig + jw) * vl_dim1]; } } } ieig = ieig + nw - 1; L220: ; } } /* Right eigenvectors */ if (compr) { ieig = im + 1; /* Main loop over eigenvalues */ ilcplx = FALSE_; for (je = *n; je >= 1; --je) { /* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or */ /* (b) this would be the second of a complex pair. */ /* Check for complex eigenvalue, so as to be sure of which */ /* entry(-ies) of SELECT to look at -- if complex, SELECT(JE) */ /* or SELECT(JE-1). */ /* If this is a complex pair, the 2-by-2 diagonal block */ /* corresponding to the eigenvalue is in rows/columns JE-1:JE */ if (ilcplx) { ilcplx = FALSE_; goto L500; } nw = 1; if (je > 1) { if (s[je + (je - 1) * s_dim1] != 0.f) { ilcplx = TRUE_; nw = 2; } } if (ilall) { ilcomp = TRUE_; } else if (ilcplx) { ilcomp = select[je] || select[je - 1]; } else { ilcomp = select[je]; } if (! ilcomp) { goto L500; } /* Decide if (a) singular pencil, (b) real eigenvalue, or */ /* (c) complex eigenvalue. */ if (! ilcplx) { if ((r__1 = s[je + je * s_dim1], dabs(r__1)) <= safmin && ( r__2 = p[je + je * p_dim1], dabs(r__2)) <= safmin) { /* Singular matrix pencil -- unit eigenvector */ --ieig; i__1 = *n; for (jr = 1; jr <= i__1; ++jr) { vr[jr + ieig * vr_dim1] = 0.f; } vr[ieig + ieig * vr_dim1] = 1.f; goto L500; } } /* Clear vector */ i__1 = nw - 1; for (jw = 0; jw <= i__1; ++jw) { i__2 = *n; for (jr = 1; jr <= i__2; ++jr) { work[(jw + 2) * *n + jr] = 0.f; } } /* Compute coefficients in ( a A - b B ) x = 0 */ /* a is ACOEF */ /* b is BCOEFR + i*BCOEFI */ if (! ilcplx) { /* Real eigenvalue */ /* Computing MAX */ r__3 = (r__1 = s[je + je * s_dim1], dabs(r__1)) * ascale, r__4 = (r__2 = p[je + je * p_dim1], dabs(r__2)) * bscale, r__3 = max(r__3,r__4); temp = 1.f / dmax(r__3,safmin); salfar = temp * s[je + je * s_dim1] * ascale; sbeta = temp * p[je + je * p_dim1] * bscale; acoef = sbeta * ascale; bcoefr = salfar * bscale; bcoefi = 0.f; /* Scale to avoid underflow */ scale = 1.f; lsa = dabs(sbeta) >= safmin && dabs(acoef) < small; lsb = dabs(salfar) >= safmin && dabs(bcoefr) < small; if (lsa) { scale = small / dabs(sbeta) * dmin(anorm,big); } if (lsb) { /* Computing MAX */ r__1 = scale, r__2 = small / dabs(salfar) * dmin(bnorm, big); scale = dmax(r__1,r__2); } if (lsa || lsb) { /* Computing MIN */ /* Computing MAX */ r__3 = 1.f, r__4 = dabs(acoef), r__3 = max(r__3,r__4), r__4 = dabs(bcoefr); r__1 = scale, r__2 = 1.f / (safmin * dmax(r__3,r__4)); scale = dmin(r__1,r__2); if (lsa) { acoef = ascale * (scale * sbeta); } else { acoef = scale * acoef; } if (lsb) { bcoefr = bscale * (scale * salfar); } else { bcoefr = scale * bcoefr; } } acoefa = dabs(acoef); bcoefa = dabs(bcoefr); /* First component is 1 */ work[(*n << 1) + je] = 1.f; xmax = 1.f; /* Compute contribution from column JE of A and B to sum */ /* (See "Further Details", above.) */ i__1 = je - 1; for (jr = 1; jr <= i__1; ++jr) { work[(*n << 1) + jr] = bcoefr * p[jr + je * p_dim1] - acoef * s[jr + je * s_dim1]; } } else { /* Complex eigenvalue */ r__1 = safmin * 100.f; slag2_(&s[je - 1 + (je - 1) * s_dim1], lds, &p[je - 1 + (je - 1) * p_dim1], ldp, &r__1, &acoef, &temp, &bcoefr, & temp2, &bcoefi); if (bcoefi == 0.f) { *info = je - 1; return 0; } /* Scale to avoid over/underflow */ acoefa = dabs(acoef); bcoefa = dabs(bcoefr) + dabs(bcoefi); scale = 1.f; if (acoefa * ulp < safmin && acoefa >= safmin) { scale = safmin / ulp / acoefa; } if (bcoefa * ulp < safmin && bcoefa >= safmin) { /* Computing MAX */ r__1 = scale, r__2 = safmin / ulp / bcoefa; scale = dmax(r__1,r__2); } if (safmin * acoefa > ascale) { scale = ascale / (safmin * acoefa); } if (safmin * bcoefa > bscale) { /* Computing MIN */ r__1 = scale, r__2 = bscale / (safmin * bcoefa); scale = dmin(r__1,r__2); } if (scale != 1.f) { acoef = scale * acoef; acoefa = dabs(acoef); bcoefr = scale * bcoefr; bcoefi = scale * bcoefi; bcoefa = dabs(bcoefr) + dabs(bcoefi); } /* Compute first two components of eigenvector */ /* and contribution to sums */ temp = acoef * s[je + (je - 1) * s_dim1]; temp2r = acoef * s[je + je * s_dim1] - bcoefr * p[je + je * p_dim1]; temp2i = -bcoefi * p[je + je * p_dim1]; if (dabs(temp) >= dabs(temp2r) + dabs(temp2i)) { work[(*n << 1) + je] = 1.f; work[*n * 3 + je] = 0.f; work[(*n << 1) + je - 1] = -temp2r / temp; work[*n * 3 + je - 1] = -temp2i / temp; } else { work[(*n << 1) + je - 1] = 1.f; work[*n * 3 + je - 1] = 0.f; temp = acoef * s[je - 1 + je * s_dim1]; work[(*n << 1) + je] = (bcoefr * p[je - 1 + (je - 1) * p_dim1] - acoef * s[je - 1 + (je - 1) * s_dim1]) / temp; work[*n * 3 + je] = bcoefi * p[je - 1 + (je - 1) * p_dim1] / temp; } /* Computing MAX */ r__5 = (r__1 = work[(*n << 1) + je], dabs(r__1)) + (r__2 = work[*n * 3 + je], dabs(r__2)), r__6 = (r__3 = work[(* n << 1) + je - 1], dabs(r__3)) + (r__4 = work[*n * 3 + je - 1], dabs(r__4)); xmax = dmax(r__5,r__6); /* Compute contribution from columns JE and JE-1 */ /* of A and B to the sums. */ creala = acoef * work[(*n << 1) + je - 1]; cimaga = acoef * work[*n * 3 + je - 1]; crealb = bcoefr * work[(*n << 1) + je - 1] - bcoefi * work[*n * 3 + je - 1]; cimagb = bcoefi * work[(*n << 1) + je - 1] + bcoefr * work[*n * 3 + je - 1]; cre2a = acoef * work[(*n << 1) + je]; cim2a = acoef * work[*n * 3 + je]; cre2b = bcoefr * work[(*n << 1) + je] - bcoefi * work[*n * 3 + je]; cim2b = bcoefi * work[(*n << 1) + je] + bcoefr * work[*n * 3 + je]; i__1 = je - 2; for (jr = 1; jr <= i__1; ++jr) { work[(*n << 1) + jr] = -creala * s[jr + (je - 1) * s_dim1] + crealb * p[jr + (je - 1) * p_dim1] - cre2a * s[ jr + je * s_dim1] + cre2b * p[jr + je * p_dim1]; work[*n * 3 + jr] = -cimaga * s[jr + (je - 1) * s_dim1] + cimagb * p[jr + (je - 1) * p_dim1] - cim2a * s[jr + je * s_dim1] + cim2b * p[jr + je * p_dim1]; } } /* Computing MAX */ r__1 = ulp * acoefa * anorm, r__2 = ulp * bcoefa * bnorm, r__1 = max(r__1,r__2); dmin__ = dmax(r__1,safmin); /* Columnwise triangular solve of (a A - b B) x = 0 */ il2by2 = FALSE_; for (j = je - nw; j >= 1; --j) { /* If a 2-by-2 block, is in position j-1:j, wait until */ /* next iteration to process it (when it will be j:j+1) */ if (! il2by2 && j > 1) { if (s[j + (j - 1) * s_dim1] != 0.f) { il2by2 = TRUE_; goto L370; } } bdiag[0] = p[j + j * p_dim1]; if (il2by2) { na = 2; bdiag[1] = p[j + 1 + (j + 1) * p_dim1]; } else { na = 1; } /* Compute x(j) (and x(j+1), if 2-by-2 block) */ slaln2_(&c_false, &na, &nw, &dmin__, &acoef, &s[j + j * s_dim1], lds, bdiag, &bdiag[1], &work[(*n << 1) + j], n, &bcoefr, &bcoefi, sum, &c__2, &scale, &temp, & iinfo); if (scale < 1.f) { i__1 = nw - 1; for (jw = 0; jw <= i__1; ++jw) { i__2 = je; for (jr = 1; jr <= i__2; ++jr) { work[(jw + 2) * *n + jr] = scale * work[(jw + 2) * *n + jr]; } } } /* Computing MAX */ r__1 = scale * xmax; xmax = dmax(r__1,temp); i__1 = nw; for (jw = 1; jw <= i__1; ++jw) { i__2 = na; for (ja = 1; ja <= i__2; ++ja) { work[(jw + 1) * *n + j + ja - 1] = sum[ja + (jw << 1) - 3]; } } /* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling */ if (j > 1) { /* Check whether scaling is necessary for sum. */ xscale = 1.f / dmax(1.f,xmax); temp = acoefa * work[j] + bcoefa * work[*n + j]; if (il2by2) { /* Computing MAX */ r__1 = temp, r__2 = acoefa * work[j + 1] + bcoefa * work[*n + j + 1]; temp = dmax(r__1,r__2); } /* Computing MAX */ r__1 = max(temp,acoefa); temp = dmax(r__1,bcoefa); if (temp > bignum * xscale) { i__1 = nw - 1; for (jw = 0; jw <= i__1; ++jw) { i__2 = je; for (jr = 1; jr <= i__2; ++jr) { work[(jw + 2) * *n + jr] = xscale * work[(jw + 2) * *n + jr]; } } xmax *= xscale; } /* Compute the contributions of the off-diagonals of */ /* column j (and j+1, if 2-by-2 block) of A and B to the */ /* sums. */ i__1 = na; for (ja = 1; ja <= i__1; ++ja) { if (ilcplx) { creala = acoef * work[(*n << 1) + j + ja - 1]; cimaga = acoef * work[*n * 3 + j + ja - 1]; crealb = bcoefr * work[(*n << 1) + j + ja - 1] - bcoefi * work[*n * 3 + j + ja - 1]; cimagb = bcoefi * work[(*n << 1) + j + ja - 1] + bcoefr * work[*n * 3 + j + ja - 1]; i__2 = j - 1; for (jr = 1; jr <= i__2; ++jr) { work[(*n << 1) + jr] = work[(*n << 1) + jr] - creala * s[jr + (j + ja - 1) * s_dim1] + crealb * p[jr + (j + ja - 1) * p_dim1]; work[*n * 3 + jr] = work[*n * 3 + jr] - cimaga * s[jr + (j + ja - 1) * s_dim1] + cimagb * p[jr + (j + ja - 1) * p_dim1]; } } else { creala = acoef * work[(*n << 1) + j + ja - 1]; crealb = bcoefr * work[(*n << 1) + j + ja - 1]; i__2 = j - 1; for (jr = 1; jr <= i__2; ++jr) { work[(*n << 1) + jr] = work[(*n << 1) + jr] - creala * s[jr + (j + ja - 1) * s_dim1] + crealb * p[jr + (j + ja - 1) * p_dim1]; } } } } il2by2 = FALSE_; L370: ; } /* Copy eigenvector to VR, back transforming if */ /* HOWMNY='B'. */ ieig -= nw; if (ilback) { i__1 = nw - 1; for (jw = 0; jw <= i__1; ++jw) { i__2 = *n; for (jr = 1; jr <= i__2; ++jr) { work[(jw + 4) * *n + jr] = work[(jw + 2) * *n + 1] * vr[jr + vr_dim1]; } /* A series of compiler directives to defeat */ /* vectorization for the next loop */ i__2 = je; for (jc = 2; jc <= i__2; ++jc) { i__3 = *n; for (jr = 1; jr <= i__3; ++jr) { work[(jw + 4) * *n + jr] += work[(jw + 2) * *n + jc] * vr[jr + jc * vr_dim1]; } } } i__1 = nw - 1; for (jw = 0; jw <= i__1; ++jw) { i__2 = *n; for (jr = 1; jr <= i__2; ++jr) { vr[jr + (ieig + jw) * vr_dim1] = work[(jw + 4) * *n + jr]; } } iend = *n; } else { i__1 = nw - 1; for (jw = 0; jw <= i__1; ++jw) { i__2 = *n; for (jr = 1; jr <= i__2; ++jr) { vr[jr + (ieig + jw) * vr_dim1] = work[(jw + 2) * *n + jr]; } } iend = je; } /* Scale eigenvector */ xmax = 0.f; if (ilcplx) { i__1 = iend; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ r__3 = xmax, r__4 = (r__1 = vr[j + ieig * vr_dim1], dabs( r__1)) + (r__2 = vr[j + (ieig + 1) * vr_dim1], dabs(r__2)); xmax = dmax(r__3,r__4); } } else { i__1 = iend; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ r__2 = xmax, r__3 = (r__1 = vr[j + ieig * vr_dim1], dabs( r__1)); xmax = dmax(r__2,r__3); } } if (xmax > safmin) { xscale = 1.f / xmax; i__1 = nw - 1; for (jw = 0; jw <= i__1; ++jw) { i__2 = iend; for (jr = 1; jr <= i__2; ++jr) { vr[jr + (ieig + jw) * vr_dim1] = xscale * vr[jr + ( ieig + jw) * vr_dim1]; } } } L500: ; } } return 0; /* End of STGEVC */ } /* stgevc_ */
/* Subroutine */ int slaqtr_(logical *ltran, logical *lreal, integer *n, real *t, integer *ldt, real *b, real *w, real *scale, real *x, real *work, integer *info) { /* System generated locals */ integer t_dim1, t_offset, i__1, i__2; real r__1, r__2, r__3, r__4, r__5, r__6; /* Local variables */ real d__[4] /* was [2][2] */ ; integer i__, j, k; real v[4] /* was [2][2] */ , z__; integer j1, j2, n1, n2; real si, xj, sr, rec, eps, tjj, tmp; integer ierr; real smin; extern real sdot_(integer *, real *, integer *, real *, integer *); real xmax; extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); integer jnext; extern real sasum_(integer *, real *, integer *); real sminw, xnorm; extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, real *, integer *), slaln2_(logical *, integer *, integer *, real *, real *, real *, integer *, real *, real *, real *, integer *, real *, real *, real *, integer *, real *, real *, integer *); real scaloc; extern real slamch_(char *), slange_(char *, integer *, integer *, real *, integer *, real *); real bignum; extern integer isamax_(integer *, real *, integer *); extern /* Subroutine */ int sladiv_(real *, real *, real *, real *, real * , real *); logical notran; real 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 .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Do not test the input parameters for errors */ /* Parameter adjustments */ t_dim1 = *ldt; t_offset = 1 + t_dim1; t -= t_offset; --b; --x; --work; /* Function Body */ notran = ! (*ltran); *info = 0; /* Quick return if possible */ if (*n == 0) { return 0; } /* Set constants to control overflow */ eps = slamch_("P"); smlnum = slamch_("S") / eps; bignum = 1.f / smlnum; xnorm = slange_("M", n, n, &t[t_offset], ldt, d__); if (! (*lreal)) { /* Computing MAX */ r__1 = xnorm, r__2 = abs(*w); r__1 = max(r__1,r__2); r__2 = slange_( "M", n, &c__1, &b[1], n, d__); // ; expr subst xnorm = max(r__1,r__2); } /* Computing MAX */ r__1 = smlnum; r__2 = eps * xnorm; // , expr subst smin = max(r__1,r__2); /* Compute 1-norm of each column of strictly upper triangular */ /* part of T to control overflow in triangular solver. */ work[1] = 0.f; i__1 = *n; for (j = 2; j <= i__1; ++j) { i__2 = j - 1; work[j] = sasum_(&i__2, &t[j * t_dim1 + 1], &c__1); /* L10: */ } if (! (*lreal)) { i__1 = *n; for (i__ = 2; i__ <= i__1; ++i__) { work[i__] += (r__1 = b[i__], abs(r__1)); /* L20: */ } } n2 = *n << 1; n1 = *n; if (! (*lreal)) { n1 = n2; } k = isamax_(&n1, &x[1], &c__1); xmax = (r__1 = x[k], abs(r__1)); *scale = 1.f; if (xmax > bignum) { *scale = bignum / xmax; sscal_(&n1, scale, &x[1], &c__1); xmax = bignum; } if (*lreal) { if (notran) { /* Solve T*p = scale*c */ jnext = *n; for (j = *n; j >= 1; --j) { if (j > jnext) { goto L30; } j1 = j; j2 = j; jnext = j - 1; if (j > 1) { if (t[j + (j - 1) * t_dim1] != 0.f) { j1 = j - 1; jnext = j - 2; } } if (j1 == j2) { /* Meet 1 by 1 diagonal block */ /* Scale to avoid overflow when computing */ /* x(j) = b(j)/T(j,j) */ xj = (r__1 = x[j1], abs(r__1)); tjj = (r__1 = t[j1 + j1 * t_dim1], abs(r__1)); tmp = t[j1 + j1 * t_dim1]; if (tjj < smin) { tmp = smin; tjj = smin; *info = 1; } if (xj == 0.f) { goto L30; } if (tjj < 1.f) { if (xj > bignum * tjj) { rec = 1.f / xj; sscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } x[j1] /= tmp; xj = (r__1 = x[j1], abs(r__1)); /* Scale x if necessary to avoid overflow when adding a */ /* multiple of column j1 of T. */ if (xj > 1.f) { rec = 1.f / xj; if (work[j1] > (bignum - xmax) * rec) { sscal_(n, &rec, &x[1], &c__1); *scale *= rec; } } if (j1 > 1) { i__1 = j1 - 1; r__1 = -x[j1]; saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] , &c__1); i__1 = j1 - 1; k = isamax_(&i__1, &x[1], &c__1); xmax = (r__1 = x[k], abs(r__1)); } } else { /* Meet 2 by 2 diagonal block */ /* Call 2 by 2 linear system solve, to take */ /* care of possible overflow by scaling factor. */ d__[0] = x[j1]; d__[1] = x[j2]; slaln2_(&c_false, &c__2, &c__1, &smin, &c_b21, &t[j1 + j1 * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, & c_b25, &c_b25, v, &c__2, &scaloc, &xnorm, &ierr); if (ierr != 0) { *info = 2; } if (scaloc != 1.f) { sscal_(n, &scaloc, &x[1], &c__1); *scale *= scaloc; } x[j1] = v[0]; x[j2] = v[1]; /* Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2)) */ /* to avoid overflow in updating right-hand side. */ /* Computing MAX */ r__1 = abs(v[0]); r__2 = abs(v[1]); // , expr subst xj = max(r__1,r__2); if (xj > 1.f) { rec = 1.f / xj; /* Computing MAX */ r__1 = work[j1]; r__2 = work[j2]; // , expr subst if (max(r__1,r__2) > (bignum - xmax) * rec) { sscal_(n, &rec, &x[1], &c__1); *scale *= rec; } } /* Update right-hand side */ if (j1 > 1) { i__1 = j1 - 1; r__1 = -x[j1]; saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] , &c__1); i__1 = j1 - 1; r__1 = -x[j2]; saxpy_(&i__1, &r__1, &t[j2 * t_dim1 + 1], &c__1, &x[1] , &c__1); i__1 = j1 - 1; k = isamax_(&i__1, &x[1], &c__1); xmax = (r__1 = x[k], abs(r__1)); } } L30: ; } } else { /* Solve T**T*p = scale*c */ jnext = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (j < jnext) { goto L40; } j1 = j; j2 = j; jnext = j + 1; if (j < *n) { if (t[j + 1 + j * t_dim1] != 0.f) { j2 = j + 1; jnext = j + 2; } } if (j1 == j2) { /* 1 by 1 diagonal block */ /* Scale if necessary to avoid overflow in forming the */ /* right-hand side element by inner product. */ xj = (r__1 = x[j1], abs(r__1)); if (xmax > 1.f) { rec = 1.f / xmax; if (work[j1] > (bignum - xj) * rec) { sscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__2 = j1 - 1; x[j1] -= sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], & c__1); xj = (r__1 = x[j1], abs(r__1)); tjj = (r__1 = t[j1 + j1 * t_dim1], abs(r__1)); tmp = t[j1 + j1 * t_dim1]; if (tjj < smin) { tmp = smin; tjj = smin; *info = 1; } if (tjj < 1.f) { if (xj > bignum * tjj) { rec = 1.f / xj; sscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } x[j1] /= tmp; /* Computing MAX */ r__2 = xmax; r__3 = (r__1 = x[j1], abs(r__1)); // , expr subst xmax = max(r__2,r__3); } else { /* 2 by 2 diagonal block */ /* Scale if necessary to avoid overflow in forming the */ /* right-hand side elements by inner product. */ /* Computing MAX */ r__3 = (r__1 = x[j1], abs(r__1)); r__4 = (r__2 = x[j2], abs(r__2)); // , expr subst xj = max(r__3,r__4); if (xmax > 1.f) { rec = 1.f / xmax; /* Computing MAX */ r__1 = work[j2]; r__2 = work[j1]; // , expr subst if (max(r__1,r__2) > (bignum - xj) * rec) { sscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__2 = j1 - 1; d__[0] = x[j1] - sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], &c__1); i__2 = j1 - 1; d__[1] = x[j2] - sdot_(&i__2, &t[j2 * t_dim1 + 1], &c__1, &x[1], &c__1); slaln2_(&c_true, &c__2, &c__1, &smin, &c_b21, &t[j1 + j1 * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &c_b25, &c_b25, v, &c__2, &scaloc, &xnorm, &ierr); if (ierr != 0) { *info = 2; } if (scaloc != 1.f) { sscal_(n, &scaloc, &x[1], &c__1); *scale *= scaloc; } x[j1] = v[0]; x[j2] = v[1]; /* Computing MAX */ r__3 = (r__1 = x[j1], abs(r__1)); r__4 = (r__2 = x[j2], abs(r__2)); r__3 = max(r__3,r__4); // ; expr subst xmax = max(r__3,xmax); } L40: ; } } } else { /* Computing MAX */ r__1 = eps * abs(*w); sminw = max(r__1,smin); if (notran) { /* Solve (T + iB)*(p+iq) = c+id */ jnext = *n; for (j = *n; j >= 1; --j) { if (j > jnext) { goto L70; } j1 = j; j2 = j; jnext = j - 1; if (j > 1) { if (t[j + (j - 1) * t_dim1] != 0.f) { j1 = j - 1; jnext = j - 2; } } if (j1 == j2) { /* 1 by 1 diagonal block */ /* Scale if necessary to avoid overflow in division */ z__ = *w; if (j1 == 1) { z__ = b[1]; } xj = (r__1 = x[j1], abs(r__1)) + (r__2 = x[*n + j1], abs( r__2)); tjj = (r__1 = t[j1 + j1 * t_dim1], abs(r__1)) + abs(z__); tmp = t[j1 + j1 * t_dim1]; if (tjj < sminw) { tmp = sminw; tjj = sminw; *info = 1; } if (xj == 0.f) { goto L70; } if (tjj < 1.f) { if (xj > bignum * tjj) { rec = 1.f / xj; sscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } sladiv_(&x[j1], &x[*n + j1], &tmp, &z__, &sr, &si); x[j1] = sr; x[*n + j1] = si; xj = (r__1 = x[j1], abs(r__1)) + (r__2 = x[*n + j1], abs( r__2)); /* Scale x if necessary to avoid overflow when adding a */ /* multiple of column j1 of T. */ if (xj > 1.f) { rec = 1.f / xj; if (work[j1] > (bignum - xmax) * rec) { sscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; } } if (j1 > 1) { i__1 = j1 - 1; r__1 = -x[j1]; saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] , &c__1); i__1 = j1 - 1; r__1 = -x[*n + j1]; saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[* n + 1], &c__1); x[1] += b[j1] * x[*n + j1]; x[*n + 1] -= b[j1] * x[j1]; xmax = 0.f; i__1 = j1 - 1; for (k = 1; k <= i__1; ++k) { /* Computing MAX */ r__3 = xmax; r__4 = (r__1 = x[k], abs(r__1)) + ( r__2 = x[k + *n], abs(r__2)); // , expr subst xmax = max(r__3,r__4); /* L50: */ } } } else { /* Meet 2 by 2 diagonal block */ d__[0] = x[j1]; d__[1] = x[j2]; d__[2] = x[*n + j1]; d__[3] = x[*n + j2]; r__1 = -(*w); slaln2_(&c_false, &c__2, &c__2, &sminw, &c_b21, &t[j1 + j1 * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, & c_b25, &r__1, v, &c__2, &scaloc, &xnorm, &ierr); if (ierr != 0) { *info = 2; } if (scaloc != 1.f) { i__1 = *n << 1; sscal_(&i__1, &scaloc, &x[1], &c__1); *scale = scaloc * *scale; } x[j1] = v[0]; x[j2] = v[1]; x[*n + j1] = v[2]; x[*n + j2] = v[3]; /* Scale X(J1), .... to avoid overflow in */ /* updating right hand side. */ /* Computing MAX */ r__1 = abs(v[0]) + abs(v[2]); r__2 = abs(v[1]) + abs(v[3]) ; // , expr subst xj = max(r__1,r__2); if (xj > 1.f) { rec = 1.f / xj; /* Computing MAX */ r__1 = work[j1]; r__2 = work[j2]; // , expr subst if (max(r__1,r__2) > (bignum - xmax) * rec) { sscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; } } /* Update the right-hand side. */ if (j1 > 1) { i__1 = j1 - 1; r__1 = -x[j1]; saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] , &c__1); i__1 = j1 - 1; r__1 = -x[j2]; saxpy_(&i__1, &r__1, &t[j2 * t_dim1 + 1], &c__1, &x[1] , &c__1); i__1 = j1 - 1; r__1 = -x[*n + j1]; saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[* n + 1], &c__1); i__1 = j1 - 1; r__1 = -x[*n + j2]; saxpy_(&i__1, &r__1, &t[j2 * t_dim1 + 1], &c__1, &x[* n + 1], &c__1); x[1] = x[1] + b[j1] * x[*n + j1] + b[j2] * x[*n + j2]; x[*n + 1] = x[*n + 1] - b[j1] * x[j1] - b[j2] * x[j2]; xmax = 0.f; i__1 = j1 - 1; for (k = 1; k <= i__1; ++k) { /* Computing MAX */ r__3 = (r__1 = x[k], abs(r__1)) + (r__2 = x[k + * n], abs(r__2)); xmax = max(r__3,xmax); /* L60: */ } } } L70: ; } } else { /* Solve (T + iB)**T*(p+iq) = c+id */ jnext = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (j < jnext) { goto L80; } j1 = j; j2 = j; jnext = j + 1; if (j < *n) { if (t[j + 1 + j * t_dim1] != 0.f) { j2 = j + 1; jnext = j + 2; } } if (j1 == j2) { /* 1 by 1 diagonal block */ /* Scale if necessary to avoid overflow in forming the */ /* right-hand side element by inner product. */ xj = (r__1 = x[j1], abs(r__1)) + (r__2 = x[j1 + *n], abs( r__2)); if (xmax > 1.f) { rec = 1.f / xmax; if (work[j1] > (bignum - xj) * rec) { sscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__2 = j1 - 1; x[j1] -= sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], & c__1); i__2 = j1 - 1; x[*n + j1] -= sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[ *n + 1], &c__1); if (j1 > 1) { x[j1] -= b[j1] * x[*n + 1]; x[*n + j1] += b[j1] * x[1]; } xj = (r__1 = x[j1], abs(r__1)) + (r__2 = x[j1 + *n], abs( r__2)); z__ = *w; if (j1 == 1) { z__ = b[1]; } /* Scale if necessary to avoid overflow in */ /* complex division */ tjj = (r__1 = t[j1 + j1 * t_dim1], abs(r__1)) + abs(z__); tmp = t[j1 + j1 * t_dim1]; if (tjj < sminw) { tmp = sminw; tjj = sminw; *info = 1; } if (tjj < 1.f) { if (xj > bignum * tjj) { rec = 1.f / xj; sscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } r__1 = -z__; sladiv_(&x[j1], &x[*n + j1], &tmp, &r__1, &sr, &si); x[j1] = sr; x[j1 + *n] = si; /* Computing MAX */ r__3 = (r__1 = x[j1], abs(r__1)) + (r__2 = x[j1 + *n], abs(r__2)); xmax = max(r__3,xmax); } else { /* 2 by 2 diagonal block */ /* Scale if necessary to avoid overflow in forming the */ /* right-hand side element by inner product. */ /* Computing MAX */ r__5 = (r__1 = x[j1], abs(r__1)) + (r__2 = x[*n + j1], abs(r__2)); r__6 = (r__3 = x[j2], abs(r__3)) + ( r__4 = x[*n + j2], abs(r__4)); // , expr subst xj = max(r__5,r__6); if (xmax > 1.f) { rec = 1.f / xmax; /* Computing MAX */ r__1 = work[j1]; r__2 = work[j2]; // , expr subst if (max(r__1,r__2) > (bignum - xj) / xmax) { sscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__2 = j1 - 1; d__[0] = x[j1] - sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], &c__1); i__2 = j1 - 1; d__[1] = x[j2] - sdot_(&i__2, &t[j2 * t_dim1 + 1], &c__1, &x[1], &c__1); i__2 = j1 - 1; d__[2] = x[*n + j1] - sdot_(&i__2, &t[j1 * t_dim1 + 1], & c__1, &x[*n + 1], &c__1); i__2 = j1 - 1; d__[3] = x[*n + j2] - sdot_(&i__2, &t[j2 * t_dim1 + 1], & c__1, &x[*n + 1], &c__1); d__[0] -= b[j1] * x[*n + 1]; d__[1] -= b[j2] * x[*n + 1]; d__[2] += b[j1] * x[1]; d__[3] += b[j2] * x[1]; slaln2_(&c_true, &c__2, &c__2, &sminw, &c_b21, &t[j1 + j1 * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, & c_b25, w, v, &c__2, &scaloc, &xnorm, &ierr); if (ierr != 0) { *info = 2; } if (scaloc != 1.f) { sscal_(&n2, &scaloc, &x[1], &c__1); *scale = scaloc * *scale; } x[j1] = v[0]; x[j2] = v[1]; x[*n + j1] = v[2]; x[*n + j2] = v[3]; /* Computing MAX */ r__5 = (r__1 = x[j1], abs(r__1)) + (r__2 = x[*n + j1], abs(r__2)); r__6 = (r__3 = x[j2], abs(r__3)) + ( r__4 = x[*n + j2], abs(r__4)); r__5 = max(r__5, r__6); // ; expr subst xmax = max(r__5,xmax); } L80: ; } } } return 0; /* End of SLAQTR */ }
/* Subroutine */ int strevc_(char *side, char *howmny, logical *select, integer *n, real *t, integer *ldt, real *vl, integer *ldvl, real *vr, integer *ldvr, integer *mm, integer *m, real *work, integer *info) { /* System generated locals */ integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3; real r__1, r__2, r__3, r__4; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ integer i__, j, k; real x[4] /* was [2][2] */; integer j1, j2, n2, ii, ki, ip, is; real wi, wr, rec, ulp, beta, emax; logical pair, allv; integer ierr; real unfl, ovfl, smin; extern doublereal sdot_(integer *, real *, integer *, real *, integer *); logical over; real vmax; integer jnxt; real scale; extern logical lsame_(char *, char *); extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); real remax; logical leftv; extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *); logical bothv; real vcrit; logical somev; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *); real xnorm; extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, real *, integer *), slaln2_(logical *, integer *, integer *, real *, real *, real *, integer *, real *, real *, real *, integer *, real *, real *, real *, integer *, real *, real *, integer *), slabad_(real *, real *); extern doublereal slamch_(char *); extern /* Subroutine */ int xerbla_(char *, integer *); real bignum; extern integer isamax_(integer *, real *, integer *); logical rightv; real smlnum; /* -- LAPACK routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* STREVC computes some or all of the right and/or left eigenvectors of */ /* a real upper quasi-triangular matrix T. */ /* Matrices of this type are produced by the Schur factorization of */ /* a real general matrix: A = Q*T*Q**T, as computed by SHSEQR. */ /* The right eigenvector x and the left eigenvector y of T corresponding */ /* to an eigenvalue w are defined by: */ /* T*x = w*x, (y**H)*T = w*(y**H) */ /* where y**H denotes the conjugate transpose of y. */ /* The eigenvalues are not input to this routine, but are read directly */ /* from the diagonal blocks of T. */ /* This routine returns the matrices X and/or Y of right and left */ /* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an */ /* input matrix. If Q is the orthogonal factor that reduces a matrix */ /* A to Schur form T, then Q*X and Q*Y are the matrices of right and */ /* left eigenvectors of A. */ /* Arguments */ /* ========= */ /* SIDE (input) CHARACTER*1 */ /* = 'R': compute right eigenvectors only; */ /* = 'L': compute left eigenvectors only; */ /* = 'B': compute both right and left eigenvectors. */ /* HOWMNY (input) CHARACTER*1 */ /* = 'A': compute all right and/or left eigenvectors; */ /* = 'B': compute all right and/or left eigenvectors, */ /* backtransformed by the matrices in VR and/or VL; */ /* = 'S': compute selected right and/or left eigenvectors, */ /* as indicated by the logical array SELECT. */ /* SELECT (input/output) LOGICAL array, dimension (N) */ /* If HOWMNY = 'S', SELECT specifies the eigenvectors to be */ /* computed. */ /* If w(j) is a real eigenvalue, the corresponding real */ /* eigenvector is computed if SELECT(j) is .TRUE.. */ /* If w(j) and w(j+1) are the real and imaginary parts of a */ /* complex eigenvalue, the corresponding complex eigenvector is */ /* computed if either SELECT(j) or SELECT(j+1) is .TRUE., and */ /* on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to */ /* .FALSE.. */ /* Not referenced if HOWMNY = 'A' or 'B'. */ /* N (input) INTEGER */ /* The order of the matrix T. N >= 0. */ /* T (input) REAL array, dimension (LDT,N) */ /* The upper quasi-triangular matrix T in Schur canonical form. */ /* LDT (input) INTEGER */ /* The leading dimension of the array T. LDT >= max(1,N). */ /* VL (input/output) REAL array, dimension (LDVL,MM) */ /* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */ /* contain an N-by-N matrix Q (usually the orthogonal matrix Q */ /* of Schur vectors returned by SHSEQR). */ /* On exit, if SIDE = 'L' or 'B', VL contains: */ /* if HOWMNY = 'A', the matrix Y of left eigenvectors of T; */ /* if HOWMNY = 'B', the matrix Q*Y; */ /* if HOWMNY = 'S', the left eigenvectors of T specified by */ /* SELECT, stored consecutively in the columns */ /* of VL, in the same order as their */ /* eigenvalues. */ /* A complex eigenvector corresponding to a complex eigenvalue */ /* is stored in two consecutive columns, the first holding the */ /* real part, and the second the imaginary part. */ /* Not referenced if SIDE = 'R'. */ /* LDVL (input) INTEGER */ /* The leading dimension of the array VL. LDVL >= 1, and if */ /* SIDE = 'L' or 'B', LDVL >= N. */ /* VR (input/output) REAL array, dimension (LDVR,MM) */ /* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */ /* contain an N-by-N matrix Q (usually the orthogonal matrix Q */ /* of Schur vectors returned by SHSEQR). */ /* On exit, if SIDE = 'R' or 'B', VR contains: */ /* if HOWMNY = 'A', the matrix X of right eigenvectors of T; */ /* if HOWMNY = 'B', the matrix Q*X; */ /* if HOWMNY = 'S', the right eigenvectors of T specified by */ /* SELECT, stored consecutively in the columns */ /* of VR, in the same order as their */ /* eigenvalues. */ /* A complex eigenvector corresponding to a complex eigenvalue */ /* is stored in two consecutive columns, the first holding the */ /* real part and the second the imaginary part. */ /* Not referenced if SIDE = 'L'. */ /* LDVR (input) INTEGER */ /* The leading dimension of the array VR. LDVR >= 1, and if */ /* SIDE = 'R' or 'B', LDVR >= N. */ /* MM (input) INTEGER */ /* The number of columns in the arrays VL and/or VR. MM >= M. */ /* M (output) INTEGER */ /* The number of columns in the arrays VL and/or VR actually */ /* used to store the eigenvectors. */ /* If HOWMNY = 'A' or 'B', M is set to N. */ /* Each selected real eigenvector occupies one column and each */ /* selected complex eigenvector occupies two columns. */ /* WORK (workspace) REAL array, dimension (3*N) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* Further Details */ /* =============== */ /* The algorithm used in this program is basically backward (forward) */ /* substitution, with scaling to make the the code robust against */ /* possible overflow. */ /* Each eigenvector is normalized so that the element of largest */ /* magnitude has magnitude 1; here the magnitude of a complex number */ /* (x,y) is taken to be |x| + |y|. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. Executable Statements .. */ /* Decode and test the input parameters */ /* Parameter adjustments */ --select; t_dim1 = *ldt; t_offset = 1 + t_dim1; t -= t_offset; vl_dim1 = *ldvl; vl_offset = 1 + vl_dim1; vl -= vl_offset; vr_dim1 = *ldvr; vr_offset = 1 + vr_dim1; vr -= vr_offset; --work; /* Function Body */ bothv = lsame_(side, "B"); rightv = lsame_(side, "R") || bothv; leftv = lsame_(side, "L") || bothv; allv = lsame_(howmny, "A"); over = lsame_(howmny, "B"); somev = lsame_(howmny, "S"); *info = 0; if (! rightv && ! leftv) { *info = -1; } else if (! allv && ! over && ! somev) { *info = -2; } else if (*n < 0) { *info = -4; } else if (*ldt < max(1,*n)) { *info = -6; } else if (*ldvl < 1 || leftv && *ldvl < *n) { *info = -8; } else if (*ldvr < 1 || rightv && *ldvr < *n) { *info = -10; } else { /* Set M to the number of columns required to store the selected */ /* eigenvectors, standardize the array SELECT if necessary, and */ /* test MM. */ if (somev) { *m = 0; pair = FALSE_; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (pair) { pair = FALSE_; select[j] = FALSE_; } else { if (j < *n) { if (t[j + 1 + j * t_dim1] == 0.f) { if (select[j]) { ++(*m); } } else { pair = TRUE_; if (select[j] || select[j + 1]) { select[j] = TRUE_; *m += 2; } } } else { if (select[*n]) { ++(*m); } } } /* L10: */ } } else { *m = *n; } if (*mm < *m) { *info = -11; } } if (*info != 0) { i__1 = -(*info); xerbla_("STREVC", &i__1); return 0; } /* Quick return if possible. */ if (*n == 0) { return 0; } /* Set the constants to control overflow. */ unfl = slamch_("Safe minimum"); ovfl = 1.f / unfl; slabad_(&unfl, &ovfl); ulp = slamch_("Precision"); smlnum = unfl * (*n / ulp); bignum = (1.f - ulp) / smlnum; /* Compute 1-norm of each column of strictly upper triangular */ /* part of T to control overflow in triangular solver. */ work[1] = 0.f; i__1 = *n; for (j = 2; j <= i__1; ++j) { work[j] = 0.f; i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { work[j] += (r__1 = t[i__ + j * t_dim1], dabs(r__1)); /* L20: */ } /* L30: */ } /* Index IP is used to specify the real or complex eigenvalue: */ /* IP = 0, real eigenvalue, */ /* 1, first of conjugate complex pair: (wr,wi) */ /* -1, second of conjugate complex pair: (wr,wi) */ n2 = *n << 1; if (rightv) { /* Compute right eigenvectors. */ ip = 0; is = *m; for (ki = *n; ki >= 1; --ki) { if (ip == 1) { goto L130; } if (ki == 1) { goto L40; } if (t[ki + (ki - 1) * t_dim1] == 0.f) { goto L40; } ip = -1; L40: if (somev) { if (ip == 0) { if (! select[ki]) { goto L130; } } else { if (! select[ki - 1]) { goto L130; } } } /* Compute the KI-th eigenvalue (WR,WI). */ wr = t[ki + ki * t_dim1]; wi = 0.f; if (ip != 0) { wi = sqrt((r__1 = t[ki + (ki - 1) * t_dim1], dabs(r__1))) * sqrt((r__2 = t[ki - 1 + ki * t_dim1], dabs(r__2))); } /* Computing MAX */ r__1 = ulp * (dabs(wr) + dabs(wi)); smin = dmax(r__1,smlnum); if (ip == 0) { /* Real right eigenvector */ work[ki + *n] = 1.f; /* Form right-hand side */ i__1 = ki - 1; for (k = 1; k <= i__1; ++k) { work[k + *n] = -t[k + ki * t_dim1]; /* L50: */ } /* Solve the upper quasi-triangular system: */ /* (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK. */ jnxt = ki - 1; for (j = ki - 1; j >= 1; --j) { if (j > jnxt) { goto L60; } j1 = j; j2 = j; jnxt = j - 1; if (j > 1) { if (t[j + (j - 1) * t_dim1] != 0.f) { j1 = j - 1; jnxt = j - 2; } } if (j1 == j2) { /* 1-by-1 diagonal block */ slaln2_(&c_false, &c__1, &c__1, &smin, &c_b22, &t[j + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm, &ierr); /* Scale X(1,1) to avoid overflow when updating */ /* the right-hand side. */ if (xnorm > 1.f) { if (work[j] > bignum / xnorm) { x[0] /= xnorm; scale /= xnorm; } } /* Scale if necessary */ if (scale != 1.f) { sscal_(&ki, &scale, &work[*n + 1], &c__1); } work[j + *n] = x[0]; /* Update right-hand side */ i__1 = j - 1; r__1 = -x[0]; saxpy_(&i__1, &r__1, &t[j * t_dim1 + 1], &c__1, &work[ *n + 1], &c__1); } else { /* 2-by-2 diagonal block */ slaln2_(&c_false, &c__2, &c__1, &smin, &c_b22, &t[j - 1 + (j - 1) * t_dim1], ldt, &c_b22, &c_b22, & work[j - 1 + *n], n, &wr, &c_b25, x, &c__2, & scale, &xnorm, &ierr); /* Scale X(1,1) and X(2,1) to avoid overflow when */ /* updating the right-hand side. */ if (xnorm > 1.f) { /* Computing MAX */ r__1 = work[j - 1], r__2 = work[j]; beta = dmax(r__1,r__2); if (beta > bignum / xnorm) { x[0] /= xnorm; x[1] /= xnorm; scale /= xnorm; } } /* Scale if necessary */ if (scale != 1.f) { sscal_(&ki, &scale, &work[*n + 1], &c__1); } work[j - 1 + *n] = x[0]; work[j + *n] = x[1]; /* Update right-hand side */ i__1 = j - 2; r__1 = -x[0]; saxpy_(&i__1, &r__1, &t[(j - 1) * t_dim1 + 1], &c__1, &work[*n + 1], &c__1); i__1 = j - 2; r__1 = -x[1]; saxpy_(&i__1, &r__1, &t[j * t_dim1 + 1], &c__1, &work[ *n + 1], &c__1); } L60: ; } /* Copy the vector x or Q*x to VR and normalize. */ if (! over) { scopy_(&ki, &work[*n + 1], &c__1, &vr[is * vr_dim1 + 1], & c__1); ii = isamax_(&ki, &vr[is * vr_dim1 + 1], &c__1); remax = 1.f / (r__1 = vr[ii + is * vr_dim1], dabs(r__1)); sscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1); i__1 = *n; for (k = ki + 1; k <= i__1; ++k) { vr[k + is * vr_dim1] = 0.f; /* L70: */ } } else { if (ki > 1) { i__1 = ki - 1; sgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, & work[*n + 1], &c__1, &work[ki + *n], &vr[ki * vr_dim1 + 1], &c__1); } ii = isamax_(n, &vr[ki * vr_dim1 + 1], &c__1); remax = 1.f / (r__1 = vr[ii + ki * vr_dim1], dabs(r__1)); sscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1); } } else { /* Complex right eigenvector. */ /* Initial solve */ /* [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0. */ /* [ (T(KI,KI-1) T(KI,KI) ) ] */ if ((r__1 = t[ki - 1 + ki * t_dim1], dabs(r__1)) >= (r__2 = t[ ki + (ki - 1) * t_dim1], dabs(r__2))) { work[ki - 1 + *n] = 1.f; work[ki + n2] = wi / t[ki - 1 + ki * t_dim1]; } else { work[ki - 1 + *n] = -wi / t[ki + (ki - 1) * t_dim1]; work[ki + n2] = 1.f; } work[ki + *n] = 0.f; work[ki - 1 + n2] = 0.f; /* Form right-hand side */ i__1 = ki - 2; for (k = 1; k <= i__1; ++k) { work[k + *n] = -work[ki - 1 + *n] * t[k + (ki - 1) * t_dim1]; work[k + n2] = -work[ki + n2] * t[k + ki * t_dim1]; /* L80: */ } /* Solve upper quasi-triangular system: */ /* (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2) */ jnxt = ki - 2; for (j = ki - 2; j >= 1; --j) { if (j > jnxt) { goto L90; } j1 = j; j2 = j; jnxt = j - 1; if (j > 1) { if (t[j + (j - 1) * t_dim1] != 0.f) { j1 = j - 1; jnxt = j - 2; } } if (j1 == j2) { /* 1-by-1 diagonal block */ slaln2_(&c_false, &c__1, &c__2, &smin, &c_b22, &t[j + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * n], n, &wr, &wi, x, &c__2, &scale, &xnorm, & ierr); /* Scale X(1,1) and X(1,2) to avoid overflow when */ /* updating the right-hand side. */ if (xnorm > 1.f) { if (work[j] > bignum / xnorm) { x[0] /= xnorm; x[2] /= xnorm; scale /= xnorm; } } /* Scale if necessary */ if (scale != 1.f) { sscal_(&ki, &scale, &work[*n + 1], &c__1); sscal_(&ki, &scale, &work[n2 + 1], &c__1); } work[j + *n] = x[0]; work[j + n2] = x[2]; /* Update the right-hand side */ i__1 = j - 1; r__1 = -x[0]; saxpy_(&i__1, &r__1, &t[j * t_dim1 + 1], &c__1, &work[ *n + 1], &c__1); i__1 = j - 1; r__1 = -x[2]; saxpy_(&i__1, &r__1, &t[j * t_dim1 + 1], &c__1, &work[ n2 + 1], &c__1); } else { /* 2-by-2 diagonal block */ slaln2_(&c_false, &c__2, &c__2, &smin, &c_b22, &t[j - 1 + (j - 1) * t_dim1], ldt, &c_b22, &c_b22, & work[j - 1 + *n], n, &wr, &wi, x, &c__2, & scale, &xnorm, &ierr); /* Scale X to avoid overflow when updating */ /* the right-hand side. */ if (xnorm > 1.f) { /* Computing MAX */ r__1 = work[j - 1], r__2 = work[j]; beta = dmax(r__1,r__2); if (beta > bignum / xnorm) { rec = 1.f / xnorm; x[0] *= rec; x[2] *= rec; x[1] *= rec; x[3] *= rec; scale *= rec; } } /* Scale if necessary */ if (scale != 1.f) { sscal_(&ki, &scale, &work[*n + 1], &c__1); sscal_(&ki, &scale, &work[n2 + 1], &c__1); } work[j - 1 + *n] = x[0]; work[j + *n] = x[1]; work[j - 1 + n2] = x[2]; work[j + n2] = x[3]; /* Update the right-hand side */ i__1 = j - 2; r__1 = -x[0]; saxpy_(&i__1, &r__1, &t[(j - 1) * t_dim1 + 1], &c__1, &work[*n + 1], &c__1); i__1 = j - 2; r__1 = -x[1]; saxpy_(&i__1, &r__1, &t[j * t_dim1 + 1], &c__1, &work[ *n + 1], &c__1); i__1 = j - 2; r__1 = -x[2]; saxpy_(&i__1, &r__1, &t[(j - 1) * t_dim1 + 1], &c__1, &work[n2 + 1], &c__1); i__1 = j - 2; r__1 = -x[3]; saxpy_(&i__1, &r__1, &t[j * t_dim1 + 1], &c__1, &work[ n2 + 1], &c__1); } L90: ; } /* Copy the vector x or Q*x to VR and normalize. */ if (! over) { scopy_(&ki, &work[*n + 1], &c__1, &vr[(is - 1) * vr_dim1 + 1], &c__1); scopy_(&ki, &work[n2 + 1], &c__1, &vr[is * vr_dim1 + 1], & c__1); emax = 0.f; i__1 = ki; for (k = 1; k <= i__1; ++k) { /* Computing MAX */ r__3 = emax, r__4 = (r__1 = vr[k + (is - 1) * vr_dim1] , dabs(r__1)) + (r__2 = vr[k + is * vr_dim1], dabs(r__2)); emax = dmax(r__3,r__4); /* L100: */ } remax = 1.f / emax; sscal_(&ki, &remax, &vr[(is - 1) * vr_dim1 + 1], &c__1); sscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1); i__1 = *n; for (k = ki + 1; k <= i__1; ++k) { vr[k + (is - 1) * vr_dim1] = 0.f; vr[k + is * vr_dim1] = 0.f; /* L110: */ } } else { if (ki > 2) { i__1 = ki - 2; sgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, & work[*n + 1], &c__1, &work[ki - 1 + *n], &vr[( ki - 1) * vr_dim1 + 1], &c__1); i__1 = ki - 2; sgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, & work[n2 + 1], &c__1, &work[ki + n2], &vr[ki * vr_dim1 + 1], &c__1); } else { sscal_(n, &work[ki - 1 + *n], &vr[(ki - 1) * vr_dim1 + 1], &c__1); sscal_(n, &work[ki + n2], &vr[ki * vr_dim1 + 1], & c__1); } emax = 0.f; i__1 = *n; for (k = 1; k <= i__1; ++k) { /* Computing MAX */ r__3 = emax, r__4 = (r__1 = vr[k + (ki - 1) * vr_dim1] , dabs(r__1)) + (r__2 = vr[k + ki * vr_dim1], dabs(r__2)); emax = dmax(r__3,r__4); /* L120: */ } remax = 1.f / emax; sscal_(n, &remax, &vr[(ki - 1) * vr_dim1 + 1], &c__1); sscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1); } } --is; if (ip != 0) { --is; } L130: if (ip == 1) { ip = 0; } if (ip == -1) { ip = 1; } /* L140: */ } } if (leftv) { /* Compute left eigenvectors. */ ip = 0; is = 1; i__1 = *n; for (ki = 1; ki <= i__1; ++ki) { if (ip == -1) { goto L250; } if (ki == *n) { goto L150; } if (t[ki + 1 + ki * t_dim1] == 0.f) { goto L150; } ip = 1; L150: if (somev) { if (! select[ki]) { goto L250; } } /* Compute the KI-th eigenvalue (WR,WI). */ wr = t[ki + ki * t_dim1]; wi = 0.f; if (ip != 0) { wi = sqrt((r__1 = t[ki + (ki + 1) * t_dim1], dabs(r__1))) * sqrt((r__2 = t[ki + 1 + ki * t_dim1], dabs(r__2))); } /* Computing MAX */ r__1 = ulp * (dabs(wr) + dabs(wi)); smin = dmax(r__1,smlnum); if (ip == 0) { /* Real left eigenvector. */ work[ki + *n] = 1.f; /* Form right-hand side */ i__2 = *n; for (k = ki + 1; k <= i__2; ++k) { work[k + *n] = -t[ki + k * t_dim1]; /* L160: */ } /* Solve the quasi-triangular system: */ /* (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK */ vmax = 1.f; vcrit = bignum; jnxt = ki + 1; i__2 = *n; for (j = ki + 1; j <= i__2; ++j) { if (j < jnxt) { goto L170; } j1 = j; j2 = j; jnxt = j + 1; if (j < *n) { if (t[j + 1 + j * t_dim1] != 0.f) { j2 = j + 1; jnxt = j + 2; } } if (j1 == j2) { /* 1-by-1 diagonal block */ /* Scale if necessary to avoid overflow when forming */ /* the right-hand side. */ if (work[j] > vcrit) { rec = 1.f / vmax; i__3 = *n - ki + 1; sscal_(&i__3, &rec, &work[ki + *n], &c__1); vmax = 1.f; vcrit = bignum; } i__3 = j - ki - 1; work[j + *n] -= sdot_(&i__3, &t[ki + 1 + j * t_dim1], &c__1, &work[ki + 1 + *n], &c__1); /* Solve (T(J,J)-WR)'*X = WORK */ slaln2_(&c_false, &c__1, &c__1, &smin, &c_b22, &t[j + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm, &ierr); /* Scale if necessary */ if (scale != 1.f) { i__3 = *n - ki + 1; sscal_(&i__3, &scale, &work[ki + *n], &c__1); } work[j + *n] = x[0]; /* Computing MAX */ r__2 = (r__1 = work[j + *n], dabs(r__1)); vmax = dmax(r__2,vmax); vcrit = bignum / vmax; } else { /* 2-by-2 diagonal block */ /* Scale if necessary to avoid overflow when forming */ /* the right-hand side. */ /* Computing MAX */ r__1 = work[j], r__2 = work[j + 1]; beta = dmax(r__1,r__2); if (beta > vcrit) { rec = 1.f / vmax; i__3 = *n - ki + 1; sscal_(&i__3, &rec, &work[ki + *n], &c__1); vmax = 1.f; vcrit = bignum; } i__3 = j - ki - 1; work[j + *n] -= sdot_(&i__3, &t[ki + 1 + j * t_dim1], &c__1, &work[ki + 1 + *n], &c__1); i__3 = j - ki - 1; work[j + 1 + *n] -= sdot_(&i__3, &t[ki + 1 + (j + 1) * t_dim1], &c__1, &work[ki + 1 + *n], &c__1); /* Solve */ /* [T(J,J)-WR T(J,J+1) ]'* X = SCALE*( WORK1 ) */ /* [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 ) */ slaln2_(&c_true, &c__2, &c__1, &smin, &c_b22, &t[j + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm, &ierr); /* Scale if necessary */ if (scale != 1.f) { i__3 = *n - ki + 1; sscal_(&i__3, &scale, &work[ki + *n], &c__1); } work[j + *n] = x[0]; work[j + 1 + *n] = x[1]; /* Computing MAX */ r__3 = (r__1 = work[j + *n], dabs(r__1)), r__4 = ( r__2 = work[j + 1 + *n], dabs(r__2)), r__3 = max(r__3,r__4); vmax = dmax(r__3,vmax); vcrit = bignum / vmax; } L170: ; } /* Copy the vector x or Q*x to VL and normalize. */ if (! over) { i__2 = *n - ki + 1; scopy_(&i__2, &work[ki + *n], &c__1, &vl[ki + is * vl_dim1], &c__1); i__2 = *n - ki + 1; ii = isamax_(&i__2, &vl[ki + is * vl_dim1], &c__1) + ki - 1; remax = 1.f / (r__1 = vl[ii + is * vl_dim1], dabs(r__1)); i__2 = *n - ki + 1; sscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1); i__2 = ki - 1; for (k = 1; k <= i__2; ++k) { vl[k + is * vl_dim1] = 0.f; /* L180: */ } } else { if (ki < *n) { i__2 = *n - ki; sgemv_("N", n, &i__2, &c_b22, &vl[(ki + 1) * vl_dim1 + 1], ldvl, &work[ki + 1 + *n], &c__1, &work[ ki + *n], &vl[ki * vl_dim1 + 1], &c__1); } ii = isamax_(n, &vl[ki * vl_dim1 + 1], &c__1); remax = 1.f / (r__1 = vl[ii + ki * vl_dim1], dabs(r__1)); sscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1); } } else { /* Complex left eigenvector. */ /* Initial solve: */ /* ((T(KI,KI) T(KI,KI+1) )' - (WR - I* WI))*X = 0. */ /* ((T(KI+1,KI) T(KI+1,KI+1)) ) */ if ((r__1 = t[ki + (ki + 1) * t_dim1], dabs(r__1)) >= (r__2 = t[ki + 1 + ki * t_dim1], dabs(r__2))) { work[ki + *n] = wi / t[ki + (ki + 1) * t_dim1]; work[ki + 1 + n2] = 1.f; } else { work[ki + *n] = 1.f; work[ki + 1 + n2] = -wi / t[ki + 1 + ki * t_dim1]; } work[ki + 1 + *n] = 0.f; work[ki + n2] = 0.f; /* Form right-hand side */ i__2 = *n; for (k = ki + 2; k <= i__2; ++k) { work[k + *n] = -work[ki + *n] * t[ki + k * t_dim1]; work[k + n2] = -work[ki + 1 + n2] * t[ki + 1 + k * t_dim1] ; /* L190: */ } /* Solve complex quasi-triangular system: */ /* ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2 */ vmax = 1.f; vcrit = bignum; jnxt = ki + 2; i__2 = *n; for (j = ki + 2; j <= i__2; ++j) { if (j < jnxt) { goto L200; } j1 = j; j2 = j; jnxt = j + 1; if (j < *n) { if (t[j + 1 + j * t_dim1] != 0.f) { j2 = j + 1; jnxt = j + 2; } } if (j1 == j2) { /* 1-by-1 diagonal block */ /* Scale if necessary to avoid overflow when */ /* forming the right-hand side elements. */ if (work[j] > vcrit) { rec = 1.f / vmax; i__3 = *n - ki + 1; sscal_(&i__3, &rec, &work[ki + *n], &c__1); i__3 = *n - ki + 1; sscal_(&i__3, &rec, &work[ki + n2], &c__1); vmax = 1.f; vcrit = bignum; } i__3 = j - ki - 2; work[j + *n] -= sdot_(&i__3, &t[ki + 2 + j * t_dim1], &c__1, &work[ki + 2 + *n], &c__1); i__3 = j - ki - 2; work[j + n2] -= sdot_(&i__3, &t[ki + 2 + j * t_dim1], &c__1, &work[ki + 2 + n2], &c__1); /* Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2 */ r__1 = -wi; slaln2_(&c_false, &c__1, &c__2, &smin, &c_b22, &t[j + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * n], n, &wr, &r__1, x, &c__2, &scale, &xnorm, & ierr); /* Scale if necessary */ if (scale != 1.f) { i__3 = *n - ki + 1; sscal_(&i__3, &scale, &work[ki + *n], &c__1); i__3 = *n - ki + 1; sscal_(&i__3, &scale, &work[ki + n2], &c__1); } work[j + *n] = x[0]; work[j + n2] = x[2]; /* Computing MAX */ r__3 = (r__1 = work[j + *n], dabs(r__1)), r__4 = ( r__2 = work[j + n2], dabs(r__2)), r__3 = max( r__3,r__4); vmax = dmax(r__3,vmax); vcrit = bignum / vmax; } else { /* 2-by-2 diagonal block */ /* Scale if necessary to avoid overflow when forming */ /* the right-hand side elements. */ /* Computing MAX */ r__1 = work[j], r__2 = work[j + 1]; beta = dmax(r__1,r__2); if (beta > vcrit) { rec = 1.f / vmax; i__3 = *n - ki + 1; sscal_(&i__3, &rec, &work[ki + *n], &c__1); i__3 = *n - ki + 1; sscal_(&i__3, &rec, &work[ki + n2], &c__1); vmax = 1.f; vcrit = bignum; } i__3 = j - ki - 2; work[j + *n] -= sdot_(&i__3, &t[ki + 2 + j * t_dim1], &c__1, &work[ki + 2 + *n], &c__1); i__3 = j - ki - 2; work[j + n2] -= sdot_(&i__3, &t[ki + 2 + j * t_dim1], &c__1, &work[ki + 2 + n2], &c__1); i__3 = j - ki - 2; work[j + 1 + *n] -= sdot_(&i__3, &t[ki + 2 + (j + 1) * t_dim1], &c__1, &work[ki + 2 + *n], &c__1); i__3 = j - ki - 2; work[j + 1 + n2] -= sdot_(&i__3, &t[ki + 2 + (j + 1) * t_dim1], &c__1, &work[ki + 2 + n2], &c__1); /* Solve 2-by-2 complex linear equation */ /* ([T(j,j) T(j,j+1) ]'-(wr-i*wi)*I)*X = SCALE*B */ /* ([T(j+1,j) T(j+1,j+1)] ) */ r__1 = -wi; slaln2_(&c_true, &c__2, &c__2, &smin, &c_b22, &t[j + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * n], n, &wr, &r__1, x, &c__2, &scale, &xnorm, & ierr); /* Scale if necessary */ if (scale != 1.f) { i__3 = *n - ki + 1; sscal_(&i__3, &scale, &work[ki + *n], &c__1); i__3 = *n - ki + 1; sscal_(&i__3, &scale, &work[ki + n2], &c__1); } work[j + *n] = x[0]; work[j + n2] = x[2]; work[j + 1 + *n] = x[1]; work[j + 1 + n2] = x[3]; /* Computing MAX */ r__1 = dabs(x[0]), r__2 = dabs(x[2]), r__1 = max(r__1, r__2), r__2 = dabs(x[1]), r__1 = max(r__1, r__2), r__2 = dabs(x[3]), r__1 = max(r__1, r__2); vmax = dmax(r__1,vmax); vcrit = bignum / vmax; } L200: ; } /* Copy the vector x or Q*x to VL and normalize. */ if (! over) { i__2 = *n - ki + 1; scopy_(&i__2, &work[ki + *n], &c__1, &vl[ki + is * vl_dim1], &c__1); i__2 = *n - ki + 1; scopy_(&i__2, &work[ki + n2], &c__1, &vl[ki + (is + 1) * vl_dim1], &c__1); emax = 0.f; i__2 = *n; for (k = ki; k <= i__2; ++k) { /* Computing MAX */ r__3 = emax, r__4 = (r__1 = vl[k + is * vl_dim1], dabs(r__1)) + (r__2 = vl[k + (is + 1) * vl_dim1], dabs(r__2)); emax = dmax(r__3,r__4); /* L220: */ } remax = 1.f / emax; i__2 = *n - ki + 1; sscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1); i__2 = *n - ki + 1; sscal_(&i__2, &remax, &vl[ki + (is + 1) * vl_dim1], &c__1) ; i__2 = ki - 1; for (k = 1; k <= i__2; ++k) { vl[k + is * vl_dim1] = 0.f; vl[k + (is + 1) * vl_dim1] = 0.f; /* L230: */ } } else { if (ki < *n - 1) { i__2 = *n - ki - 1; sgemv_("N", n, &i__2, &c_b22, &vl[(ki + 2) * vl_dim1 + 1], ldvl, &work[ki + 2 + *n], &c__1, &work[ ki + *n], &vl[ki * vl_dim1 + 1], &c__1); i__2 = *n - ki - 1; sgemv_("N", n, &i__2, &c_b22, &vl[(ki + 2) * vl_dim1 + 1], ldvl, &work[ki + 2 + n2], &c__1, &work[ ki + 1 + n2], &vl[(ki + 1) * vl_dim1 + 1], & c__1); } else { sscal_(n, &work[ki + *n], &vl[ki * vl_dim1 + 1], & c__1); sscal_(n, &work[ki + 1 + n2], &vl[(ki + 1) * vl_dim1 + 1], &c__1); } emax = 0.f; i__2 = *n; for (k = 1; k <= i__2; ++k) { /* Computing MAX */ r__3 = emax, r__4 = (r__1 = vl[k + ki * vl_dim1], dabs(r__1)) + (r__2 = vl[k + (ki + 1) * vl_dim1], dabs(r__2)); emax = dmax(r__3,r__4); /* L240: */ } remax = 1.f / emax; sscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1); sscal_(n, &remax, &vl[(ki + 1) * vl_dim1 + 1], &c__1); } } ++is; if (ip != 0) { ++is; } L250: if (ip == -1) { ip = 0; } if (ip == 1) { ip = -1; } /* L260: */ } } return 0; /* End of STREVC */ } /* strevc_ */