/* Subroutine */ int dlaqtr_(logical *ltran, logical *lreal, integer *n, doublereal *t, integer *ldt, doublereal *b, doublereal *w, doublereal *scale, doublereal *x, doublereal *work, integer *info) { /* System generated locals */ integer t_dim1, t_offset, i__1, i__2; doublereal d__1, d__2, d__3, d__4, d__5, d__6; /* Local variables */ doublereal d__[4] /* was [2][2] */; integer i__, j, k; doublereal v[4] /* was [2][2] */, z__; integer j1, j2, n1, n2; doublereal si, xj, sr, rec, eps, tjj, tmp; extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *); integer ierr; doublereal smin, xmax; extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, integer *); extern doublereal dasum_(integer *, doublereal *, integer *); extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *); integer jnext; doublereal sminw, xnorm; extern /* Subroutine */ int dlaln2_(logical *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal * , doublereal *, integer *, doublereal *, doublereal *, integer *); extern doublereal dlamch_(char *), dlange_(char *, integer *, integer *, doublereal *, integer *, doublereal *); extern integer idamax_(integer *, doublereal *, integer *); doublereal scaloc; extern /* Subroutine */ int dladiv_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *); doublereal bignum; logical notran; doublereal smlnum; /* -- LAPACK auxiliary routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* DLAQTR 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 DTRSNA. */ /* 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) DOUBLE PRECISION array, dimension (LDT,N) */ /* On entry, T contains a matrix in Schur canonical form. */ /* If LREAL = .FALSE., then the first diagonal block of T mu */ /* be 1 by 1. */ /* LDT (input) INTEGER */ /* The leading dimension of the matrix T. LDT >= max(1,N). */ /* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION */ /* On entry, W is the diagonal element of the matrix B. */ /* If LREAL = .TRUE., W is not referenced. */ /* SCALE (output) DOUBLE PRECISION */ /* On exit, SCALE is the scale factor. */ /* X (input/output) DOUBLE PRECISION 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) DOUBLE PRECISION 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 DLALN2 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 = dlamch_("P"); smlnum = dlamch_("S") / eps; bignum = 1. / smlnum; xnorm = dlange_("M", n, n, &t[t_offset], ldt, d__); if (! (*lreal)) { /* Computing MAX */ d__1 = xnorm, d__2 = abs(*w), d__1 = max(d__1,d__2), d__2 = dlange_( "M", n, &c__1, &b[1], n, d__); xnorm = max(d__1,d__2); } /* Computing MAX */ d__1 = smlnum, d__2 = eps * xnorm; smin = max(d__1,d__2); /* Compute 1-norm of each column of strictly upper triangular */ /* part of T to control overflow in triangular solver. */ work[1] = 0.; i__1 = *n; for (j = 2; j <= i__1; ++j) { i__2 = j - 1; work[j] = dasum_(&i__2, &t[j * t_dim1 + 1], &c__1); /* L10: */ } if (! (*lreal)) { i__1 = *n; for (i__ = 2; i__ <= i__1; ++i__) { work[i__] += (d__1 = b[i__], abs(d__1)); /* L20: */ } } n2 = *n << 1; n1 = *n; if (! (*lreal)) { n1 = n2; } k = idamax_(&n1, &x[1], &c__1); xmax = (d__1 = x[k], abs(d__1)); *scale = 1.; if (xmax > bignum) { *scale = bignum / xmax; dscal_(&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.) { 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 = (d__1 = x[j1], abs(d__1)); tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1)); tmp = t[j1 + j1 * t_dim1]; if (tjj < smin) { tmp = smin; tjj = smin; *info = 1; } if (xj == 0.) { goto L30; } if (tjj < 1.) { if (xj > bignum * tjj) { rec = 1. / xj; dscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } x[j1] /= tmp; xj = (d__1 = x[j1], abs(d__1)); /* Scale x if necessary to avoid overflow when adding a */ /* multiple of column j1 of T. */ if (xj > 1.) { rec = 1. / xj; if (work[j1] > (bignum - xmax) * rec) { dscal_(n, &rec, &x[1], &c__1); *scale *= rec; } } if (j1 > 1) { i__1 = j1 - 1; d__1 = -x[j1]; daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] , &c__1); i__1 = j1 - 1; k = idamax_(&i__1, &x[1], &c__1); xmax = (d__1 = x[k], abs(d__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]; dlaln2_(&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.) { dscal_(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 */ d__1 = abs(v[0]), d__2 = abs(v[1]); xj = max(d__1,d__2); if (xj > 1.) { rec = 1. / xj; /* Computing MAX */ d__1 = work[j1], d__2 = work[j2]; if (max(d__1,d__2) > (bignum - xmax) * rec) { dscal_(n, &rec, &x[1], &c__1); *scale *= rec; } } /* Update right-hand side */ if (j1 > 1) { i__1 = j1 - 1; d__1 = -x[j1]; daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] , &c__1); i__1 = j1 - 1; d__1 = -x[j2]; daxpy_(&i__1, &d__1, &t[j2 * t_dim1 + 1], &c__1, &x[1] , &c__1); i__1 = j1 - 1; k = idamax_(&i__1, &x[1], &c__1); xmax = (d__1 = x[k], abs(d__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.) { 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 = (d__1 = x[j1], abs(d__1)); if (xmax > 1.) { rec = 1. / xmax; if (work[j1] > (bignum - xj) * rec) { dscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__2 = j1 - 1; x[j1] -= ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], & c__1); xj = (d__1 = x[j1], abs(d__1)); tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1)); tmp = t[j1 + j1 * t_dim1]; if (tjj < smin) { tmp = smin; tjj = smin; *info = 1; } if (tjj < 1.) { if (xj > bignum * tjj) { rec = 1. / xj; dscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } x[j1] /= tmp; /* Computing MAX */ d__2 = xmax, d__3 = (d__1 = x[j1], abs(d__1)); xmax = max(d__2,d__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 */ d__3 = (d__1 = x[j1], abs(d__1)), d__4 = (d__2 = x[j2], abs(d__2)); xj = max(d__3,d__4); if (xmax > 1.) { rec = 1. / xmax; /* Computing MAX */ d__1 = work[j2], d__2 = work[j1]; if (max(d__1,d__2) > (bignum - xj) * rec) { dscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__2 = j1 - 1; d__[0] = x[j1] - ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], &c__1); i__2 = j1 - 1; d__[1] = x[j2] - ddot_(&i__2, &t[j2 * t_dim1 + 1], &c__1, &x[1], &c__1); dlaln2_(&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.) { dscal_(n, &scaloc, &x[1], &c__1); *scale *= scaloc; } x[j1] = v[0]; x[j2] = v[1]; /* Computing MAX */ d__3 = (d__1 = x[j1], abs(d__1)), d__4 = (d__2 = x[j2], abs(d__2)), d__3 = max(d__3,d__4); xmax = max(d__3,xmax); } L40: ; } } } else { /* Computing MAX */ d__1 = eps * abs(*w); sminw = max(d__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.) { 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 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], abs( d__2)); tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1)) + abs(z__); tmp = t[j1 + j1 * t_dim1]; if (tjj < sminw) { tmp = sminw; tjj = sminw; *info = 1; } if (xj == 0.) { goto L70; } if (tjj < 1.) { if (xj > bignum * tjj) { rec = 1. / xj; dscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } dladiv_(&x[j1], &x[*n + j1], &tmp, &z__, &sr, &si); x[j1] = sr; x[*n + j1] = si; xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], abs( d__2)); /* Scale x if necessary to avoid overflow when adding a */ /* multiple of column j1 of T. */ if (xj > 1.) { rec = 1. / xj; if (work[j1] > (bignum - xmax) * rec) { dscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; } } if (j1 > 1) { i__1 = j1 - 1; d__1 = -x[j1]; daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] , &c__1); i__1 = j1 - 1; d__1 = -x[*n + j1]; daxpy_(&i__1, &d__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.; i__1 = j1 - 1; for (k = 1; k <= i__1; ++k) { /* Computing MAX */ d__3 = xmax, d__4 = (d__1 = x[k], abs(d__1)) + ( d__2 = x[k + *n], abs(d__2)); xmax = max(d__3,d__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]; d__1 = -(*w); dlaln2_(&c_false, &c__2, &c__2, &sminw, &c_b21, &t[j1 + j1 * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, & c_b25, &d__1, v, &c__2, &scaloc, &xnorm, &ierr); if (ierr != 0) { *info = 2; } if (scaloc != 1.) { i__1 = *n << 1; dscal_(&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 */ d__1 = abs(v[0]) + abs(v[2]), d__2 = abs(v[1]) + abs(v[3]) ; xj = max(d__1,d__2); if (xj > 1.) { rec = 1. / xj; /* Computing MAX */ d__1 = work[j1], d__2 = work[j2]; if (max(d__1,d__2) > (bignum - xmax) * rec) { dscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; } } /* Update the right-hand side. */ if (j1 > 1) { i__1 = j1 - 1; d__1 = -x[j1]; daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] , &c__1); i__1 = j1 - 1; d__1 = -x[j2]; daxpy_(&i__1, &d__1, &t[j2 * t_dim1 + 1], &c__1, &x[1] , &c__1); i__1 = j1 - 1; d__1 = -x[*n + j1]; daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[* n + 1], &c__1); i__1 = j1 - 1; d__1 = -x[*n + j2]; daxpy_(&i__1, &d__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.; i__1 = j1 - 1; for (k = 1; k <= i__1; ++k) { /* Computing MAX */ d__3 = (d__1 = x[k], abs(d__1)) + (d__2 = x[k + * n], abs(d__2)); xmax = max(d__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.) { 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 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n], abs( d__2)); if (xmax > 1.) { rec = 1. / xmax; if (work[j1] > (bignum - xj) * rec) { dscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__2 = j1 - 1; x[j1] -= ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], & c__1); i__2 = j1 - 1; x[*n + j1] -= ddot_(&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 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n], abs( d__2)); z__ = *w; if (j1 == 1) { z__ = b[1]; } /* Scale if necessary to avoid overflow in */ /* complex division */ tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1)) + abs(z__); tmp = t[j1 + j1 * t_dim1]; if (tjj < sminw) { tmp = sminw; tjj = sminw; *info = 1; } if (tjj < 1.) { if (xj > bignum * tjj) { rec = 1. / xj; dscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } d__1 = -z__; dladiv_(&x[j1], &x[*n + j1], &tmp, &d__1, &sr, &si); x[j1] = sr; x[j1 + *n] = si; /* Computing MAX */ d__3 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n], abs(d__2)); xmax = max(d__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 */ d__5 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], abs(d__2)), d__6 = (d__3 = x[j2], abs(d__3)) + ( d__4 = x[*n + j2], abs(d__4)); xj = max(d__5,d__6); if (xmax > 1.) { rec = 1. / xmax; /* Computing MAX */ d__1 = work[j1], d__2 = work[j2]; if (max(d__1,d__2) > (bignum - xj) / xmax) { dscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__2 = j1 - 1; d__[0] = x[j1] - ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], &c__1); i__2 = j1 - 1; d__[1] = x[j2] - ddot_(&i__2, &t[j2 * t_dim1 + 1], &c__1, &x[1], &c__1); i__2 = j1 - 1; d__[2] = x[*n + j1] - ddot_(&i__2, &t[j1 * t_dim1 + 1], & c__1, &x[*n + 1], &c__1); i__2 = j1 - 1; d__[3] = x[*n + j2] - ddot_(&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]; dlaln2_(&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.) { dscal_(&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 */ d__5 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], abs(d__2)), d__6 = (d__3 = x[j2], abs(d__3)) + ( d__4 = x[*n + j2], abs(d__4)), d__5 = max(d__5, d__6); xmax = max(d__5,xmax); } L80: ; } } } return 0; /* End of DLAQTR */ } /* dlaqtr_ */
/* Subroutine */ int dlaein_(logical *rightv, logical *noinit, integer *n, doublereal *h__, integer *ldh, doublereal *wr, doublereal *wi, doublereal *vr, doublereal *vi, doublereal *b, integer *ldb, doublereal *work, doublereal *eps3, doublereal *smlnum, doublereal * bignum, integer *info) { /* System generated locals */ integer b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4; doublereal d__1, d__2, d__3, d__4; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ integer i__, j; doublereal w, x, y; integer i1, i2, i3; doublereal w1, ei, ej, xi, xr, rec; integer its, ierr; doublereal temp, norm, vmax; extern doublereal dnrm2_(integer *, doublereal *, integer *); extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, integer *); doublereal scale; extern doublereal dasum_(integer *, doublereal *, integer *); char trans[1]; doublereal vcrit, rootn, vnorm; extern doublereal dlapy2_(doublereal *, doublereal *); doublereal absbii, absbjj; extern integer idamax_(integer *, doublereal *, integer *); extern /* Subroutine */ int dladiv_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *), dlatrs_( char *, char *, char *, char *, integer *, doublereal *, integer * , doublereal *, doublereal *, doublereal *, integer *); char normin[1]; doublereal nrmsml, growto; /* -- LAPACK auxiliary routine (version 3.4.2) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* September 2012 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; --vr; --vi; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; --work; /* Function Body */ *info = 0; /* GROWTO is the threshold used in the acceptance test for an */ /* eigenvector. */ rootn = sqrt((doublereal) (*n)); growto = .1 / rootn; /* Computing MAX */ d__1 = 1.; d__2 = *eps3 * rootn; // , expr subst nrmsml = max(d__1,d__2) * *smlnum; /* Form B = H - (WR,WI)*I (except that the subdiagonal elements and */ /* the imaginary parts of the diagonal elements are not stored). */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { b[i__ + j * b_dim1] = h__[i__ + j * h_dim1]; /* L10: */ } b[j + j * b_dim1] = h__[j + j * h_dim1] - *wr; /* L20: */ } if (*wi == 0.) { /* Real eigenvalue. */ if (*noinit) { /* Set initial vector. */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { vr[i__] = *eps3; /* L30: */ } } else { /* Scale supplied initial vector. */ vnorm = dnrm2_(n, &vr[1], &c__1); d__1 = *eps3 * rootn / max(vnorm,nrmsml); dscal_(n, &d__1, &vr[1], &c__1); } if (*rightv) { /* LU decomposition with partial pivoting of B, replacing zero */ /* pivots by EPS3. */ i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { ei = h__[i__ + 1 + i__ * h_dim1]; if ((d__1 = b[i__ + i__ * b_dim1], abs(d__1)) < abs(ei)) { /* Interchange rows and eliminate. */ x = b[i__ + i__ * b_dim1] / ei; b[i__ + i__ * b_dim1] = ei; i__2 = *n; for (j = i__ + 1; j <= i__2; ++j) { temp = b[i__ + 1 + j * b_dim1]; b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - x * temp; b[i__ + j * b_dim1] = temp; /* L40: */ } } else { /* Eliminate without interchange. */ if (b[i__ + i__ * b_dim1] == 0.) { b[i__ + i__ * b_dim1] = *eps3; } x = ei / b[i__ + i__ * b_dim1]; if (x != 0.) { i__2 = *n; for (j = i__ + 1; j <= i__2; ++j) { b[i__ + 1 + j * b_dim1] -= x * b[i__ + j * b_dim1] ; /* L50: */ } } } /* L60: */ } if (b[*n + *n * b_dim1] == 0.) { b[*n + *n * b_dim1] = *eps3; } *(unsigned char *)trans = 'N'; } else { /* UL decomposition with partial pivoting of B, replacing zero */ /* pivots by EPS3. */ for (j = *n; j >= 2; --j) { ej = h__[j + (j - 1) * h_dim1]; if ((d__1 = b[j + j * b_dim1], abs(d__1)) < abs(ej)) { /* Interchange columns and eliminate. */ x = b[j + j * b_dim1] / ej; b[j + j * b_dim1] = ej; i__1 = j - 1; for (i__ = 1; i__ <= i__1; ++i__) { temp = b[i__ + (j - 1) * b_dim1]; b[i__ + (j - 1) * b_dim1] = b[i__ + j * b_dim1] - x * temp; b[i__ + j * b_dim1] = temp; /* L70: */ } } else { /* Eliminate without interchange. */ if (b[j + j * b_dim1] == 0.) { b[j + j * b_dim1] = *eps3; } x = ej / b[j + j * b_dim1]; if (x != 0.) { i__1 = j - 1; for (i__ = 1; i__ <= i__1; ++i__) { b[i__ + (j - 1) * b_dim1] -= x * b[i__ + j * b_dim1]; /* L80: */ } } } /* L90: */ } if (b[b_dim1 + 1] == 0.) { b[b_dim1 + 1] = *eps3; } *(unsigned char *)trans = 'T'; } *(unsigned char *)normin = 'N'; i__1 = *n; for (its = 1; its <= i__1; ++its) { /* Solve U*x = scale*v for a right eigenvector */ /* or U**T*x = scale*v for a left eigenvector, */ /* overwriting x on v. */ dlatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, & vr[1], &scale, &work[1], &ierr); *(unsigned char *)normin = 'Y'; /* Test for sufficient growth in the norm of v. */ vnorm = dasum_(n, &vr[1], &c__1); if (vnorm >= growto * scale) { goto L120; } /* Choose new orthogonal starting vector and try again. */ temp = *eps3 / (rootn + 1.); vr[1] = *eps3; i__2 = *n; for (i__ = 2; i__ <= i__2; ++i__) { vr[i__] = temp; /* L100: */ } vr[*n - its + 1] -= *eps3 * rootn; /* L110: */ } /* Failure to find eigenvector in N iterations. */ *info = 1; L120: /* Normalize eigenvector. */ i__ = idamax_(n, &vr[1], &c__1); d__2 = 1. / (d__1 = vr[i__], abs(d__1)); dscal_(n, &d__2, &vr[1], &c__1); } else { /* Complex eigenvalue. */ if (*noinit) { /* Set initial vector. */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { vr[i__] = *eps3; vi[i__] = 0.; /* L130: */ } } else { /* Scale supplied initial vector. */ d__1 = dnrm2_(n, &vr[1], &c__1); d__2 = dnrm2_(n, &vi[1], &c__1); norm = dlapy2_(&d__1, &d__2); rec = *eps3 * rootn / max(norm,nrmsml); dscal_(n, &rec, &vr[1], &c__1); dscal_(n, &rec, &vi[1], &c__1); } if (*rightv) { /* LU decomposition with partial pivoting of B, replacing zero */ /* pivots by EPS3. */ /* The imaginary part of the (i,j)-th element of U is stored in */ /* B(j+1,i). */ b[b_dim1 + 2] = -(*wi); i__1 = *n; for (i__ = 2; i__ <= i__1; ++i__) { b[i__ + 1 + b_dim1] = 0.; /* L140: */ } i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { absbii = dlapy2_(&b[i__ + i__ * b_dim1], &b[i__ + 1 + i__ * b_dim1]); ei = h__[i__ + 1 + i__ * h_dim1]; if (absbii < abs(ei)) { /* Interchange rows and eliminate. */ xr = b[i__ + i__ * b_dim1] / ei; xi = b[i__ + 1 + i__ * b_dim1] / ei; b[i__ + i__ * b_dim1] = ei; b[i__ + 1 + i__ * b_dim1] = 0.; i__2 = *n; for (j = i__ + 1; j <= i__2; ++j) { temp = b[i__ + 1 + j * b_dim1]; b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - xr * temp; b[j + 1 + (i__ + 1) * b_dim1] = b[j + 1 + i__ * b_dim1] - xi * temp; b[i__ + j * b_dim1] = temp; b[j + 1 + i__ * b_dim1] = 0.; /* L150: */ } b[i__ + 2 + i__ * b_dim1] = -(*wi); b[i__ + 1 + (i__ + 1) * b_dim1] -= xi * *wi; b[i__ + 2 + (i__ + 1) * b_dim1] += xr * *wi; } else { /* Eliminate without interchanging rows. */ if (absbii == 0.) { b[i__ + i__ * b_dim1] = *eps3; b[i__ + 1 + i__ * b_dim1] = 0.; absbii = *eps3; } ei = ei / absbii / absbii; xr = b[i__ + i__ * b_dim1] * ei; xi = -b[i__ + 1 + i__ * b_dim1] * ei; i__2 = *n; for (j = i__ + 1; j <= i__2; ++j) { b[i__ + 1 + j * b_dim1] = b[i__ + 1 + j * b_dim1] - xr * b[i__ + j * b_dim1] + xi * b[j + 1 + i__ * b_dim1]; b[j + 1 + (i__ + 1) * b_dim1] = -xr * b[j + 1 + i__ * b_dim1] - xi * b[i__ + j * b_dim1]; /* L160: */ } b[i__ + 2 + (i__ + 1) * b_dim1] -= *wi; } /* Compute 1-norm of offdiagonal elements of i-th row. */ i__2 = *n - i__; i__3 = *n - i__; work[i__] = dasum_(&i__2, &b[i__ + (i__ + 1) * b_dim1], ldb) + dasum_(&i__3, &b[i__ + 2 + i__ * b_dim1], &c__1); /* L170: */ } if (b[*n + *n * b_dim1] == 0. && b[*n + 1 + *n * b_dim1] == 0.) { b[*n + *n * b_dim1] = *eps3; } work[*n] = 0.; i1 = *n; i2 = 1; i3 = -1; } else { /* UL decomposition with partial pivoting of conjg(B), */ /* replacing zero pivots by EPS3. */ /* The imaginary part of the (i,j)-th element of U is stored in */ /* B(j+1,i). */ b[*n + 1 + *n * b_dim1] = *wi; i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { b[*n + 1 + j * b_dim1] = 0.; /* L180: */ } for (j = *n; j >= 2; --j) { ej = h__[j + (j - 1) * h_dim1]; absbjj = dlapy2_(&b[j + j * b_dim1], &b[j + 1 + j * b_dim1]); if (absbjj < abs(ej)) { /* Interchange columns and eliminate */ xr = b[j + j * b_dim1] / ej; xi = b[j + 1 + j * b_dim1] / ej; b[j + j * b_dim1] = ej; b[j + 1 + j * b_dim1] = 0.; i__1 = j - 1; for (i__ = 1; i__ <= i__1; ++i__) { temp = b[i__ + (j - 1) * b_dim1]; b[i__ + (j - 1) * b_dim1] = b[i__ + j * b_dim1] - xr * temp; b[j + i__ * b_dim1] = b[j + 1 + i__ * b_dim1] - xi * temp; b[i__ + j * b_dim1] = temp; b[j + 1 + i__ * b_dim1] = 0.; /* L190: */ } b[j + 1 + (j - 1) * b_dim1] = *wi; b[j - 1 + (j - 1) * b_dim1] += xi * *wi; b[j + (j - 1) * b_dim1] -= xr * *wi; } else { /* Eliminate without interchange. */ if (absbjj == 0.) { b[j + j * b_dim1] = *eps3; b[j + 1 + j * b_dim1] = 0.; absbjj = *eps3; } ej = ej / absbjj / absbjj; xr = b[j + j * b_dim1] * ej; xi = -b[j + 1 + j * b_dim1] * ej; i__1 = j - 1; for (i__ = 1; i__ <= i__1; ++i__) { b[i__ + (j - 1) * b_dim1] = b[i__ + (j - 1) * b_dim1] - xr * b[i__ + j * b_dim1] + xi * b[j + 1 + i__ * b_dim1]; b[j + i__ * b_dim1] = -xr * b[j + 1 + i__ * b_dim1] - xi * b[i__ + j * b_dim1]; /* L200: */ } b[j + (j - 1) * b_dim1] += *wi; } /* Compute 1-norm of offdiagonal elements of j-th column. */ i__1 = j - 1; i__2 = j - 1; work[j] = dasum_(&i__1, &b[j * b_dim1 + 1], &c__1) + dasum_(& i__2, &b[j + 1 + b_dim1], ldb); /* L210: */ } if (b[b_dim1 + 1] == 0. && b[b_dim1 + 2] == 0.) { b[b_dim1 + 1] = *eps3; } work[1] = 0.; i1 = 1; i2 = *n; i3 = 1; } i__1 = *n; for (its = 1; its <= i__1; ++its) { scale = 1.; vmax = 1.; vcrit = *bignum; /* Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector, */ /* or U**T*(xr,xi) = scale*(vr,vi) for a left eigenvector, */ /* overwriting (xr,xi) on (vr,vi). */ i__2 = i2; i__3 = i3; for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) { if (work[i__] > vcrit) { rec = 1. / vmax; dscal_(n, &rec, &vr[1], &c__1); dscal_(n, &rec, &vi[1], &c__1); scale *= rec; vmax = 1.; vcrit = *bignum; } xr = vr[i__]; xi = vi[i__]; if (*rightv) { i__4 = *n; for (j = i__ + 1; j <= i__4; ++j) { xr = xr - b[i__ + j * b_dim1] * vr[j] + b[j + 1 + i__ * b_dim1] * vi[j]; xi = xi - b[i__ + j * b_dim1] * vi[j] - b[j + 1 + i__ * b_dim1] * vr[j]; /* L220: */ } } else { i__4 = i__ - 1; for (j = 1; j <= i__4; ++j) { xr = xr - b[j + i__ * b_dim1] * vr[j] + b[i__ + 1 + j * b_dim1] * vi[j]; xi = xi - b[j + i__ * b_dim1] * vi[j] - b[i__ + 1 + j * b_dim1] * vr[j]; /* L230: */ } } w = (d__1 = b[i__ + i__ * b_dim1], abs(d__1)) + (d__2 = b[i__ + 1 + i__ * b_dim1], abs(d__2)); if (w > *smlnum) { if (w < 1.) { w1 = abs(xr) + abs(xi); if (w1 > w * *bignum) { rec = 1. / w1; dscal_(n, &rec, &vr[1], &c__1); dscal_(n, &rec, &vi[1], &c__1); xr = vr[i__]; xi = vi[i__]; scale *= rec; vmax *= rec; } } /* Divide by diagonal element of B. */ dladiv_(&xr, &xi, &b[i__ + i__ * b_dim1], &b[i__ + 1 + i__ * b_dim1], &vr[i__], &vi[i__]); /* Computing MAX */ d__3 = (d__1 = vr[i__], abs(d__1)) + (d__2 = vi[i__], abs( d__2)); vmax = max(d__3,vmax); vcrit = *bignum / vmax; } else { i__4 = *n; for (j = 1; j <= i__4; ++j) { vr[j] = 0.; vi[j] = 0.; /* L240: */ } vr[i__] = 1.; vi[i__] = 1.; scale = 0.; vmax = 1.; vcrit = *bignum; } /* L250: */ } /* Test for sufficient growth in the norm of (VR,VI). */ vnorm = dasum_(n, &vr[1], &c__1) + dasum_(n, &vi[1], &c__1); if (vnorm >= growto * scale) { goto L280; } /* Choose a new orthogonal starting vector and try again. */ y = *eps3 / (rootn + 1.); vr[1] = *eps3; vi[1] = 0.; i__3 = *n; for (i__ = 2; i__ <= i__3; ++i__) { vr[i__] = y; vi[i__] = 0.; /* L260: */ } vr[*n - its + 1] -= *eps3 * rootn; /* L270: */ } /* Failure to find eigenvector in N iterations */ *info = 1; L280: /* Normalize eigenvector. */ vnorm = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ d__3 = vnorm; d__4 = (d__1 = vr[i__], abs(d__1)) + (d__2 = vi[i__] , abs(d__2)); // , expr subst vnorm = max(d__3,d__4); /* L290: */ } d__1 = 1. / vnorm; dscal_(n, &d__1, &vr[1], &c__1); d__1 = 1. / vnorm; dscal_(n, &d__1, &vi[1], &c__1); } return 0; /* End of DLAEIN */ }
/* Subroutine */ int dlaln2_(logical *ltrans, integer *na, integer *nw, doublereal *smin, doublereal *ca, doublereal *a, integer *lda, doublereal *d1, doublereal *d2, doublereal *b, integer *ldb, doublereal *wr, doublereal *wi, doublereal *x, integer *ldx, doublereal *scale, doublereal *xnorm, integer *info) { /* Initialized data */ static logical zswap[4] = { FALSE_,FALSE_,TRUE_,TRUE_ }; static logical rswap[4] = { FALSE_,TRUE_,FALSE_,TRUE_ }; static integer ipivot[16] /* was [4][4] */ = { 1,2,3,4,2,1,4,3,3,4,1,2, 4,3,2,1 }; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset; doublereal d__1, d__2, d__3, d__4, d__5, d__6; static doublereal equiv_0[4], equiv_1[4]; /* Local variables */ static integer j; #define ci (equiv_0) #define cr (equiv_1) static doublereal bi1, bi2, br1, br2, xi1, xi2, xr1, xr2, ci21, ci22, cr21, cr22, li21, csi, ui11, lr21, ui12, ui22; #define civ (equiv_0) static doublereal csr, ur11, ur12, ur22; #define crv (equiv_1) static doublereal bbnd, cmax, ui11r, ui12s, temp, ur11r, ur12s, u22abs; static integer icmax; static doublereal bnorm, cnorm, smini; extern doublereal dlamch_(char *, ftnlen); extern /* Subroutine */ int dladiv_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *); static doublereal bignum, smlnum; /* -- LAPACK auxiliary routine (version 3.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* October 31, 1992 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* DLALN2 solves a system of the form (ca A - w D ) X = s B */ /* or (ca A' - w D) X = s B with possible scaling ("s") and */ /* perturbation of A. (A' means A-transpose.) */ /* A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA */ /* real diagonal matrix, w is a real or complex value, and X and B are */ /* NA x 1 matrices -- real if w is real, complex if w is complex. NA */ /* may be 1 or 2. */ /* If w is complex, X and B are represented as NA x 2 matrices, */ /* the first column of each being the real part and the second */ /* being the imaginary part. */ /* "s" is a scaling factor (.LE. 1), computed by DLALN2, which is */ /* so chosen that X can be computed without overflow. X is further */ /* scaled if necessary to assure that norm(ca A - w D)*norm(X) is less */ /* than overflow. */ /* If both singular values of (ca A - w D) are less than SMIN, */ /* SMIN*identity will be used instead of (ca A - w D). If only one */ /* singular value is less than SMIN, one element of (ca A - w D) will be */ /* perturbed enough to make the smallest singular value roughly SMIN. */ /* If both singular values are at least SMIN, (ca A - w D) will not be */ /* perturbed. In any case, the perturbation will be at most some small */ /* multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values */ /* are computed by infinity-norm approximations, and thus will only be */ /* correct to a factor of 2 or so. */ /* Note: all input quantities are assumed to be smaller than overflow */ /* by a reasonable factor. (See BIGNUM.) */ /* Arguments */ /* ========== */ /* LTRANS (input) LOGICAL */ /* =.TRUE.: A-transpose will be used. */ /* =.FALSE.: A will be used (not transposed.) */ /* NA (input) INTEGER */ /* The size of the matrix A. It may (only) be 1 or 2. */ /* NW (input) INTEGER */ /* 1 if "w" is real, 2 if "w" is complex. It may only be 1 */ /* or 2. */ /* SMIN (input) DOUBLE PRECISION */ /* The desired lower bound on the singular values of A. This */ /* should be a safe distance away from underflow or overflow, */ /* say, between (underflow/machine precision) and (machine */ /* precision * overflow ). (See BIGNUM and ULP.) */ /* CA (input) DOUBLE PRECISION */ /* The coefficient c, which A is multiplied by. */ /* A (input) DOUBLE PRECISION array, dimension (LDA,NA) */ /* The NA x NA matrix A. */ /* LDA (input) INTEGER */ /* The leading dimension of A. It must be at least NA. */ /* D1 (input) DOUBLE PRECISION */ /* The 1,1 element in the diagonal matrix D. */ /* D2 (input) DOUBLE PRECISION */ /* The 2,2 element in the diagonal matrix D. Not used if NW=1. */ /* B (input) DOUBLE PRECISION array, dimension (LDB,NW) */ /* The NA x NW matrix B (right-hand side). If NW=2 ("w" is */ /* complex), column 1 contains the real part of B and column 2 */ /* contains the imaginary part. */ /* LDB (input) INTEGER */ /* The leading dimension of B. It must be at least NA. */ /* WR (input) DOUBLE PRECISION */ /* The real part of the scalar "w". */ /* WI (input) DOUBLE PRECISION */ /* The imaginary part of the scalar "w". Not used if NW=1. */ /* X (output) DOUBLE PRECISION array, dimension (LDX,NW) */ /* The NA x NW matrix X (unknowns), as computed by DLALN2. */ /* If NW=2 ("w" is complex), on exit, column 1 will contain */ /* the real part of X and column 2 will contain the imaginary */ /* part. */ /* LDX (input) INTEGER */ /* The leading dimension of X. It must be at least NA. */ /* SCALE (output) DOUBLE PRECISION */ /* The scale factor that B must be multiplied by to insure */ /* that overflow does not occur when computing X. Thus, */ /* (ca A - w D) X will be SCALE*B, not B (ignoring */ /* perturbations of A.) It will be at most 1. */ /* XNORM (output) DOUBLE PRECISION */ /* The infinity-norm of X, when X is regarded as an NA x NW */ /* real matrix. */ /* INFO (output) INTEGER */ /* An error flag. It will be set to zero if no error occurs, */ /* a negative number if an argument is in error, or a positive */ /* number if ca A - w D had to be perturbed. */ /* The possible values are: */ /* = 0: No error occurred, and (ca A - w D) did not have to be */ /* perturbed. */ /* = 1: (ca A - w D) had to be perturbed to make its smallest */ /* (or only) singular value greater than SMIN. */ /* 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 .. */ /* .. */ /* .. Equivalences .. */ /* .. */ /* .. Data statements .. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; x_dim1 = *ldx; x_offset = 1 + x_dim1; x -= x_offset; /* Function Body */ /* .. */ /* .. Executable Statements .. */ /* Compute BIGNUM */ smlnum = 2. * dlamch_("Safe minimum", (ftnlen)12); bignum = 1. / smlnum; smini = max(*smin,smlnum); /* Don't check for input errors */ *info = 0; /* Standard Initializations */ *scale = 1.; if (*na == 1) { /* 1 x 1 (i.e., scalar) system C X = B */ if (*nw == 1) { /* Real 1x1 system. */ /* C = ca A - w D */ csr = *ca * a[a_dim1 + 1] - *wr * *d1; cnorm = abs(csr); /* If | C | < SMINI, use C = SMINI */ if (cnorm < smini) { csr = smini; cnorm = smini; *info = 1; } /* Check scaling for X = B / C */ bnorm = (d__1 = b[b_dim1 + 1], abs(d__1)); if (cnorm < 1. && bnorm > 1.) { if (bnorm > bignum * cnorm) { *scale = 1. / bnorm; } } /* Compute X */ x[x_dim1 + 1] = b[b_dim1 + 1] * *scale / csr; *xnorm = (d__1 = x[x_dim1 + 1], abs(d__1)); } else { /* Complex 1x1 system (w is complex) */ /* C = ca A - w D */ csr = *ca * a[a_dim1 + 1] - *wr * *d1; csi = -(*wi) * *d1; cnorm = abs(csr) + abs(csi); /* If | C | < SMINI, use C = SMINI */ if (cnorm < smini) { csr = smini; csi = 0.; cnorm = smini; *info = 1; } /* Check scaling for X = B / C */ bnorm = (d__1 = b[b_dim1 + 1], abs(d__1)) + (d__2 = b[(b_dim1 << 1) + 1], abs(d__2)); if (cnorm < 1. && bnorm > 1.) { if (bnorm > bignum * cnorm) { *scale = 1. / bnorm; } } /* Compute X */ d__1 = *scale * b[b_dim1 + 1]; d__2 = *scale * b[(b_dim1 << 1) + 1]; dladiv_(&d__1, &d__2, &csr, &csi, &x[x_dim1 + 1], &x[(x_dim1 << 1) + 1]); *xnorm = (d__1 = x[x_dim1 + 1], abs(d__1)) + (d__2 = x[(x_dim1 << 1) + 1], abs(d__2)); } } else { /* 2x2 System */ /* Compute the real part of C = ca A - w D (or ca A' - w D ) */ cr[0] = *ca * a[a_dim1 + 1] - *wr * *d1; cr[3] = *ca * a[(a_dim1 << 1) + 2] - *wr * *d2; if (*ltrans) { cr[2] = *ca * a[a_dim1 + 2]; cr[1] = *ca * a[(a_dim1 << 1) + 1]; } else { cr[1] = *ca * a[a_dim1 + 2]; cr[2] = *ca * a[(a_dim1 << 1) + 1]; } if (*nw == 1) { /* Real 2x2 system (w is real) */ /* Find the largest element in C */ cmax = 0.; icmax = 0; for (j = 1; j <= 4; ++j) { if ((d__1 = crv[j - 1], abs(d__1)) > cmax) { cmax = (d__1 = crv[j - 1], abs(d__1)); icmax = j; } /* L10: */ } /* If norm(C) < SMINI, use SMINI*identity. */ if (cmax < smini) { /* Computing MAX */ d__3 = (d__1 = b[b_dim1 + 1], abs(d__1)), d__4 = (d__2 = b[ b_dim1 + 2], abs(d__2)); bnorm = max(d__3,d__4); if (smini < 1. && bnorm > 1.) { if (bnorm > bignum * smini) { *scale = 1. / bnorm; } } temp = *scale / smini; x[x_dim1 + 1] = temp * b[b_dim1 + 1]; x[x_dim1 + 2] = temp * b[b_dim1 + 2]; *xnorm = temp * bnorm; *info = 1; return 0; } /* Gaussian elimination with complete pivoting. */ ur11 = crv[icmax - 1]; cr21 = crv[ipivot[(icmax << 2) - 3] - 1]; ur12 = crv[ipivot[(icmax << 2) - 2] - 1]; cr22 = crv[ipivot[(icmax << 2) - 1] - 1]; ur11r = 1. / ur11; lr21 = ur11r * cr21; ur22 = cr22 - ur12 * lr21; /* If smaller pivot < SMINI, use SMINI */ if (abs(ur22) < smini) { ur22 = smini; *info = 1; } if (rswap[icmax - 1]) { br1 = b[b_dim1 + 2]; br2 = b[b_dim1 + 1]; } else { br1 = b[b_dim1 + 1]; br2 = b[b_dim1 + 2]; } br2 -= lr21 * br1; /* Computing MAX */ d__2 = (d__1 = br1 * (ur22 * ur11r), abs(d__1)), d__3 = abs(br2); bbnd = max(d__2,d__3); if (bbnd > 1. && abs(ur22) < 1.) { if (bbnd >= bignum * abs(ur22)) { *scale = 1. / bbnd; } } xr2 = br2 * *scale / ur22; xr1 = *scale * br1 * ur11r - xr2 * (ur11r * ur12); if (zswap[icmax - 1]) { x[x_dim1 + 1] = xr2; x[x_dim1 + 2] = xr1; } else { x[x_dim1 + 1] = xr1; x[x_dim1 + 2] = xr2; } /* Computing MAX */ d__1 = abs(xr1), d__2 = abs(xr2); *xnorm = max(d__1,d__2); /* Further scaling if norm(A) norm(X) > overflow */ if (*xnorm > 1. && cmax > 1.) { if (*xnorm > bignum / cmax) { temp = cmax / bignum; x[x_dim1 + 1] = temp * x[x_dim1 + 1]; x[x_dim1 + 2] = temp * x[x_dim1 + 2]; *xnorm = temp * *xnorm; *scale = temp * *scale; } } } else { /* Complex 2x2 system (w is complex) */ /* Find the largest element in C */ ci[0] = -(*wi) * *d1; ci[1] = 0.; ci[2] = 0.; ci[3] = -(*wi) * *d2; cmax = 0.; icmax = 0; for (j = 1; j <= 4; ++j) { if ((d__1 = crv[j - 1], abs(d__1)) + (d__2 = civ[j - 1], abs( d__2)) > cmax) { cmax = (d__1 = crv[j - 1], abs(d__1)) + (d__2 = civ[j - 1] , abs(d__2)); icmax = j; } /* L20: */ } /* If norm(C) < SMINI, use SMINI*identity. */ if (cmax < smini) { /* Computing MAX */ d__5 = (d__1 = b[b_dim1 + 1], abs(d__1)) + (d__2 = b[(b_dim1 << 1) + 1], abs(d__2)), d__6 = (d__3 = b[b_dim1 + 2], abs(d__3)) + (d__4 = b[(b_dim1 << 1) + 2], abs(d__4)); bnorm = max(d__5,d__6); if (smini < 1. && bnorm > 1.) { if (bnorm > bignum * smini) { *scale = 1. / bnorm; } } temp = *scale / smini; x[x_dim1 + 1] = temp * b[b_dim1 + 1]; x[x_dim1 + 2] = temp * b[b_dim1 + 2]; x[(x_dim1 << 1) + 1] = temp * b[(b_dim1 << 1) + 1]; x[(x_dim1 << 1) + 2] = temp * b[(b_dim1 << 1) + 2]; *xnorm = temp * bnorm; *info = 1; return 0; } /* Gaussian elimination with complete pivoting. */ ur11 = crv[icmax - 1]; ui11 = civ[icmax - 1]; cr21 = crv[ipivot[(icmax << 2) - 3] - 1]; ci21 = civ[ipivot[(icmax << 2) - 3] - 1]; ur12 = crv[ipivot[(icmax << 2) - 2] - 1]; ui12 = civ[ipivot[(icmax << 2) - 2] - 1]; cr22 = crv[ipivot[(icmax << 2) - 1] - 1]; ci22 = civ[ipivot[(icmax << 2) - 1] - 1]; if (icmax == 1 || icmax == 4) { /* Code when off-diagonals of pivoted C are real */ if (abs(ur11) > abs(ui11)) { temp = ui11 / ur11; /* Computing 2nd power */ d__1 = temp; ur11r = 1. / (ur11 * (d__1 * d__1 + 1.)); ui11r = -temp * ur11r; } else { temp = ur11 / ui11; /* Computing 2nd power */ d__1 = temp; ui11r = -1. / (ui11 * (d__1 * d__1 + 1.)); ur11r = -temp * ui11r; } lr21 = cr21 * ur11r; li21 = cr21 * ui11r; ur12s = ur12 * ur11r; ui12s = ur12 * ui11r; ur22 = cr22 - ur12 * lr21; ui22 = ci22 - ur12 * li21; } else { /* Code when diagonals of pivoted C are real */ ur11r = 1. / ur11; ui11r = 0.; lr21 = cr21 * ur11r; li21 = ci21 * ur11r; ur12s = ur12 * ur11r; ui12s = ui12 * ur11r; ur22 = cr22 - ur12 * lr21 + ui12 * li21; ui22 = -ur12 * li21 - ui12 * lr21; } u22abs = abs(ur22) + abs(ui22); /* If smaller pivot < SMINI, use SMINI */ if (u22abs < smini) { ur22 = smini; ui22 = 0.; *info = 1; } if (rswap[icmax - 1]) { br2 = b[b_dim1 + 1]; br1 = b[b_dim1 + 2]; bi2 = b[(b_dim1 << 1) + 1]; bi1 = b[(b_dim1 << 1) + 2]; } else { br1 = b[b_dim1 + 1]; br2 = b[b_dim1 + 2]; bi1 = b[(b_dim1 << 1) + 1]; bi2 = b[(b_dim1 << 1) + 2]; } br2 = br2 - lr21 * br1 + li21 * bi1; bi2 = bi2 - li21 * br1 - lr21 * bi1; /* Computing MAX */ d__1 = (abs(br1) + abs(bi1)) * (u22abs * (abs(ur11r) + abs(ui11r)) ), d__2 = abs(br2) + abs(bi2); bbnd = max(d__1,d__2); if (bbnd > 1. && u22abs < 1.) { if (bbnd >= bignum * u22abs) { *scale = 1. / bbnd; br1 = *scale * br1; bi1 = *scale * bi1; br2 = *scale * br2; bi2 = *scale * bi2; } } dladiv_(&br2, &bi2, &ur22, &ui22, &xr2, &xi2); xr1 = ur11r * br1 - ui11r * bi1 - ur12s * xr2 + ui12s * xi2; xi1 = ui11r * br1 + ur11r * bi1 - ui12s * xr2 - ur12s * xi2; if (zswap[icmax - 1]) { x[x_dim1 + 1] = xr2; x[x_dim1 + 2] = xr1; x[(x_dim1 << 1) + 1] = xi2; x[(x_dim1 << 1) + 2] = xi1; } else { x[x_dim1 + 1] = xr1; x[x_dim1 + 2] = xr2; x[(x_dim1 << 1) + 1] = xi1; x[(x_dim1 << 1) + 2] = xi2; } /* Computing MAX */ d__1 = abs(xr1) + abs(xi1), d__2 = abs(xr2) + abs(xi2); *xnorm = max(d__1,d__2); /* Further scaling if norm(A) norm(X) > overflow */ if (*xnorm > 1. && cmax > 1.) { if (*xnorm > bignum / cmax) { temp = cmax / bignum; x[x_dim1 + 1] = temp * x[x_dim1 + 1]; x[x_dim1 + 2] = temp * x[x_dim1 + 2]; x[(x_dim1 << 1) + 1] = temp * x[(x_dim1 << 1) + 1]; x[(x_dim1 << 1) + 2] = temp * x[(x_dim1 << 1) + 2]; *xnorm = temp * *xnorm; *scale = temp * *scale; } } } } return 0; /* End of DLALN2 */ } /* dlaln2_ */
/*< DOUBLE COMPLEX FUNCTION ZLADIV( X, Y ) >*/ /* Double Complex */ VOID zladiv_(doublecomplex * ret_val, doublecomplex *x, doublecomplex *y) { /* System generated locals */ doublereal d__1, d__2, d__3, d__4; doublecomplex z__1; /* Builtin functions */ double d_imag(doublecomplex *); /* Local variables */ doublereal zi, zr; extern /* Subroutine */ int dladiv_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *); /* -- LAPACK auxiliary routine (version 3.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* October 31, 1992 */ /* .. Scalar Arguments .. */ /*< COMPLEX*16 X, Y >*/ /* .. */ /* Purpose */ /* ======= */ /* ZLADIV := X / Y, where X and Y are complex. The computation of X / Y */ /* will not overflow on an intermediary step unless the results */ /* overflows. */ /* Arguments */ /* ========= */ /* X (input) COMPLEX*16 */ /* Y (input) COMPLEX*16 */ /* The complex scalars X and Y. */ /* ===================================================================== */ /* .. Local Scalars .. */ /*< DOUBLE PRECISION ZI, ZR >*/ /* .. */ /* .. External Subroutines .. */ /*< EXTERNAL DLADIV >*/ /* .. */ /* .. Intrinsic Functions .. */ /*< INTRINSIC DBLE, DCMPLX, DIMAG >*/ /* .. */ /* .. Executable Statements .. */ /*< >*/ d__1 = x->r; d__2 = d_imag(x); d__3 = y->r; d__4 = d_imag(y); dladiv_(&d__1, &d__2, &d__3, &d__4, &zr, &zi); /*< ZLADIV = DCMPLX( ZR, ZI ) >*/ z__1.r = zr, z__1.i = zi; ret_val->r = z__1.r, ret_val->i = z__1.i; /*< RETURN >*/ return ; /* End of ZLADIV */ /*< END >*/ } /* zladiv_ */
/* Subroutine */ int dlaqtr_(logical *ltran, logical *lreal, integer *n, doublereal *t, integer *ldt, doublereal *b, doublereal *w, doublereal *scale, doublereal *x, doublereal *work, integer *info) { /* -- LAPACK auxiliary routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Purpose ======= DLAQTR 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 DTRSNA. 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) DOUBLE PRECISION array, dimension (LDT,N) On entry, T contains a matrix in Schur canonical form. If LREAL = .FALSE., then the first diagonal block of T mu be 1 by 1. LDT (input) INTEGER The leading dimension of the matrix T. LDT >= max(1,N). B (input) DOUBLE PRECISION 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) DOUBLE PRECISION On entry, W is the diagonal element of the matrix B. If LREAL = .TRUE., W is not referenced. SCALE (output) DOUBLE PRECISION On exit, SCALE is the scale factor. X (input/output) DOUBLE PRECISION 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) DOUBLE PRECISION 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 DLALN2 to keep nonsingularity. NOTE: In the interests of speed, this routine does not check the inputs for errors. ===================================================================== Do not test the input parameters for errors Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; static logical c_false = FALSE_; static integer c__2 = 2; static doublereal c_b21 = 1.; static doublereal c_b25 = 0.; static logical c_true = TRUE_; /* System generated locals */ integer t_dim1, t_offset, i__1, i__2; doublereal d__1, d__2, d__3, d__4, d__5, d__6; /* Local variables */ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *); static integer ierr; static doublereal smin, xmax, d__[4] /* was [2][2] */; static integer i__, j, k; static doublereal v[4] /* was [2][2] */, z__; extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, integer *); extern doublereal dasum_(integer *, doublereal *, integer *); extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *); static integer jnext, j1, j2; static doublereal sminw; static integer n1, n2; static doublereal xnorm; extern /* Subroutine */ int dlaln2_(logical *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal * , doublereal *, integer *, doublereal *, doublereal *, integer *); extern doublereal dlamch_(char *), dlange_(char *, integer *, integer *, doublereal *, integer *, doublereal *); static doublereal si, xj; extern integer idamax_(integer *, doublereal *, integer *); static doublereal scaloc, sr; extern /* Subroutine */ int dladiv_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *); static doublereal bignum; static logical notran; static doublereal smlnum, rec, eps, tjj, tmp; #define d___ref(a_1,a_2) d__[(a_2)*2 + a_1 - 3] #define t_ref(a_1,a_2) t[(a_2)*t_dim1 + a_1] #define v_ref(a_1,a_2) v[(a_2)*2 + a_1 - 3] t_dim1 = *ldt; t_offset = 1 + t_dim1 * 1; 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 = dlamch_("P"); smlnum = dlamch_("S") / eps; bignum = 1. / smlnum; xnorm = dlange_("M", n, n, &t[t_offset], ldt, d__); if (! (*lreal)) { /* Computing MAX */ d__1 = xnorm, d__2 = abs(*w), d__1 = max(d__1,d__2), d__2 = dlange_( "M", n, &c__1, &b[1], n, d__); xnorm = max(d__1,d__2); } /* Computing MAX */ d__1 = smlnum, d__2 = eps * xnorm; smin = max(d__1,d__2); /* Compute 1-norm of each column of strictly upper triangular part of T to control overflow in triangular solver. */ work[1] = 0.; i__1 = *n; for (j = 2; j <= i__1; ++j) { i__2 = j - 1; work[j] = dasum_(&i__2, &t_ref(1, j), &c__1); /* L10: */ } if (! (*lreal)) { i__1 = *n; for (i__ = 2; i__ <= i__1; ++i__) { work[i__] += (d__1 = b[i__], abs(d__1)); /* L20: */ } } n2 = *n << 1; n1 = *n; if (! (*lreal)) { n1 = n2; } k = idamax_(&n1, &x[1], &c__1); xmax = (d__1 = x[k], abs(d__1)); *scale = 1.; if (xmax > bignum) { *scale = bignum / xmax; dscal_(&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_ref(j, j - 1) != 0.) { 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 = (d__1 = x[j1], abs(d__1)); tjj = (d__1 = t_ref(j1, j1), abs(d__1)); tmp = t_ref(j1, j1); if (tjj < smin) { tmp = smin; tjj = smin; *info = 1; } if (xj == 0.) { goto L30; } if (tjj < 1.) { if (xj > bignum * tjj) { rec = 1. / xj; dscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } x[j1] /= tmp; xj = (d__1 = x[j1], abs(d__1)); /* Scale x if necessary to avoid overflow when adding a multiple of column j1 of T. */ if (xj > 1.) { rec = 1. / xj; if (work[j1] > (bignum - xmax) * rec) { dscal_(n, &rec, &x[1], &c__1); *scale *= rec; } } if (j1 > 1) { i__1 = j1 - 1; d__1 = -x[j1]; daxpy_(&i__1, &d__1, &t_ref(1, j1), &c__1, &x[1], & c__1); i__1 = j1 - 1; k = idamax_(&i__1, &x[1], &c__1); xmax = (d__1 = x[k], abs(d__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___ref(1, 1) = x[j1]; d___ref(2, 1) = x[j2]; dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b21, &t_ref(j1, j1), 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.) { dscal_(n, &scaloc, &x[1], &c__1); *scale *= scaloc; } x[j1] = v_ref(1, 1); x[j2] = v_ref(2, 1); /* Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2)) to avoid overflow in updating right-hand side. Computing MAX */ d__3 = (d__1 = v_ref(1, 1), abs(d__1)), d__4 = (d__2 = v_ref(2, 1), abs(d__2)); xj = max(d__3,d__4); if (xj > 1.) { rec = 1. / xj; /* Computing MAX */ d__1 = work[j1], d__2 = work[j2]; if (max(d__1,d__2) > (bignum - xmax) * rec) { dscal_(n, &rec, &x[1], &c__1); *scale *= rec; } } /* Update right-hand side */ if (j1 > 1) { i__1 = j1 - 1; d__1 = -x[j1]; daxpy_(&i__1, &d__1, &t_ref(1, j1), &c__1, &x[1], & c__1); i__1 = j1 - 1; d__1 = -x[j2]; daxpy_(&i__1, &d__1, &t_ref(1, j2), &c__1, &x[1], & c__1); i__1 = j1 - 1; k = idamax_(&i__1, &x[1], &c__1); xmax = (d__1 = x[k], abs(d__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_ref(j + 1, j) != 0.) { 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 = (d__1 = x[j1], abs(d__1)); if (xmax > 1.) { rec = 1. / xmax; if (work[j1] > (bignum - xj) * rec) { dscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__2 = j1 - 1; x[j1] -= ddot_(&i__2, &t_ref(1, j1), &c__1, &x[1], &c__1); xj = (d__1 = x[j1], abs(d__1)); tjj = (d__1 = t_ref(j1, j1), abs(d__1)); tmp = t_ref(j1, j1); if (tjj < smin) { tmp = smin; tjj = smin; *info = 1; } if (tjj < 1.) { if (xj > bignum * tjj) { rec = 1. / xj; dscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } x[j1] /= tmp; /* Computing MAX */ d__2 = xmax, d__3 = (d__1 = x[j1], abs(d__1)); xmax = max(d__2,d__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 */ d__3 = (d__1 = x[j1], abs(d__1)), d__4 = (d__2 = x[j2], abs(d__2)); xj = max(d__3,d__4); if (xmax > 1.) { rec = 1. / xmax; /* Computing MAX */ d__1 = work[j2], d__2 = work[j1]; if (max(d__1,d__2) > (bignum - xj) * rec) { dscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__2 = j1 - 1; d___ref(1, 1) = x[j1] - ddot_(&i__2, &t_ref(1, j1), &c__1, &x[1], &c__1); i__2 = j1 - 1; d___ref(2, 1) = x[j2] - ddot_(&i__2, &t_ref(1, j2), &c__1, &x[1], &c__1); dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b21, &t_ref(j1, j1), 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.) { dscal_(n, &scaloc, &x[1], &c__1); *scale *= scaloc; } x[j1] = v_ref(1, 1); x[j2] = v_ref(2, 1); /* Computing MAX */ d__3 = (d__1 = x[j1], abs(d__1)), d__4 = (d__2 = x[j2], abs(d__2)), d__3 = max(d__3,d__4); xmax = max(d__3,xmax); } L40: ; } } } else { /* Computing MAX */ d__1 = eps * abs(*w); sminw = max(d__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_ref(j, j - 1) != 0.) { 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 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], abs( d__2)); tjj = (d__1 = t_ref(j1, j1), abs(d__1)) + abs(z__); tmp = t_ref(j1, j1); if (tjj < sminw) { tmp = sminw; tjj = sminw; *info = 1; } if (xj == 0.) { goto L70; } if (tjj < 1.) { if (xj > bignum * tjj) { rec = 1. / xj; dscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } dladiv_(&x[j1], &x[*n + j1], &tmp, &z__, &sr, &si); x[j1] = sr; x[*n + j1] = si; xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], abs( d__2)); /* Scale x if necessary to avoid overflow when adding a multiple of column j1 of T. */ if (xj > 1.) { rec = 1. / xj; if (work[j1] > (bignum - xmax) * rec) { dscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; } } if (j1 > 1) { i__1 = j1 - 1; d__1 = -x[j1]; daxpy_(&i__1, &d__1, &t_ref(1, j1), &c__1, &x[1], & c__1); i__1 = j1 - 1; d__1 = -x[*n + j1]; daxpy_(&i__1, &d__1, &t_ref(1, j1), &c__1, &x[*n + 1], &c__1); x[1] += b[j1] * x[*n + j1]; x[*n + 1] -= b[j1] * x[j1]; xmax = 0.; i__1 = j1 - 1; for (k = 1; k <= i__1; ++k) { /* Computing MAX */ d__3 = xmax, d__4 = (d__1 = x[k], abs(d__1)) + ( d__2 = x[k + *n], abs(d__2)); xmax = max(d__3,d__4); /* L50: */ } } } else { /* Meet 2 by 2 diagonal block */ d___ref(1, 1) = x[j1]; d___ref(2, 1) = x[j2]; d___ref(1, 2) = x[*n + j1]; d___ref(2, 2) = x[*n + j2]; d__1 = -(*w); dlaln2_(&c_false, &c__2, &c__2, &sminw, &c_b21, &t_ref(j1, j1), ldt, &c_b21, &c_b21, d__, &c__2, &c_b25, & d__1, v, &c__2, &scaloc, &xnorm, &ierr); if (ierr != 0) { *info = 2; } if (scaloc != 1.) { i__1 = *n << 1; dscal_(&i__1, &scaloc, &x[1], &c__1); *scale = scaloc * *scale; } x[j1] = v_ref(1, 1); x[j2] = v_ref(2, 1); x[*n + j1] = v_ref(1, 2); x[*n + j2] = v_ref(2, 2); /* Scale X(J1), .... to avoid overflow in updating right hand side. Computing MAX */ d__5 = (d__1 = v_ref(1, 1), abs(d__1)) + (d__2 = v_ref(1, 2), abs(d__2)), d__6 = (d__3 = v_ref(2, 1), abs( d__3)) + (d__4 = v_ref(2, 2), abs(d__4)); xj = max(d__5,d__6); if (xj > 1.) { rec = 1. / xj; /* Computing MAX */ d__1 = work[j1], d__2 = work[j2]; if (max(d__1,d__2) > (bignum - xmax) * rec) { dscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; } } /* Update the right-hand side. */ if (j1 > 1) { i__1 = j1 - 1; d__1 = -x[j1]; daxpy_(&i__1, &d__1, &t_ref(1, j1), &c__1, &x[1], & c__1); i__1 = j1 - 1; d__1 = -x[j2]; daxpy_(&i__1, &d__1, &t_ref(1, j2), &c__1, &x[1], & c__1); i__1 = j1 - 1; d__1 = -x[*n + j1]; daxpy_(&i__1, &d__1, &t_ref(1, j1), &c__1, &x[*n + 1], &c__1); i__1 = j1 - 1; d__1 = -x[*n + j2]; daxpy_(&i__1, &d__1, &t_ref(1, j2), &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.; i__1 = j1 - 1; for (k = 1; k <= i__1; ++k) { /* Computing MAX */ d__3 = (d__1 = x[k], abs(d__1)) + (d__2 = x[k + * n], abs(d__2)); xmax = max(d__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_ref(j + 1, j) != 0.) { 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 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n], abs( d__2)); if (xmax > 1.) { rec = 1. / xmax; if (work[j1] > (bignum - xj) * rec) { dscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__2 = j1 - 1; x[j1] -= ddot_(&i__2, &t_ref(1, j1), &c__1, &x[1], &c__1); i__2 = j1 - 1; x[*n + j1] -= ddot_(&i__2, &t_ref(1, j1), &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 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n], abs( d__2)); z__ = *w; if (j1 == 1) { z__ = b[1]; } /* Scale if necessary to avoid overflow in complex division */ tjj = (d__1 = t_ref(j1, j1), abs(d__1)) + abs(z__); tmp = t_ref(j1, j1); if (tjj < sminw) { tmp = sminw; tjj = sminw; *info = 1; } if (tjj < 1.) { if (xj > bignum * tjj) { rec = 1. / xj; dscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } d__1 = -z__; dladiv_(&x[j1], &x[*n + j1], &tmp, &d__1, &sr, &si); x[j1] = sr; x[j1 + *n] = si; /* Computing MAX */ d__3 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n], abs(d__2)); xmax = max(d__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 */ d__5 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], abs(d__2)), d__6 = (d__3 = x[j2], abs(d__3)) + ( d__4 = x[*n + j2], abs(d__4)); xj = max(d__5,d__6); if (xmax > 1.) { rec = 1. / xmax; /* Computing MAX */ d__1 = work[j1], d__2 = work[j2]; if (max(d__1,d__2) > (bignum - xj) / xmax) { dscal_(&n2, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__2 = j1 - 1; d___ref(1, 1) = x[j1] - ddot_(&i__2, &t_ref(1, j1), &c__1, &x[1], &c__1); i__2 = j1 - 1; d___ref(2, 1) = x[j2] - ddot_(&i__2, &t_ref(1, j2), &c__1, &x[1], &c__1); i__2 = j1 - 1; d___ref(1, 2) = x[*n + j1] - ddot_(&i__2, &t_ref(1, j1), & c__1, &x[*n + 1], &c__1); i__2 = j1 - 1; d___ref(2, 2) = x[*n + j2] - ddot_(&i__2, &t_ref(1, j2), & c__1, &x[*n + 1], &c__1); d___ref(1, 1) = d___ref(1, 1) - b[j1] * x[*n + 1]; d___ref(2, 1) = d___ref(2, 1) - b[j2] * x[*n + 1]; d___ref(1, 2) = d___ref(1, 2) + b[j1] * x[1]; d___ref(2, 2) = d___ref(2, 2) + b[j2] * x[1]; dlaln2_(&c_true, &c__2, &c__2, &sminw, &c_b21, &t_ref(j1, j1), 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.) { dscal_(&n2, &scaloc, &x[1], &c__1); *scale = scaloc * *scale; } x[j1] = v_ref(1, 1); x[j2] = v_ref(2, 1); x[*n + j1] = v_ref(1, 2); x[*n + j2] = v_ref(2, 2); /* Computing MAX */ d__5 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], abs(d__2)), d__6 = (d__3 = x[j2], abs(d__3)) + ( d__4 = x[*n + j2], abs(d__4)), d__5 = max(d__5, d__6); xmax = max(d__5,xmax); } L80: ; } } } return 0; /* End of DLAQTR */ } /* dlaqtr_ */