doublereal slantb_(char *norm, char *uplo, char *diag, integer *n, integer *k,
real *ab, integer *ldab, real *work)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5;
real ret_val, r__1, r__2, r__3;
/* Local variables */
integer i__, j, l;
real sum, scale;
logical udiag;
real value;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SLANTB returns the value of the one norm, or the Frobenius norm, or */
/* the infinity norm, or the element of largest absolute value of an */
/* n by n triangular band matrix A, with ( k + 1 ) diagonals. */
/* Description */
/* =========== */
/* SLANTB returns the value */
/* SLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
/* ( */
/* ( norm1(A), NORM = '1', 'O' or 'o' */
/* ( */
/* ( normI(A), NORM = 'I' or 'i' */
/* ( */
/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
/* where norm1 denotes the one norm of a matrix (maximum column sum), */
/* normI denotes the infinity norm of a matrix (maximum row sum) and */
/* normF denotes the Frobenius norm of a matrix (square root of sum of */
/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies the value to be returned in SLANTB as described */
/* above. */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. When N = 0, SLANTB is */
/* set to zero. */
/* K (input) INTEGER */
/* The number of super-diagonals of the matrix A if UPLO = 'U', */
/* or the number of sub-diagonals of the matrix A if UPLO = 'L'. */
/* K >= 0. */
/* AB (input) REAL array, dimension (LDAB,N) */
/* The upper or lower triangular band matrix A, stored in the */
/* first k+1 rows of AB. The j-th column of A is stored */
/* in the j-th column of the array AB as follows: */
/* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). */
/* Note that when DIAG = 'U', the elements of the array AB */
/* corresponding to the diagonal elements of the matrix A are */
/* not referenced, but are assumed to be one. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= K+1. */
/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */
/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
/* referenced. */
/* ===================================================================== */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--work;
/* Function Body */
if (*n == 0) {
value = 0.f;
} else if (lsame_(norm, "M")) {
/* Find max(abs(A(i,j))). */
if (lsame_(diag, "U")) {
value = 1.f;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = *k + 2 - j;
i__3 = *k;
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
/* Computing MAX */
r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1],
dabs(r__1));
value = dmax(r__2,r__3);
}
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__2 = *n + 1 - j, i__4 = *k + 1;
i__3 = min(i__2,i__4);
for (i__ = 2; i__ <= i__3; ++i__) {
/* Computing MAX */
r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1],
dabs(r__1));
value = dmax(r__2,r__3);
}
}
}
} else {
value = 0.f;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__3 = *k + 2 - j;
i__2 = *k + 1;
for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1],
dabs(r__1));
value = dmax(r__2,r__3);
}
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n + 1 - j, i__4 = *k + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1],
dabs(r__1));
value = dmax(r__2,r__3);
}
}
}
}
} else if (lsame_(norm, "O") || *(unsigned char *)
norm == '1') {
/* Find norm1(A). */
value = 0.f;
udiag = lsame_(diag, "U");
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag) {
sum = 1.f;
/* Computing MAX */
i__2 = *k + 2 - j;
i__3 = *k;
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
sum += (r__1 = ab[i__ + j * ab_dim1], dabs(r__1));
}
} else {
sum = 0.f;
/* Computing MAX */
i__3 = *k + 2 - j;
i__2 = *k + 1;
for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
sum += (r__1 = ab[i__ + j * ab_dim1], dabs(r__1));
}
}
value = dmax(value,sum);
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (udiag) {
sum = 1.f;
/* Computing MIN */
i__3 = *n + 1 - j, i__4 = *k + 1;
i__2 = min(i__3,i__4);
for (i__ = 2; i__ <= i__2; ++i__) {
sum += (r__1 = ab[i__ + j * ab_dim1], dabs(r__1));
}
} else {
sum = 0.f;
/* Computing MIN */
i__3 = *n + 1 - j, i__4 = *k + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
sum += (r__1 = ab[i__ + j * ab_dim1], dabs(r__1));
}
}
value = dmax(value,sum);
}
}
} else if (lsame_(norm, "I")) {
/* Find normI(A). */
value = 0.f;
if (lsame_(uplo, "U")) {
if (lsame_(diag, "U")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 1.f;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
l = *k + 1 - j;
/* Computing MAX */
i__2 = 1, i__3 = j - *k;
i__4 = j - 1;
for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
work[i__] += (r__1 = ab[l + i__ + j * ab_dim1], dabs(
r__1));
}
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
l = *k + 1 - j;
/* Computing MAX */
i__4 = 1, i__2 = j - *k;
i__3 = j;
for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
work[i__] += (r__1 = ab[l + i__ + j * ab_dim1], dabs(
r__1));
}
}
}
} else {
if (lsame_(diag, "U")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 1.f;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
l = 1 - j;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2);
for (i__ = j + 1; i__ <= i__3; ++i__) {
work[i__] += (r__1 = ab[l + i__ + j * ab_dim1], dabs(
r__1));
}
}
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
l = 1 - j;
/* Computing MIN */
i__4 = *n, i__2 = j + *k;
i__3 = min(i__4,i__2);
for (i__ = j; i__ <= i__3; ++i__) {
work[i__] += (r__1 = ab[l + i__ + j * ab_dim1], dabs(
r__1));
}
}
}
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__1 = value, r__2 = work[i__];
value = dmax(r__1,r__2);
}
} else if (lsame_(norm, "F") || lsame_(norm, "E")) {
/* Find normF(A). */
if (lsame_(uplo, "U")) {
if (lsame_(diag, "U")) {
scale = 1.f;
sum = (real) (*n);
if (*k > 0) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
/* Computing MIN */
i__4 = j - 1;
i__3 = min(i__4,*k);
/* Computing MAX */
i__2 = *k + 2 - j;
slassq_(&i__3, &ab[max(i__2, 1)+ j * ab_dim1], &c__1,
&scale, &sum);
}
}
} else {
scale = 0.f;
sum = 1.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__4 = j, i__2 = *k + 1;
i__3 = min(i__4,i__2);
/* Computing MAX */
i__5 = *k + 2 - j;
slassq_(&i__3, &ab[max(i__5, 1)+ j * ab_dim1], &c__1, &
scale, &sum);
}
}
} else {
if (lsame_(diag, "U")) {
scale = 1.f;
sum = (real) (*n);
if (*k > 0) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__4 = *n - j;
i__3 = min(i__4,*k);
slassq_(&i__3, &ab[j * ab_dim1 + 2], &c__1, &scale, &
sum);
}
}
} else {
scale = 0.f;
sum = 1.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__4 = *n - j + 1, i__2 = *k + 1;
i__3 = min(i__4,i__2);
slassq_(&i__3, &ab[j * ab_dim1 + 1], &c__1, &scale, &sum);
}
}
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of SLANTB */
} /* slantb_ */
/* Subroutine */ int slaebz_(integer *ijob, integer *nitmax, integer *n,
integer *mmax, integer *minp, integer *nbmin, real *abstol, real *
reltol, real *pivmin, real *d__, real *e, real *e2, integer *nval,
real *ab, real *c__, integer *mout, integer *nab, real *work, integer
*iwork, integer *info)
{
/* System generated locals */
integer nab_dim1, nab_offset, ab_dim1, ab_offset, i__1, i__2, i__3, i__4,
i__5, i__6;
real r__1, r__2, r__3, r__4;
/* Local variables */
integer j, kf, ji, kl, jp, jit;
real tmp1, tmp2;
integer itmp1, itmp2, kfnew, klnew;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLAEBZ contains the iteration loops which compute and use the */
/* function N(w), which is the count of eigenvalues of a symmetric */
/* tridiagonal matrix T less than or equal to its argument w. It */
/* performs a choice of two types of loops: */
/* IJOB=1, followed by */
/* IJOB=2: It takes as input a list of intervals and returns a list of */
/* sufficiently small intervals whose union contains the same */
/* eigenvalues as the union of the original intervals. */
/* The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP. */
/* The output interval (AB(j,1),AB(j,2)] will contain */
/* eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT. */
/* IJOB=3: It performs a binary search in each input interval */
/* (AB(j,1),AB(j,2)] for a point w(j) such that */
/* N(w(j))=NVAL(j), and uses C(j) as the starting point of */
/* the search. If such a w(j) is found, then on output */
/* AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output */
/* (AB(j,1),AB(j,2)] will be a small interval containing the */
/* point where N(w) jumps through NVAL(j), unless that point */
/* lies outside the initial interval. */
/* Note that the intervals are in all cases half-open intervals, */
/* i.e., of the form (a,b] , which includes b but not a . */
/* To avoid underflow, the matrix should be scaled so that its largest */
/* element is no greater than overflow**(1/2) * underflow**(1/4) */
/* in absolute value. To assure the most accurate computation */
/* of small eigenvalues, the matrix should be scaled to be */
/* not much smaller than that, either. */
/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */
/* Matrix", Report CS41, Computer Science Dept., Stanford */
/* University, July 21, 1966 */
/* Note: the arguments are, in general, *not* checked for unreasonable */
/* values. */
/* Arguments */
/* ========= */
/* IJOB (input) INTEGER */
/* Specifies what is to be done: */
/* = 1: Compute NAB for the initial intervals. */
/* = 2: Perform bisection iteration to find eigenvalues of T. */
/* = 3: Perform bisection iteration to invert N(w), i.e., */
/* to find a point which has a specified number of */
/* eigenvalues of T to its left. */
/* Other values will cause SLAEBZ to return with INFO=-1. */
/* NITMAX (input) INTEGER */
/* The maximum number of "levels" of bisection to be */
/* performed, i.e., an interval of width W will not be made */
/* smaller than 2^(-NITMAX) * W. If not all intervals */
/* have converged after NITMAX iterations, then INFO is set */
/* to the number of non-converged intervals. */
/* N (input) INTEGER */
/* The dimension n of the tridiagonal matrix T. It must be at */
/* least 1. */
/* MMAX (input) INTEGER */
/* The maximum number of intervals. If more than MMAX intervals */
/* are generated, then SLAEBZ will quit with INFO=MMAX+1. */
/* MINP (input) INTEGER */
/* The initial number of intervals. It may not be greater than */
/* MMAX. */
/* NBMIN (input) INTEGER */
/* The smallest number of intervals that should be processed */
/* using a vector loop. If zero, then only the scalar loop */
/* will be used. */
/* ABSTOL (input) REAL */
/* The minimum (absolute) width of an interval. When an */
/* interval is narrower than ABSTOL, or than RELTOL times the */
/* larger (in magnitude) endpoint, then it is considered to be */
/* sufficiently small, i.e., converged. This must be at least */
/* zero. */
/* RELTOL (input) REAL */
/* The minimum relative width of an interval. When an interval */
/* is narrower than ABSTOL, or than RELTOL times the larger (in */
/* magnitude) endpoint, then it is considered to be */
/* sufficiently small, i.e., converged. Note: this should */
/* always be at least radix*machine epsilon. */
/* PIVMIN (input) REAL */
/* The minimum absolute value of a "pivot" in the Sturm */
/* sequence loop. This *must* be at least max |e(j)**2| * */
/* safe_min and at least safe_min, where safe_min is at least */
/* the smallest number that can divide one without overflow. */
/* D (input) REAL array, dimension (N) */
/* The diagonal elements of the tridiagonal matrix T. */
/* E (input) REAL array, dimension (N) */
/* The offdiagonal elements of the tridiagonal matrix T in */
/* positions 1 through N-1. E(N) is arbitrary. */
/* E2 (input) REAL array, dimension (N) */
/* The squares of the offdiagonal elements of the tridiagonal */
/* matrix T. E2(N) is ignored. */
/* NVAL (input/output) INTEGER array, dimension (MINP) */
/* If IJOB=1 or 2, not referenced. */
/* If IJOB=3, the desired values of N(w). The elements of NVAL */
/* will be reordered to correspond with the intervals in AB. */
/* Thus, NVAL(j) on output will not, in general be the same as */
/* NVAL(j) on input, but it will correspond with the interval */
/* (AB(j,1),AB(j,2)] on output. */
/* AB (input/output) REAL array, dimension (MMAX,2) */
/* The endpoints of the intervals. AB(j,1) is a(j), the left */
/* endpoint of the j-th interval, and AB(j,2) is b(j), the */
/* right endpoint of the j-th interval. The input intervals */
/* will, in general, be modified, split, and reordered by the */
/* calculation. */
/* C (input/output) REAL array, dimension (MMAX) */
/* If IJOB=1, ignored. */
/* If IJOB=2, workspace. */
/* If IJOB=3, then on input C(j) should be initialized to the */
/* first search point in the binary search. */
/* MOUT (output) INTEGER */
/* If IJOB=1, the number of eigenvalues in the intervals. */
/* If IJOB=2 or 3, the number of intervals output. */
/* If IJOB=3, MOUT will equal MINP. */
/* NAB (input/output) INTEGER array, dimension (MMAX,2) */
/* If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)). */
/* If IJOB=2, then on input, NAB(i,j) should be set. It must */
/* satisfy the condition: */
/* N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)), */
/* which means that in interval i only eigenvalues */
/* NAB(i,1)+1,...,NAB(i,2) will be considered. Usually, */
/* NAB(i,j)=N(AB(i,j)), from a previous call to SLAEBZ with */
/* IJOB=1. */
/* On output, NAB(i,j) will contain */
/* max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of */
/* the input interval that the output interval */
/* (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the */
/* the input values of NAB(k,1) and NAB(k,2). */
/* If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)), */
/* unless N(w) > NVAL(i) for all search points w , in which */
/* case NAB(i,1) will not be modified, i.e., the output */
/* value will be the same as the input value (modulo */
/* reorderings -- see NVAL and AB), or unless N(w) < NVAL(i) */
/* for all search points w , in which case NAB(i,2) will */
/* not be modified. Normally, NAB should be set to some */
/* distinctive value(s) before SLAEBZ is called. */
/* WORK (workspace) REAL array, dimension (MMAX) */
/* Workspace. */
/* IWORK (workspace) INTEGER array, dimension (MMAX) */
/* Workspace. */
/* INFO (output) INTEGER */
/* = 0: All intervals converged. */
/* = 1--MMAX: The last INFO intervals did not converge. */
/* = MMAX+1: More than MMAX intervals were generated. */
/* Further Details */
/* =============== */
/* This routine is intended to be called only by other LAPACK */
/* routines, thus the interface is less user-friendly. It is intended */
/* for two purposes: */
/* (a) finding eigenvalues. In this case, SLAEBZ should have one or */
/* more initial intervals set up in AB, and SLAEBZ should be called */
/* with IJOB=1. This sets up NAB, and also counts the eigenvalues. */
/* Intervals with no eigenvalues would usually be thrown out at */
/* this point. Also, if not all the eigenvalues in an interval i */
/* are desired, NAB(i,1) can be increased or NAB(i,2) decreased. */
/* For example, set NAB(i,1)=NAB(i,2)-1 to get the largest */
/* eigenvalue. SLAEBZ is then called with IJOB=2 and MMAX */
/* no smaller than the value of MOUT returned by the call with */
/* IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1 */
/* through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the */
/* tolerance specified by ABSTOL and RELTOL. */
/* (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l). */
/* In this case, start with a Gershgorin interval (a,b). Set up */
/* AB to contain 2 search intervals, both initially (a,b). One */
/* NVAL element should contain f-1 and the other should contain l */
/* , while C should contain a and b, resp. NAB(i,1) should be -1 */
/* and NAB(i,2) should be N+1, to flag an error if the desired */
/* interval does not lie in (a,b). SLAEBZ is then called with */
/* IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals -- */
/* j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while */
/* if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r */
/* >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and */
/* N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and */
/* w(l-r)=...=w(l+k) are handled similarly. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Check for Errors */
/* Parameter adjustments */
nab_dim1 = *mmax;
nab_offset = 1 + nab_dim1;
nab -= nab_offset;
ab_dim1 = *mmax;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--d__;
--e;
--e2;
--nval;
--c__;
--work;
--iwork;
/* Function Body */
*info = 0;
if (*ijob < 1 || *ijob > 3) {
*info = -1;
return 0;
}
/* Initialize NAB */
if (*ijob == 1) {
/* Compute the number of eigenvalues in the initial intervals. */
*mout = 0;
/* DIR$ NOVECTOR */
i__1 = *minp;
for (ji = 1; ji <= i__1; ++ji) {
for (jp = 1; jp <= 2; ++jp) {
tmp1 = d__[1] - ab[ji + jp * ab_dim1];
if (dabs(tmp1) < *pivmin) {
tmp1 = -(*pivmin);
}
nab[ji + jp * nab_dim1] = 0;
if (tmp1 <= 0.f) {
nab[ji + jp * nab_dim1] = 1;
}
i__2 = *n;
for (j = 2; j <= i__2; ++j) {
tmp1 = d__[j] - e2[j - 1] / tmp1 - ab[ji + jp * ab_dim1];
if (dabs(tmp1) < *pivmin) {
tmp1 = -(*pivmin);
}
if (tmp1 <= 0.f) {
++nab[ji + jp * nab_dim1];
}
/* L10: */
}
/* L20: */
}
*mout = *mout + nab[ji + (nab_dim1 << 1)] - nab[ji + nab_dim1];
/* L30: */
}
return 0;
}
/* Initialize for loop */
/* KF and KL have the following meaning: */
/* Intervals 1,...,KF-1 have converged. */
/* Intervals KF,...,KL still need to be refined. */
kf = 1;
kl = *minp;
/* If IJOB=2, initialize C. */
/* If IJOB=3, use the user-supplied starting point. */
if (*ijob == 2) {
i__1 = *minp;
for (ji = 1; ji <= i__1; ++ji) {
c__[ji] = (ab[ji + ab_dim1] + ab[ji + (ab_dim1 << 1)]) * .5f;
/* L40: */
}
}
/* Iteration loop */
i__1 = *nitmax;
for (jit = 1; jit <= i__1; ++jit) {
/* Loop over intervals */
if (kl - kf + 1 >= *nbmin && *nbmin > 0) {
/* Begin of Parallel Version of the loop */
i__2 = kl;
for (ji = kf; ji <= i__2; ++ji) {
/* Compute N(c), the number of eigenvalues less than c */
work[ji] = d__[1] - c__[ji];
iwork[ji] = 0;
if (work[ji] <= *pivmin) {
iwork[ji] = 1;
/* Computing MIN */
r__1 = work[ji], r__2 = -(*pivmin);
work[ji] = dmin(r__1,r__2);
}
i__3 = *n;
for (j = 2; j <= i__3; ++j) {
work[ji] = d__[j] - e2[j - 1] / work[ji] - c__[ji];
if (work[ji] <= *pivmin) {
++iwork[ji];
/* Computing MIN */
r__1 = work[ji], r__2 = -(*pivmin);
work[ji] = dmin(r__1,r__2);
}
/* L50: */
}
/* L60: */
}
if (*ijob <= 2) {
/* IJOB=2: Choose all intervals containing eigenvalues. */
klnew = kl;
i__2 = kl;
for (ji = kf; ji <= i__2; ++ji) {
/* Insure that N(w) is monotone */
/* Computing MIN */
/* Computing MAX */
i__5 = nab[ji + nab_dim1], i__6 = iwork[ji];
i__3 = nab[ji + (nab_dim1 << 1)], i__4 = max(i__5,i__6);
iwork[ji] = min(i__3,i__4);
/* Update the Queue -- add intervals if both halves */
/* contain eigenvalues. */
if (iwork[ji] == nab[ji + (nab_dim1 << 1)]) {
/* No eigenvalue in the upper interval: */
/* just use the lower interval. */
ab[ji + (ab_dim1 << 1)] = c__[ji];
} else if (iwork[ji] == nab[ji + nab_dim1]) {
/* No eigenvalue in the lower interval: */
/* just use the upper interval. */
ab[ji + ab_dim1] = c__[ji];
} else {
++klnew;
if (klnew <= *mmax) {
/* Eigenvalue in both intervals -- add upper to */
/* queue. */
ab[klnew + (ab_dim1 << 1)] = ab[ji + (ab_dim1 <<
1)];
nab[klnew + (nab_dim1 << 1)] = nab[ji + (nab_dim1
<< 1)];
ab[klnew + ab_dim1] = c__[ji];
nab[klnew + nab_dim1] = iwork[ji];
ab[ji + (ab_dim1 << 1)] = c__[ji];
nab[ji + (nab_dim1 << 1)] = iwork[ji];
} else {
*info = *mmax + 1;
}
}
/* L70: */
}
if (*info != 0) {
return 0;
}
kl = klnew;
} else {
/* IJOB=3: Binary search. Keep only the interval containing */
/* w s.t. N(w) = NVAL */
i__2 = kl;
for (ji = kf; ji <= i__2; ++ji) {
if (iwork[ji] <= nval[ji]) {
ab[ji + ab_dim1] = c__[ji];
nab[ji + nab_dim1] = iwork[ji];
}
if (iwork[ji] >= nval[ji]) {
ab[ji + (ab_dim1 << 1)] = c__[ji];
nab[ji + (nab_dim1 << 1)] = iwork[ji];
}
/* L80: */
}
}
} else {
/* End of Parallel Version of the loop */
/* Begin of Serial Version of the loop */
klnew = kl;
i__2 = kl;
for (ji = kf; ji <= i__2; ++ji) {
/* Compute N(w), the number of eigenvalues less than w */
tmp1 = c__[ji];
tmp2 = d__[1] - tmp1;
itmp1 = 0;
if (tmp2 <= *pivmin) {
itmp1 = 1;
/* Computing MIN */
r__1 = tmp2, r__2 = -(*pivmin);
tmp2 = dmin(r__1,r__2);
}
/* 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 = *n;
for (j = 2; j <= i__3; ++j) {
tmp2 = d__[j] - e2[j - 1] / tmp2 - tmp1;
if (tmp2 <= *pivmin) {
++itmp1;
/* Computing MIN */
r__1 = tmp2, r__2 = -(*pivmin);
tmp2 = dmin(r__1,r__2);
}
/* L90: */
}
if (*ijob <= 2) {
/* IJOB=2: Choose all intervals containing eigenvalues. */
/* Insure that N(w) is monotone */
/* Computing MIN */
/* Computing MAX */
i__5 = nab[ji + nab_dim1];
i__3 = nab[ji + (nab_dim1 << 1)], i__4 = max(i__5,itmp1);
itmp1 = min(i__3,i__4);
/* Update the Queue -- add intervals if both halves */
/* contain eigenvalues. */
if (itmp1 == nab[ji + (nab_dim1 << 1)]) {
/* No eigenvalue in the upper interval: */
/* just use the lower interval. */
ab[ji + (ab_dim1 << 1)] = tmp1;
} else if (itmp1 == nab[ji + nab_dim1]) {
/* No eigenvalue in the lower interval: */
/* just use the upper interval. */
ab[ji + ab_dim1] = tmp1;
} else if (klnew < *mmax) {
/* Eigenvalue in both intervals -- add upper to queue. */
++klnew;
ab[klnew + (ab_dim1 << 1)] = ab[ji + (ab_dim1 << 1)];
nab[klnew + (nab_dim1 << 1)] = nab[ji + (nab_dim1 <<
1)];
ab[klnew + ab_dim1] = tmp1;
nab[klnew + nab_dim1] = itmp1;
ab[ji + (ab_dim1 << 1)] = tmp1;
nab[ji + (nab_dim1 << 1)] = itmp1;
} else {
*info = *mmax + 1;
return 0;
}
} else {
/* IJOB=3: Binary search. Keep only the interval */
/* containing w s.t. N(w) = NVAL */
if (itmp1 <= nval[ji]) {
ab[ji + ab_dim1] = tmp1;
nab[ji + nab_dim1] = itmp1;
}
if (itmp1 >= nval[ji]) {
ab[ji + (ab_dim1 << 1)] = tmp1;
nab[ji + (nab_dim1 << 1)] = itmp1;
}
}
/* L100: */
}
kl = klnew;
/* End of Serial Version of the loop */
}
/* Check for convergence */
kfnew = kf;
i__2 = kl;
for (ji = kf; ji <= i__2; ++ji) {
tmp1 = (r__1 = ab[ji + (ab_dim1 << 1)] - ab[ji + ab_dim1], dabs(
r__1));
/* Computing MAX */
r__3 = (r__1 = ab[ji + (ab_dim1 << 1)], dabs(r__1)), r__4 = (r__2
= ab[ji + ab_dim1], dabs(r__2));
tmp2 = dmax(r__3,r__4);
/* Computing MAX */
r__1 = max(*abstol,*pivmin), r__2 = *reltol * tmp2;
if (tmp1 < dmax(r__1,r__2) || nab[ji + nab_dim1] >= nab[ji + (
nab_dim1 << 1)]) {
/* Converged -- Swap with position KFNEW, */
/* then increment KFNEW */
if (ji > kfnew) {
tmp1 = ab[ji + ab_dim1];
tmp2 = ab[ji + (ab_dim1 << 1)];
itmp1 = nab[ji + nab_dim1];
itmp2 = nab[ji + (nab_dim1 << 1)];
ab[ji + ab_dim1] = ab[kfnew + ab_dim1];
ab[ji + (ab_dim1 << 1)] = ab[kfnew + (ab_dim1 << 1)];
nab[ji + nab_dim1] = nab[kfnew + nab_dim1];
nab[ji + (nab_dim1 << 1)] = nab[kfnew + (nab_dim1 << 1)];
ab[kfnew + ab_dim1] = tmp1;
ab[kfnew + (ab_dim1 << 1)] = tmp2;
nab[kfnew + nab_dim1] = itmp1;
nab[kfnew + (nab_dim1 << 1)] = itmp2;
if (*ijob == 3) {
itmp1 = nval[ji];
nval[ji] = nval[kfnew];
nval[kfnew] = itmp1;
}
}
++kfnew;
}
/* L110: */
}
kf = kfnew;
/* Choose Midpoints */
i__2 = kl;
for (ji = kf; ji <= i__2; ++ji) {
c__[ji] = (ab[ji + ab_dim1] + ab[ji + (ab_dim1 << 1)]) * .5f;
/* L120: */
}
/* If no more intervals to refine, quit. */
if (kf > kl) {
goto L140;
}
/* L130: */
}
/* Converged */
L140:
/* Computing MAX */
i__1 = kl + 1 - kf;
*info = max(i__1,0);
*mout = kl;
return 0;
/* End of SLAEBZ */
} /* slaebz_ */
/* Subroutine */ int sbdt01_(integer *m, integer *n, integer *kd, real *a,
integer *lda, real *q, integer *ldq, real *d__, real *e, real *pt,
integer *ldpt, real *work, real *resid)
{
/* System generated locals */
integer a_dim1, a_offset, pt_dim1, pt_offset, q_dim1, q_offset, i__1,
i__2;
real r__1, r__2;
/* Local variables */
integer i__, j;
real eps, anorm;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *);
extern doublereal sasum_(integer *, real *, integer *);
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SBDT01 reconstructs a general matrix A from its bidiagonal form */
/* A = Q * B * P' */
/* where Q (m by min(m,n)) and P' (min(m,n) by n) are orthogonal */
/* matrices and B is bidiagonal. */
/* The test ratio to test the reduction is */
/* RESID = norm( A - Q * B * PT ) / ( n * norm(A) * EPS ) */
/* where PT = P' and EPS is the machine precision. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrices A and Q. */
/* N (input) INTEGER */
/* The number of columns of the matrices A and P'. */
/* KD (input) INTEGER */
/* If KD = 0, B is diagonal and the array E is not referenced. */
/* If KD = 1, the reduction was performed by xGEBRD; B is upper */
/* bidiagonal if M >= N, and lower bidiagonal if M < N. */
/* If KD = -1, the reduction was performed by xGBBRD; B is */
/* always upper bidiagonal. */
/* A (input) REAL array, dimension (LDA,N) */
/* The m by n matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* Q (input) REAL array, dimension (LDQ,N) */
/* The m by min(m,n) orthogonal matrix Q in the reduction */
/* A = Q * B * P'. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= max(1,M). */
/* D (input) REAL array, dimension (min(M,N)) */
/* The diagonal elements of the bidiagonal matrix B. */
/* E (input) REAL array, dimension (min(M,N)-1) */
/* The superdiagonal elements of the bidiagonal matrix B if */
/* m >= n, or the subdiagonal elements of B if m < n. */
/* PT (input) REAL array, dimension (LDPT,N) */
/* The min(m,n) by n orthogonal matrix P' in the reduction */
/* A = Q * B * P'. */
/* LDPT (input) INTEGER */
/* The leading dimension of the array PT. */
/* LDPT >= max(1,min(M,N)). */
/* WORK (workspace) REAL array, dimension (M+N) */
/* RESID (output) REAL */
/* The test ratio: norm(A - Q * B * P') / ( n * norm(A) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--d__;
--e;
pt_dim1 = *ldpt;
pt_offset = 1 + pt_dim1;
pt -= pt_offset;
--work;
/* Function Body */
if (*m <= 0 || *n <= 0) {
*resid = 0.f;
return 0;
}
/* Compute A - Q * B * P' one column at a time. */
*resid = 0.f;
if (*kd != 0) {
/* B is bidiagonal. */
if (*kd != 0 && *m >= *n) {
/* B is upper bidiagonal and M >= N. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
scopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
i__2 = *n - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*m + i__] = d__[i__] * pt[i__ + j * pt_dim1] + e[i__]
* pt[i__ + 1 + j * pt_dim1];
/* L10: */
}
work[*m + *n] = d__[*n] * pt[*n + j * pt_dim1];
sgemv_("No transpose", m, n, &c_b7, &q[q_offset], ldq, &work[*
m + 1], &c__1, &c_b9, &work[1], &c__1);
/* Computing MAX */
r__1 = *resid, r__2 = sasum_(m, &work[1], &c__1);
*resid = dmax(r__1,r__2);
/* L20: */
}
} else if (*kd < 0) {
/* B is upper bidiagonal and M < N. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
scopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
i__2 = *m - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*m + i__] = d__[i__] * pt[i__ + j * pt_dim1] + e[i__]
* pt[i__ + 1 + j * pt_dim1];
/* L30: */
}
work[*m + *m] = d__[*m] * pt[*m + j * pt_dim1];
sgemv_("No transpose", m, m, &c_b7, &q[q_offset], ldq, &work[*
m + 1], &c__1, &c_b9, &work[1], &c__1);
/* Computing MAX */
r__1 = *resid, r__2 = sasum_(m, &work[1], &c__1);
*resid = dmax(r__1,r__2);
/* L40: */
}
} else {
/* B is lower bidiagonal. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
scopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
work[*m + 1] = d__[1] * pt[j * pt_dim1 + 1];
i__2 = *m;
for (i__ = 2; i__ <= i__2; ++i__) {
work[*m + i__] = e[i__ - 1] * pt[i__ - 1 + j * pt_dim1] +
d__[i__] * pt[i__ + j * pt_dim1];
/* L50: */
}
sgemv_("No transpose", m, m, &c_b7, &q[q_offset], ldq, &work[*
m + 1], &c__1, &c_b9, &work[1], &c__1);
/* Computing MAX */
r__1 = *resid, r__2 = sasum_(m, &work[1], &c__1);
*resid = dmax(r__1,r__2);
/* L60: */
}
}
} else {
/* B is diagonal. */
if (*m >= *n) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
scopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*m + i__] = d__[i__] * pt[i__ + j * pt_dim1];
/* L70: */
}
sgemv_("No transpose", m, n, &c_b7, &q[q_offset], ldq, &work[*
m + 1], &c__1, &c_b9, &work[1], &c__1);
/* Computing MAX */
r__1 = *resid, r__2 = sasum_(m, &work[1], &c__1);
*resid = dmax(r__1,r__2);
/* L80: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
scopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*m + i__] = d__[i__] * pt[i__ + j * pt_dim1];
/* L90: */
}
sgemv_("No transpose", m, m, &c_b7, &q[q_offset], ldq, &work[*
m + 1], &c__1, &c_b9, &work[1], &c__1);
/* Computing MAX */
r__1 = *resid, r__2 = sasum_(m, &work[1], &c__1);
*resid = dmax(r__1,r__2);
/* L100: */
}
}
}
/* Compute norm(A - Q * B * P') / ( n * norm(A) * EPS ) */
anorm = slange_("1", m, n, &a[a_offset], lda, &work[1]);
eps = slamch_("Precision");
if (anorm <= 0.f) {
if (*resid != 0.f) {
*resid = 1.f / eps;
}
} else {
if (anorm >= *resid) {
*resid = *resid / anorm / ((real) (*n) * eps);
} else {
if (anorm < 1.f) {
/* Computing MIN */
r__1 = *resid, r__2 = (real) (*n) * anorm;
*resid = dmin(r__1,r__2) / anorm / ((real) (*n) * eps);
} else {
/* Computing MIN */
r__1 = *resid / anorm, r__2 = (real) (*n);
*resid = dmin(r__1,r__2) / ((real) (*n) * eps);
}
}
}
return 0;
/* End of SBDT01 */
} /* sbdt01_ */
/* Subroutine */ int sget07_(char *trans, integer *n, integer *nrhs, real *a,
integer *lda, real *b, integer *ldb, real *x, integer *ldx, real *
xact, integer *ldxact, real *ferr, logical *chkferr, real *berr, real
*reslts)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
xact_offset, i__1, i__2, i__3;
real r__1, r__2, r__3;
/* Local variables */
integer i__, j, k;
real eps, tmp, diff, axbi;
integer imax;
real unfl, ovfl;
real xnorm;
real errbnd;
logical notran;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGET07 tests the error bounds from iterative refinement for the */
/* computed solution to a system of equations op(A)*X = B, where A is a */
/* general n by n matrix and op(A) = A or A**T, depending on TRANS. */
/* RESLTS(1) = test of the error bound */
/* = norm(X - XACT) / ( norm(X) * FERR ) */
/* A large value is returned if this ratio is not less than one. */
/* RESLTS(2) = residual from the iterative refinement routine */
/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
/* (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
/* Arguments */
/* ========= */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations. */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A**T * X = B (Transpose) */
/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
/* N (input) INTEGER */
/* The number of rows of the matrices X and XACT. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of columns of the matrices X and XACT. NRHS >= 0. */
/* A (input) REAL array, dimension (LDA,N) */
/* The original n by n matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input) REAL array, dimension (LDB,NRHS) */
/* The right hand side vectors for the system of linear */
/* equations. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (input) REAL array, dimension (LDX,NRHS) */
/* The computed solution vectors. Each vector is stored as a */
/* column of the matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* XACT (input) REAL array, dimension (LDX,NRHS) */
/* The exact solution vectors. Each vector is stored as a */
/* column of the matrix XACT. */
/* LDXACT (input) INTEGER */
/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
/* FERR (input) REAL array, dimension (NRHS) */
/* The estimated forward error bounds for each solution vector */
/* X. If XTRUE is the true solution, FERR bounds the magnitude */
/* of the largest entry in (X - XTRUE) divided by the magnitude */
/* of the largest entry in X. */
/* CHKFERR (input) LOGICAL */
/* Set to .TRUE. to check FERR, .FALSE. not to check FERR. */
/* When the test system is ill-conditioned, the "true" */
/* solution in XACT may be incorrect. */
/* BERR (input) REAL array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector (i.e., the smallest relative change in any entry of A */
/* or B that makes X an exact solution). */
/* RESLTS (output) REAL array, dimension (2) */
/* The maximum over the NRHS solution vectors of the ratios: */
/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 or NRHS = 0. */
/* 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;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.f;
reslts[2] = 0.f;
return 0;
}
eps = slamch_("Epsilon");
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
notran = lsame_(trans, "N");
/* Test 1: Compute the maximum of */
/* norm(X - XACT) / ( norm(X) * FERR ) */
/* over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.f;
if (*chkferr) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = isamax_(n, &x[j * x_dim1 + 1], &c__1);
/* Computing MAX */
r__2 = (r__1 = x[imax + j * x_dim1], dabs(r__1));
xnorm = dmax(r__2,unfl);
diff = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = diff, r__3 = (r__1 = x[i__ + j * x_dim1] - xact[i__ +
j * xact_dim1], dabs(r__1));
diff = dmax(r__2,r__3);
/* L10: */
}
if (xnorm > 1.f) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1.f / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
errbnd = dmax(r__1,r__2);
} else {
errbnd = 1.f / eps;
}
L30:
;
}
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
/* (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
i__1 = *nrhs;
for (k = 1; k <= i__1; ++k) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
tmp = (r__1 = b[i__ + k * b_dim1], dabs(r__1));
if (notran) {
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
tmp += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * (r__2 =
x[j + k * x_dim1], dabs(r__2));
/* L40: */
}
} else {
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
tmp += (r__1 = a[j + i__ * a_dim1], dabs(r__1)) * (r__2 =
x[j + k * x_dim1], dabs(r__2));
/* L50: */
}
}
if (i__ == 1) {
axbi = tmp;
} else {
axbi = dmin(axbi,tmp);
}
/* L60: */
}
/* Computing MAX */
r__1 = axbi, r__2 = (*n + 1) * unfl;
tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / dmax(r__1,r__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = dmax(reslts[2],tmp);
}
/* L70: */
}
return 0;
/* End of SGET07 */
} /* sget07_ */
/* Subroutine */ int cdrvbd_(integer *nsizes, integer *mm, integer *nn,
integer *ntypes, logical *dotype, integer *iseed, real *thresh,
complex *a, integer *lda, complex *u, integer *ldu, complex *vt,
integer *ldvt, complex *asav, complex *usav, complex *vtsav, real *s,
real *ssav, real *e, complex *work, integer *lwork, real *rwork,
integer *iwork, integer *nounit, integer *info)
{
/* Initialized data */
static char cjob[1*4] = "N" "O" "S" "A";
/* Format strings */
static char fmt_9996[] = "(\002 CDRVBD: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002M=\002,i6,\002, N=\002,i6,\002, JTYPE=\002,i"
"6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9995[] = "(\002 CDRVBD: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002M=\002,i6,\002, N=\002,i6,\002, JTYPE=\002,i"
"6,\002, LSWORK=\002,i6,/9x,\002ISEED=(\002,3(i5,\002,\002),i5"
",\002)\002)";
static char fmt_9999[] = "(\002 SVD -- Complex Singular Value Decomposit"
"ion Driver \002,/\002 Matrix types (see CDRVBD for details):\002"
",//\002 1 = Zero matrix\002,/\002 2 = Identity matrix\002,/\002 "
"3 = Evenly spaced singular values near 1\002,/\002 4 = Evenly sp"
"aced singular values near underflow\002,/\002 5 = Evenly spaced "
"singular values near overflow\002,//\002 Tests performed: ( A is"
" dense, U and V are unitary,\002,/19x,\002 S is an array, and Up"
"artial, VTpartial, and\002,/19x,\002 Spartial are partially comp"
"uted U, VT and S),\002,/)";
static char fmt_9998[] = "(\002 Tests performed with Test Threshold ="
" \002,f8.2,/\002 CGESVD: \002,/\002 1 = | A - U diag(S) VT | / ("
" |A| max(M,N) ulp ) \002,/\002 2 = | I - U**T U | / ( M ulp )"
" \002,/\002 3 = | I - VT VT**T | / ( N ulp ) \002,/\002 4 = 0 if"
" S contains min(M,N) nonnegative values in\002,\002 decreasing o"
"rder, else 1/ulp\002,/\002 5 = | U - Upartial | / ( M ulp )\002,/"
"\002 6 = | VT - VTpartial | / ( N ulp )\002,/\002 7 = | S - Spar"
"tial | / ( min(M,N) ulp |S| )\002,/\002 CGESDD: \002,/\002 8 = |"
" A - U diag(S) VT | / ( |A| max(M,N) ulp ) \002,/\002 9 = | I - "
"U**T U | / ( M ulp ) \002,/\00210 = | I - VT VT**T | / ( N ulp ) "
"\002,/\00211 = 0 if S contains min(M,N) nonnegative values in"
"\002,\002 decreasing order, else 1/ulp\002,/\00212 = | U - Upart"
"ial | / ( M ulp )\002,/\00213 = | VT - VTpartial | / ( N ulp "
")\002,/\00214 = | S - Spartial | / ( min(M,N) ulp |S| )\002,//)";
static char fmt_9997[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, type "
"\002,i1,\002, IWS=\002,i1,\002, seed=\002,4(i4,\002,\002),\002 t"
"est(\002,i1,\002)=\002,g11.4)";
/* System generated locals */
integer a_dim1, a_offset, asav_dim1, asav_offset, u_dim1, u_offset,
usav_dim1, usav_offset, vt_dim1, vt_offset, vtsav_dim1,
vtsav_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
i__9, i__10, i__11, i__12, i__13, i__14;
real r__1, r__2, r__3;
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static char jobq[1], jobu[1];
static integer mmax, nmax;
static real unfl, ovfl;
static integer ijvt, i__, j, m, n;
extern /* Subroutine */ int cbdt01_(integer *, integer *, integer *,
complex *, integer *, complex *, integer *, real *, real *,
complex *, integer *, complex *, real *, real *);
static logical badmm, badnn;
static integer nfail, iinfo;
extern /* Subroutine */ int cunt01_(char *, integer *, integer *, complex
*, integer *, complex *, integer *, real *, real *);
static real anorm;
extern /* Subroutine */ int cunt03_(char *, integer *, integer *, integer
*, integer *, complex *, integer *, complex *, integer *, complex
*, integer *, real *, real *, integer *);
static integer mnmin, mnmax;
static char jobvt[1];
static integer iwspc, jsize, nerrs, jtype, ntest, iwtmp;
extern /* Subroutine */ int cgesdd_(char *, integer *, integer *, complex
*, integer *, real *, complex *, integer *, complex *, integer *,
complex *, integer *, real *, integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int cgesvd_(char *, char *, integer *, integer *,
complex *, integer *, real *, complex *, integer *, complex *,
integer *, complex *, integer *, real *, integer *), clacpy_(char *, integer *, integer *, complex *, integer
*, complex *, integer *), claset_(char *, integer *,
integer *, complex *, complex *, complex *, integer *);
static integer ioldsd[4];
extern /* Subroutine */ int xerbla_(char *, integer *), alasvm_(
char *, integer *, integer *, integer *, integer *),
clatms_(integer *, integer *, char *, integer *, char *, real *,
integer *, real *, real *, integer *, integer *, char *, complex *
, integer *, complex *, integer *);
static integer ntestf, minwrk;
static real ulpinv, result[14];
static integer lswork, mtypes, ntestt;
static real dif, div;
static integer ijq, iju;
static real ulp;
/* Fortran I/O blocks */
static cilist io___27 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1999
Purpose
=======
CDRVBD checks the singular value decomposition (SVD) driver CGESVD
and CGESDD.
CGESVD and CGESDD factors A = U diag(S) VT, where U and VT are
unitary and diag(S) is diagonal with the entries of the array S on
its diagonal. The entries of S are the singular values, nonnegative
and stored in decreasing order. U and VT can be optionally not
computed, overwritten on A, or computed partially.
A is M by N. Let MNMIN = min( M, N ). S has dimension MNMIN.
U can be M by M or M by MNMIN. VT can be N by N or MNMIN by N.
When CDRVBD is called, a number of matrix "sizes" (M's and N's)
and a number of matrix "types" are specified. For each size (M,N)
and each type of matrix, and for the minimal workspace as well as
workspace adequate to permit blocking, an M x N matrix "A" will be
generated and used to test the SVD routines. For each matrix, A will
be factored as A = U diag(S) VT and the following 12 tests computed:
Test for CGESVD:
(1) | A - U diag(S) VT | / ( |A| max(M,N) ulp )
(2) | I - U'U | / ( M ulp )
(3) | I - VT VT' | / ( N ulp )
(4) S contains MNMIN nonnegative values in decreasing order.
(Return 0 if true, 1/ULP if false.)
(5) | U - Upartial | / ( M ulp ) where Upartial is a partially
computed U.
(6) | VT - VTpartial | / ( N ulp ) where VTpartial is a partially
computed VT.
(7) | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the
vector of singular values from the partial SVD
Test for CGESDD:
(1) | A - U diag(S) VT | / ( |A| max(M,N) ulp )
(2) | I - U'U | / ( M ulp )
(3) | I - VT VT' | / ( N ulp )
(4) S contains MNMIN nonnegative values in decreasing order.
(Return 0 if true, 1/ULP if false.)
(5) | U - Upartial | / ( M ulp ) where Upartial is a partially
computed U.
(6) | VT - VTpartial | / ( N ulp ) where VTpartial is a partially
computed VT.
(7) | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the
vector of singular values from the partial SVD
The "sizes" are specified by the arrays MM(1:NSIZES) and
NN(1:NSIZES); the value of each element pair (MM(j),NN(j))
specifies one size. The "types" are specified by a logical array
DOTYPE( 1:NTYPES ); if DOTYPE(j) is .TRUE., then matrix type "j"
will be generated.
Currently, the list of possible types is:
(1) The zero matrix.
(2) The identity matrix.
(3) A matrix of the form U D V, where U and V are unitary and
D has evenly spaced entries 1, ..., ULP with random signs
on the diagonal.
(4) Same as (3), but multiplied by the underflow-threshold / ULP.
(5) Same as (3), but multiplied by the overflow-threshold * ULP.
Arguments
==========
NSIZES (input) INTEGER
The number of sizes of matrices to use. If it is zero,
CDRVBD does nothing. It must be at least zero.
MM (input) INTEGER array, dimension (NSIZES)
An array containing the matrix "heights" to be used. For
each j=1,...,NSIZES, if MM(j) is zero, then MM(j) and NN(j)
will be ignored. The MM(j) values must be at least zero.
NN (input) INTEGER array, dimension (NSIZES)
An array containing the matrix "widths" to be used. For
each j=1,...,NSIZES, if NN(j) is zero, then MM(j) and NN(j)
will be ignored. The NN(j) values must be at least zero.
NTYPES (input) INTEGER
The number of elements in DOTYPE. If it is zero, CDRVBD
does nothing. It must be at least zero. If it is MAXTYP+1
and NSIZES is 1, then an additional type, MAXTYP+1 is
defined, which is to use whatever matrices are in A and B.
This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
DOTYPE(MAXTYP+1) is .TRUE. .
DOTYPE (input) LOGICAL array, dimension (NTYPES)
If DOTYPE(j) is .TRUE., then for each size (m,n), a matrix
of type j will be generated. If NTYPES is smaller than the
maximum number of types defined (PARAMETER MAXTYP), then
types NTYPES+1 through MAXTYP will not be generated. If
NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through
DOTYPE(NTYPES) will be ignored.
ISEED (input/output) INTEGER array, dimension (4)
On entry ISEED specifies the seed of the random number
generator. The array elements should be between 0 and 4095;
if not they will be reduced mod 4096. Also, ISEED(4) must
be odd. The random number generator uses a linear
congruential sequence limited to small integers, and so
should produce machine independent random numbers. The
values of ISEED are changed on exit, and can be used in the
next call to CDRVBD to continue the same random number
sequence.
THRESH (input) REAL
A test will count as "failed" if the "error", computed as
described above, exceeds THRESH. Note that the error
is scaled to be O(1), so THRESH should be a reasonably
small multiple of 1, e.g., 10 or 100. In particular,
it should not depend on the precision (single vs. double)
or the size of the matrix. It must be at least zero.
NOUNIT (input) INTEGER
The FORTRAN unit number for printing out error messages
(e.g., if a routine returns IINFO not equal to 0.)
A (output) COMPLEX array, dimension (LDA,max(NN))
Used to hold the matrix whose singular values are to be
computed. On exit, A contains the last matrix actually
used.
LDA (input) INTEGER
The leading dimension of A. It must be at
least 1 and at least max( MM ).
U (output) COMPLEX array, dimension (LDU,max(MM))
Used to hold the computed matrix of right singular vectors.
On exit, U contains the last such vectors actually computed.
LDU (input) INTEGER
The leading dimension of U. It must be at
least 1 and at least max( MM ).
VT (output) COMPLEX array, dimension (LDVT,max(NN))
Used to hold the computed matrix of left singular vectors.
On exit, VT contains the last such vectors actually computed.
LDVT (input) INTEGER
The leading dimension of VT. It must be at
least 1 and at least max( NN ).
ASAV (output) COMPLEX array, dimension (LDA,max(NN))
Used to hold a different copy of the matrix whose singular
values are to be computed. On exit, A contains the last
matrix actually used.
USAV (output) COMPLEX array, dimension (LDU,max(MM))
Used to hold a different copy of the computed matrix of
right singular vectors. On exit, USAV contains the last such
vectors actually computed.
VTSAV (output) COMPLEX array, dimension (LDVT,max(NN))
Used to hold a different copy of the computed matrix of
left singular vectors. On exit, VTSAV contains the last such
vectors actually computed.
S (output) REAL array, dimension (max(min(MM,NN)))
Contains the computed singular values.
SSAV (output) REAL array, dimension (max(min(MM,NN)))
Contains another copy of the computed singular values.
E (output) REAL array, dimension (max(min(MM,NN)))
Workspace for CGESVD.
WORK (workspace) COMPLEX array, dimension (LWORK)
LWORK (input) INTEGER
The number of entries in WORK. This must be at least
MAX(3*MIN(M,N)+MAX(M,N)**2,5*MIN(M,N),3*MAX(M,N)) for all
pairs (M,N)=(MM(j),NN(j))
RWORK (workspace) REAL array,
dimension ( 5*max(max(MM,NN)) )
IWORK (workspace) INTEGER array, dimension at least 8*min(M,N)
RESULT (output) REAL array, dimension (7)
The values computed by the 7 tests described above.
The values are currently limited to 1/ULP, to avoid
overflow.
INFO (output) INTEGER
If 0, then everything ran OK.
-1: NSIZES < 0
-2: Some MM(j) < 0
-3: Some NN(j) < 0
-4: NTYPES < 0
-7: THRESH < 0
-10: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ).
-12: LDU < 1 or LDU < MMAX.
-14: LDVT < 1 or LDVT < NMAX, where NMAX is max( NN(j) ).
-21: LWORK too small.
If CLATMS, or CGESVD returns an error code, the
absolute value of it is returned.
=====================================================================
Parameter adjustments */
--mm;
--nn;
--dotype;
--iseed;
asav_dim1 = *lda;
asav_offset = 1 + asav_dim1 * 1;
asav -= asav_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
usav_dim1 = *ldu;
usav_offset = 1 + usav_dim1 * 1;
usav -= usav_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
vtsav_dim1 = *ldvt;
vtsav_offset = 1 + vtsav_dim1 * 1;
vtsav -= vtsav_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1 * 1;
vt -= vt_offset;
--s;
--ssav;
--e;
--work;
--rwork;
--iwork;
/* Function Body
Check for errors */
*info = 0;
/* Important constants */
nerrs = 0;
ntestt = 0;
ntestf = 0;
badmm = FALSE_;
badnn = FALSE_;
mmax = 1;
nmax = 1;
mnmax = 1;
minwrk = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = mmax, i__3 = mm[j];
mmax = max(i__2,i__3);
if (mm[j] < 0) {
badmm = TRUE_;
}
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* Computing MAX
Computing MIN */
i__4 = mm[j], i__5 = nn[j];
i__2 = mnmax, i__3 = min(i__4,i__5);
mnmax = max(i__2,i__3);
/* Computing MAX
Computing MAX
Computing MIN */
i__6 = mm[j], i__7 = nn[j];
/* Computing MAX */
i__9 = mm[j], i__10 = nn[j];
/* Computing 2nd power */
i__8 = max(i__9,i__10);
/* Computing MIN */
i__11 = mm[j], i__12 = nn[j];
/* Computing MAX */
i__13 = mm[j], i__14 = nn[j];
i__4 = min(i__6,i__7) * 3 + i__8 * i__8, i__5 = min(i__11,i__12) * 5,
i__4 = max(i__4,i__5), i__5 = max(i__13,i__14) * 3;
i__2 = minwrk, i__3 = max(i__4,i__5);
minwrk = max(i__2,i__3);
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badmm) {
*info = -2;
} else if (badnn) {
*info = -3;
} else if (*ntypes < 0) {
*info = -4;
} else if (*lda < max(1,mmax)) {
*info = -10;
} else if (*ldu < max(1,mmax)) {
*info = -12;
} else if (*ldvt < max(1,nmax)) {
*info = -14;
} else if (minwrk > *lwork) {
*info = -21;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CDRVBD", &i__1);
return 0;
}
/* Quick return if nothing to do */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
/* More Important constants */
unfl = slamch_("S");
ovfl = 1.f / unfl;
ulp = slamch_("E");
ulpinv = 1.f / ulp;
/* Loop over sizes, types */
nerrs = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
m = mm[jsize];
n = nn[jsize];
mnmin = min(m,n);
if (*nsizes != 1) {
mtypes = min(5,*ntypes);
} else {
mtypes = min(6,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L170;
}
ntest = 0;
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Compute "A" */
if (mtypes > 5) {
goto L50;
}
if (jtype == 1) {
/* Zero matrix */
claset_("Full", &m, &n, &c_b1, &c_b1, &a[a_offset], lda);
i__3 = min(m,n);
for (i__ = 1; i__ <= i__3; ++i__) {
s[i__] = 0.f;
/* L30: */
}
} else if (jtype == 2) {
/* Identity matrix */
claset_("Full", &m, &n, &c_b1, &c_b2, &a[a_offset], lda);
i__3 = min(m,n);
for (i__ = 1; i__ <= i__3; ++i__) {
s[i__] = 1.f;
/* L40: */
}
} else {
/* (Scaled) random matrix */
if (jtype == 3) {
anorm = 1.f;
}
if (jtype == 4) {
anorm = unfl / ulp;
}
if (jtype == 5) {
anorm = ovfl * ulp;
}
r__1 = (real) mnmin;
i__3 = m - 1;
i__4 = n - 1;
clatms_(&m, &n, "U", &iseed[1], "N", &s[1], &c__4, &r__1, &
anorm, &i__3, &i__4, "N", &a[a_offset], lda, &work[1],
&iinfo);
if (iinfo != 0) {
io___27.ciunit = *nounit;
s_wsfe(&io___27);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
return 0;
}
}
L50:
clacpy_("F", &m, &n, &a[a_offset], lda, &asav[asav_offset], lda);
/* Do for minimal and adequate (for blocking) workspace */
for (iwspc = 1; iwspc <= 4; ++iwspc) {
/* Test for CGESVD */
iwtmp = (min(m,n) << 1) + max(m,n);
lswork = iwtmp + (iwspc - 1) * (*lwork - iwtmp) / 3;
lswork = min(lswork,*lwork);
lswork = max(lswork,1);
if (iwspc == 4) {
lswork = *lwork;
}
for (j = 1; j <= 14; ++j) {
result[j - 1] = -1.f;
/* L60: */
}
/* Factorize A */
if (iwspc > 1) {
clacpy_("F", &m, &n, &asav[asav_offset], lda, &a[a_offset]
, lda);
}
cgesvd_("A", "A", &m, &n, &a[a_offset], lda, &ssav[1], &usav[
usav_offset], ldu, &vtsav[vtsav_offset], ldvt, &work[
1], &lswork, &rwork[1], &iinfo);
if (iinfo != 0) {
io___32.ciunit = *nounit;
s_wsfe(&io___32);
do_fio(&c__1, "GESVD", (ftnlen)5);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&lswork, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
return 0;
}
/* Do tests 1--4 */
cbdt01_(&m, &n, &c__0, &asav[asav_offset], lda, &usav[
usav_offset], ldu, &ssav[1], &e[1], &vtsav[
vtsav_offset], ldvt, &work[1], &rwork[1], result);
if (m != 0 && n != 0) {
cunt01_("Columns", &mnmin, &m, &usav[usav_offset], ldu, &
work[1], lwork, &rwork[1], &result[1]);
cunt01_("Rows", &mnmin, &n, &vtsav[vtsav_offset], ldvt, &
work[1], lwork, &rwork[1], &result[2]);
}
result[3] = 0.f;
i__3 = mnmin - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
if (ssav[i__] < ssav[i__ + 1]) {
result[3] = ulpinv;
}
if (ssav[i__] < 0.f) {
result[3] = ulpinv;
}
/* L70: */
}
if (mnmin >= 1) {
if (ssav[mnmin] < 0.f) {
result[3] = ulpinv;
}
}
/* Do partial SVDs, comparing to SSAV, USAV, and VTSAV */
result[4] = 0.f;
result[5] = 0.f;
result[6] = 0.f;
for (iju = 0; iju <= 3; ++iju) {
for (ijvt = 0; ijvt <= 3; ++ijvt) {
if (iju == 3 && ijvt == 3 || iju == 1 && ijvt == 1) {
goto L90;
}
*(unsigned char *)jobu = *(unsigned char *)&cjob[iju];
*(unsigned char *)jobvt = *(unsigned char *)&cjob[
ijvt];
clacpy_("F", &m, &n, &asav[asav_offset], lda, &a[
a_offset], lda);
cgesvd_(jobu, jobvt, &m, &n, &a[a_offset], lda, &s[1],
&u[u_offset], ldu, &vt[vt_offset], ldvt, &
work[1], &lswork, &rwork[1], &iinfo);
/* Compare U */
dif = 0.f;
if (m > 0 && n > 0) {
if (iju == 1) {
cunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
usav_offset], ldu, &a[a_offset], lda,
&work[1], lwork, &rwork[1], &dif, &
iinfo);
} else if (iju == 2) {
cunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
usav_offset], ldu, &u[u_offset], ldu,
&work[1], lwork, &rwork[1], &dif, &
iinfo);
} else if (iju == 3) {
cunt03_("C", &m, &m, &m, &mnmin, &usav[
usav_offset], ldu, &u[u_offset], ldu,
&work[1], lwork, &rwork[1], &dif, &
iinfo);
}
}
result[4] = dmax(result[4],dif);
/* Compare VT */
dif = 0.f;
if (m > 0 && n > 0) {
if (ijvt == 1) {
cunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
vtsav_offset], ldvt, &a[a_offset],
lda, &work[1], lwork, &rwork[1], &dif,
&iinfo);
} else if (ijvt == 2) {
cunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
vtsav_offset], ldvt, &vt[vt_offset],
ldvt, &work[1], lwork, &rwork[1], &
dif, &iinfo);
} else if (ijvt == 3) {
cunt03_("R", &n, &n, &n, &mnmin, &vtsav[
vtsav_offset], ldvt, &vt[vt_offset],
ldvt, &work[1], lwork, &rwork[1], &
dif, &iinfo);
}
}
result[5] = dmax(result[5],dif);
/* Compare S */
dif = 0.f;
/* Computing MAX */
r__1 = (real) mnmin * ulp * s[1], r__2 = slamch_(
"Safe minimum");
div = dmax(r__1,r__2);
i__3 = mnmin - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
if (ssav[i__] < ssav[i__ + 1]) {
dif = ulpinv;
}
if (ssav[i__] < 0.f) {
dif = ulpinv;
}
/* Computing MAX */
r__2 = dif, r__3 = (r__1 = ssav[i__] - s[i__],
dabs(r__1)) / div;
dif = dmax(r__2,r__3);
/* L80: */
}
result[6] = dmax(result[6],dif);
L90:
;
}
/* L100: */
}
/* Test for CGESDD */
iwtmp = (mnmin << 1) * mnmin + (mnmin << 1) + max(m,n);
lswork = iwtmp + (iwspc - 1) * (*lwork - iwtmp) / 3;
lswork = min(lswork,*lwork);
lswork = max(lswork,1);
if (iwspc == 4) {
lswork = *lwork;
}
/* Factorize A */
clacpy_("F", &m, &n, &asav[asav_offset], lda, &a[a_offset],
lda);
cgesdd_("A", &m, &n, &a[a_offset], lda, &ssav[1], &usav[
usav_offset], ldu, &vtsav[vtsav_offset], ldvt, &work[
1], &lswork, &rwork[1], &iwork[1], &iinfo);
if (iinfo != 0) {
io___39.ciunit = *nounit;
s_wsfe(&io___39);
do_fio(&c__1, "GESDD", (ftnlen)5);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&lswork, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
return 0;
}
/* Do tests 1--4 */
cbdt01_(&m, &n, &c__0, &asav[asav_offset], lda, &usav[
usav_offset], ldu, &ssav[1], &e[1], &vtsav[
vtsav_offset], ldvt, &work[1], &rwork[1], &result[7]);
if (m != 0 && n != 0) {
cunt01_("Columns", &mnmin, &m, &usav[usav_offset], ldu, &
work[1], lwork, &rwork[1], &result[8]);
cunt01_("Rows", &mnmin, &n, &vtsav[vtsav_offset], ldvt, &
work[1], lwork, &rwork[1], &result[9]);
}
result[10] = 0.f;
i__3 = mnmin - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
if (ssav[i__] < ssav[i__ + 1]) {
result[10] = ulpinv;
}
if (ssav[i__] < 0.f) {
result[10] = ulpinv;
}
/* L110: */
}
if (mnmin >= 1) {
if (ssav[mnmin] < 0.f) {
result[10] = ulpinv;
}
}
/* Do partial SVDs, comparing to SSAV, USAV, and VTSAV */
result[11] = 0.f;
result[12] = 0.f;
result[13] = 0.f;
for (ijq = 0; ijq <= 2; ++ijq) {
*(unsigned char *)jobq = *(unsigned char *)&cjob[ijq];
clacpy_("F", &m, &n, &asav[asav_offset], lda, &a[a_offset]
, lda);
cgesdd_(jobq, &m, &n, &a[a_offset], lda, &s[1], &u[
u_offset], ldu, &vt[vt_offset], ldvt, &work[1], &
lswork, &rwork[1], &iwork[1], &iinfo);
/* Compare U */
dif = 0.f;
if (m > 0 && n > 0) {
if (ijq == 1) {
if (m >= n) {
cunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
usav_offset], ldu, &a[a_offset], lda,
&work[1], lwork, &rwork[1], &dif, &
iinfo);
} else {
cunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
usav_offset], ldu, &u[u_offset], ldu,
&work[1], lwork, &rwork[1], &dif, &
iinfo);
}
} else if (ijq == 2) {
cunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
usav_offset], ldu, &u[u_offset], ldu, &
work[1], lwork, &rwork[1], &dif, &iinfo);
}
}
result[11] = dmax(result[11],dif);
/* Compare VT */
dif = 0.f;
if (m > 0 && n > 0) {
if (ijq == 1) {
if (m >= n) {
cunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
vtsav_offset], ldvt, &vt[vt_offset],
ldvt, &work[1], lwork, &rwork[1], &
dif, &iinfo);
} else {
cunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
vtsav_offset], ldvt, &a[a_offset],
lda, &work[1], lwork, &rwork[1], &dif,
&iinfo);
}
} else if (ijq == 2) {
cunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
vtsav_offset], ldvt, &vt[vt_offset], ldvt,
&work[1], lwork, &rwork[1], &dif, &iinfo);
}
}
result[12] = dmax(result[12],dif);
/* Compare S */
dif = 0.f;
/* Computing MAX */
r__1 = (real) mnmin * ulp * s[1], r__2 = slamch_("Safe m"
"inimum");
div = dmax(r__1,r__2);
i__3 = mnmin - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
if (ssav[i__] < ssav[i__ + 1]) {
dif = ulpinv;
}
if (ssav[i__] < 0.f) {
dif = ulpinv;
}
/* Computing MAX */
r__2 = dif, r__3 = (r__1 = ssav[i__] - s[i__], dabs(
r__1)) / div;
dif = dmax(r__2,r__3);
/* L120: */
}
result[13] = dmax(result[13],dif);
/* L130: */
}
/* End of Loop -- Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 14; ++j) {
if (result[j - 1] >= 0.f) {
++ntest;
}
if (result[j - 1] >= *thresh) {
++nfail;
}
/* L140: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___43.ciunit = *nounit;
s_wsfe(&io___43);
e_wsfe();
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 14; ++j) {
if (result[j - 1] >= *thresh) {
io___45.ciunit = *nounit;
s_wsfe(&io___45);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&iwspc, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
real));
e_wsfe();
}
/* L150: */
}
nerrs += nfail;
ntestt += ntest;
/* L160: */
}
L170:
;
}
/* L180: */
}
/* Summary */
alasvm_("CBD", nounit, &nerrs, &ntestt, &c__0);
return 0;
/* End of CDRVBD */
} /* cdrvbd_ */
/* Subroutine */ int ctgsja_(char *jobu, char *jobv, char *jobq, integer *m,
integer *p, integer *n, integer *k, integer *l, complex *a, integer *
lda, complex *b, integer *ldb, real *tola, real *tolb, real *alpha,
real *beta, complex *u, integer *ldu, complex *v, integer *ldv,
complex *q, integer *ldq, complex *work, integer *ncycle, integer *
info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1,
u_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4;
real r__1;
complex q__1;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j;
real a1, b1, a3, b3;
complex a2, b2;
real csq, csu, csv;
complex snq;
real rwk;
complex snu, snv;
extern /* Subroutine */ int crot_(integer *, complex *, integer *,
complex *, integer *, real *, complex *);
real gamma;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
logical initq, initu, initv, wantq, upper;
real error, ssmin;
logical wantu, wantv;
extern /* Subroutine */ int clags2_(logical *, real *, complex *, real *,
real *, complex *, real *, real *, complex *, real *, complex *,
real *, complex *), clapll_(integer *, complex *, integer *,
complex *, integer *, real *), csscal_(integer *, real *, complex
*, integer *);
integer kcycle;
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *), xerbla_(char *,
integer *), slartg_(real *, real *, real *, real *, real *
);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTGSJA computes the generalized singular value decomposition (GSVD) */
/* of two complex upper triangular (or trapezoidal) matrices A and B. */
/* On entry, it is assumed that matrices A and B have the following */
/* forms, which may be obtained by the preprocessing subroutine CGGSVP */
/* from a general M-by-N matrix A and P-by-N matrix B: */
/* N-K-L K L */
/* A = K ( 0 A12 A13 ) if M-K-L >= 0; */
/* L ( 0 0 A23 ) */
/* M-K-L ( 0 0 0 ) */
/* N-K-L K L */
/* A = K ( 0 A12 A13 ) if M-K-L < 0; */
/* M-K ( 0 0 A23 ) */
/* N-K-L K L */
/* B = L ( 0 0 B13 ) */
/* P-L ( 0 0 0 ) */
/* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */
/* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */
/* otherwise A23 is (M-K)-by-L upper trapezoidal. */
/* On exit, */
/* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ), */
/* where U, V and Q are unitary matrices, Z' denotes the conjugate */
/* transpose of Z, R is a nonsingular upper triangular matrix, and D1 */
/* and D2 are ``diagonal'' matrices, which are of the following */
/* structures: */
/* If M-K-L >= 0, */
/* K L */
/* D1 = K ( I 0 ) */
/* L ( 0 C ) */
/* M-K-L ( 0 0 ) */
/* K L */
/* D2 = L ( 0 S ) */
/* P-L ( 0 0 ) */
/* N-K-L K L */
/* ( 0 R ) = K ( 0 R11 R12 ) K */
/* L ( 0 0 R22 ) L */
/* where */
/* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */
/* S = diag( BETA(K+1), ... , BETA(K+L) ), */
/* C**2 + S**2 = I. */
/* R is stored in A(1:K+L,N-K-L+1:N) on exit. */
/* If M-K-L < 0, */
/* K M-K K+L-M */
/* D1 = K ( I 0 0 ) */
/* M-K ( 0 C 0 ) */
/* K M-K K+L-M */
/* D2 = M-K ( 0 S 0 ) */
/* K+L-M ( 0 0 I ) */
/* P-L ( 0 0 0 ) */
/* N-K-L K M-K K+L-M */
/* ( 0 R ) = K ( 0 R11 R12 R13 ) */
/* M-K ( 0 0 R22 R23 ) */
/* K+L-M ( 0 0 0 R33 ) */
/* where */
/* C = diag( ALPHA(K+1), ... , ALPHA(M) ), */
/* S = diag( BETA(K+1), ... , BETA(M) ), */
/* C**2 + S**2 = I. */
/* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored */
/* ( 0 R22 R23 ) */
/* in B(M-K+1:L,N+M-K-L+1:N) on exit. */
/* The computation of the unitary transformation matrices U, V or Q */
/* is optional. These matrices may either be formed explicitly, or they */
/* may be postmultiplied into input matrices U1, V1, or Q1. */
/* Arguments */
/* ========= */
/* JOBU (input) CHARACTER*1 */
/* = 'U': U must contain a unitary matrix U1 on entry, and */
/* the product U1*U is returned; */
/* = 'I': U is initialized to the unit matrix, and the */
/* unitary matrix U is returned; */
/* = 'N': U is not computed. */
/* JOBV (input) CHARACTER*1 */
/* = 'V': V must contain a unitary matrix V1 on entry, and */
/* the product V1*V is returned; */
/* = 'I': V is initialized to the unit matrix, and the */
/* unitary matrix V is returned; */
/* = 'N': V is not computed. */
/* JOBQ (input) CHARACTER*1 */
/* = 'Q': Q must contain a unitary matrix Q1 on entry, and */
/* the product Q1*Q is returned; */
/* = 'I': Q is initialized to the unit matrix, and the */
/* unitary matrix Q is returned; */
/* = 'N': Q is not computed. */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* P (input) INTEGER */
/* The number of rows of the matrix B. P >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrices A and B. N >= 0. */
/* K (input) INTEGER */
/* L (input) INTEGER */
/* K and L specify the subblocks in the input matrices A and B: */
/* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,,N-L+1:N) */
/* of A and B, whose GSVD is going to be computed by CTGSJA. */
/* See Further details. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular */
/* matrix R or part of R. See Purpose for details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* B (input/output) COMPLEX array, dimension (LDB,N) */
/* On entry, the P-by-N matrix B. */
/* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains */
/* a part of R. See Purpose for details. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,P). */
/* TOLA (input) REAL */
/* TOLB (input) REAL */
/* TOLA and TOLB are the convergence criteria for the Jacobi- */
/* Kogbetliantz iteration procedure. Generally, they are the */
/* same as used in the preprocessing step, say */
/* TOLA = MAX(M,N)*norm(A)*MACHEPS, */
/* TOLB = MAX(P,N)*norm(B)*MACHEPS. */
/* ALPHA (output) REAL array, dimension (N) */
/* BETA (output) REAL array, dimension (N) */
/* On exit, ALPHA and BETA contain the generalized singular */
/* value pairs of A and B; */
/* ALPHA(1:K) = 1, */
/* BETA(1:K) = 0, */
/* and if M-K-L >= 0, */
/* ALPHA(K+1:K+L) = diag(C), */
/* BETA(K+1:K+L) = diag(S), */
/* or if M-K-L < 0, */
/* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0 */
/* BETA(K+1:M) = S, BETA(M+1:K+L) = 1. */
/* Furthermore, if K+L < N, */
/* ALPHA(K+L+1:N) = 0 */
/* BETA(K+L+1:N) = 0. */
/* U (input/output) COMPLEX array, dimension (LDU,M) */
/* On entry, if JOBU = 'U', U must contain a matrix U1 (usually */
/* the unitary matrix returned by CGGSVP). */
/* On exit, */
/* if JOBU = 'I', U contains the unitary matrix U; */
/* if JOBU = 'U', U contains the product U1*U. */
/* If JOBU = 'N', U is not referenced. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= max(1,M) if */
/* JOBU = 'U'; LDU >= 1 otherwise. */
/* V (input/output) COMPLEX array, dimension (LDV,P) */
/* On entry, if JOBV = 'V', V must contain a matrix V1 (usually */
/* the unitary matrix returned by CGGSVP). */
/* On exit, */
/* if JOBV = 'I', V contains the unitary matrix V; */
/* if JOBV = 'V', V contains the product V1*V. */
/* If JOBV = 'N', V is not referenced. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. LDV >= max(1,P) if */
/* JOBV = 'V'; LDV >= 1 otherwise. */
/* Q (input/output) COMPLEX array, dimension (LDQ,N) */
/* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually */
/* the unitary matrix returned by CGGSVP). */
/* On exit, */
/* if JOBQ = 'I', Q contains the unitary matrix Q; */
/* if JOBQ = 'Q', Q contains the product Q1*Q. */
/* If JOBQ = 'N', Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= max(1,N) if */
/* JOBQ = 'Q'; LDQ >= 1 otherwise. */
/* WORK (workspace) COMPLEX array, dimension (2*N) */
/* NCYCLE (output) INTEGER */
/* The number of cycles required for convergence. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* = 1: the procedure does not converge after MAXIT cycles. */
/* Internal Parameters */
/* =================== */
/* MAXIT INTEGER */
/* MAXIT specifies the total loops that the iterative procedure */
/* may take. If after MAXIT cycles, the routine fails to */
/* converge, we return INFO = 1. */
/* Further Details */
/* =============== */
/* CTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce */
/* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L */
/* matrix B13 to the form: */
/* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1, */
/* where U1, V1 and Q1 are unitary matrix, and Z' is the conjugate */
/* transpose of Z. C1 and S1 are diagonal matrices satisfying */
/* C1**2 + S1**2 = I, */
/* and R1 is an L-by-L nonsingular upper triangular matrix. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--alpha;
--beta;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--work;
/* Function Body */
initu = lsame_(jobu, "I");
wantu = initu || lsame_(jobu, "U");
initv = lsame_(jobv, "I");
wantv = initv || lsame_(jobv, "V");
initq = lsame_(jobq, "I");
wantq = initq || lsame_(jobq, "Q");
*info = 0;
if (! (initu || wantu || lsame_(jobu, "N"))) {
*info = -1;
} else if (! (initv || wantv || lsame_(jobv, "N")))
{
*info = -2;
} else if (! (initq || wantq || lsame_(jobq, "N")))
{
*info = -3;
} else if (*m < 0) {
*info = -4;
} else if (*p < 0) {
*info = -5;
} else if (*n < 0) {
*info = -6;
} else if (*lda < max(1,*m)) {
*info = -10;
} else if (*ldb < max(1,*p)) {
*info = -12;
} else if (*ldu < 1 || wantu && *ldu < *m) {
*info = -18;
} else if (*ldv < 1 || wantv && *ldv < *p) {
*info = -20;
} else if (*ldq < 1 || wantq && *ldq < *n) {
*info = -22;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTGSJA", &i__1);
return 0;
}
/* Initialize U, V and Q, if necessary */
if (initu) {
claset_("Full", m, m, &c_b1, &c_b2, &u[u_offset], ldu);
}
if (initv) {
claset_("Full", p, p, &c_b1, &c_b2, &v[v_offset], ldv);
}
if (initq) {
claset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
}
/* Loop until convergence */
upper = FALSE_;
for (kcycle = 1; kcycle <= 40; ++kcycle) {
upper = ! upper;
i__1 = *l - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *l;
for (j = i__ + 1; j <= i__2; ++j) {
a1 = 0.f;
a2.r = 0.f, a2.i = 0.f;
a3 = 0.f;
if (*k + i__ <= *m) {
i__3 = *k + i__ + (*n - *l + i__) * a_dim1;
a1 = a[i__3].r;
}
if (*k + j <= *m) {
i__3 = *k + j + (*n - *l + j) * a_dim1;
a3 = a[i__3].r;
}
i__3 = i__ + (*n - *l + i__) * b_dim1;
b1 = b[i__3].r;
i__3 = j + (*n - *l + j) * b_dim1;
b3 = b[i__3].r;
if (upper) {
if (*k + i__ <= *m) {
i__3 = *k + i__ + (*n - *l + j) * a_dim1;
a2.r = a[i__3].r, a2.i = a[i__3].i;
}
i__3 = i__ + (*n - *l + j) * b_dim1;
b2.r = b[i__3].r, b2.i = b[i__3].i;
} else {
if (*k + j <= *m) {
i__3 = *k + j + (*n - *l + i__) * a_dim1;
a2.r = a[i__3].r, a2.i = a[i__3].i;
}
i__3 = j + (*n - *l + i__) * b_dim1;
b2.r = b[i__3].r, b2.i = b[i__3].i;
}
clags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &
csv, &snv, &csq, &snq);
/* Update (K+I)-th and (K+J)-th rows of matrix A: U'*A */
if (*k + j <= *m) {
r_cnjg(&q__1, &snu);
crot_(l, &a[*k + j + (*n - *l + 1) * a_dim1], lda, &a[*k
+ i__ + (*n - *l + 1) * a_dim1], lda, &csu, &q__1)
;
}
/* Update I-th and J-th rows of matrix B: V'*B */
r_cnjg(&q__1, &snv);
crot_(l, &b[j + (*n - *l + 1) * b_dim1], ldb, &b[i__ + (*n - *
l + 1) * b_dim1], ldb, &csv, &q__1);
/* Update (N-L+I)-th and (N-L+J)-th columns of matrices */
/* A and B: A*Q and B*Q */
/* Computing MIN */
i__4 = *k + *l;
i__3 = min(i__4,*m);
crot_(&i__3, &a[(*n - *l + j) * a_dim1 + 1], &c__1, &a[(*n - *
l + i__) * a_dim1 + 1], &c__1, &csq, &snq);
crot_(l, &b[(*n - *l + j) * b_dim1 + 1], &c__1, &b[(*n - *l +
i__) * b_dim1 + 1], &c__1, &csq, &snq);
if (upper) {
if (*k + i__ <= *m) {
i__3 = *k + i__ + (*n - *l + j) * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
}
i__3 = i__ + (*n - *l + j) * b_dim1;
b[i__3].r = 0.f, b[i__3].i = 0.f;
} else {
if (*k + j <= *m) {
i__3 = *k + j + (*n - *l + i__) * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
}
i__3 = j + (*n - *l + i__) * b_dim1;
b[i__3].r = 0.f, b[i__3].i = 0.f;
}
/* Ensure that the diagonal elements of A and B are real. */
if (*k + i__ <= *m) {
i__3 = *k + i__ + (*n - *l + i__) * a_dim1;
i__4 = *k + i__ + (*n - *l + i__) * a_dim1;
r__1 = a[i__4].r;
a[i__3].r = r__1, a[i__3].i = 0.f;
}
if (*k + j <= *m) {
i__3 = *k + j + (*n - *l + j) * a_dim1;
i__4 = *k + j + (*n - *l + j) * a_dim1;
r__1 = a[i__4].r;
a[i__3].r = r__1, a[i__3].i = 0.f;
}
i__3 = i__ + (*n - *l + i__) * b_dim1;
i__4 = i__ + (*n - *l + i__) * b_dim1;
r__1 = b[i__4].r;
b[i__3].r = r__1, b[i__3].i = 0.f;
i__3 = j + (*n - *l + j) * b_dim1;
i__4 = j + (*n - *l + j) * b_dim1;
r__1 = b[i__4].r;
b[i__3].r = r__1, b[i__3].i = 0.f;
/* Update unitary matrices U, V, Q, if desired. */
if (wantu && *k + j <= *m) {
crot_(m, &u[(*k + j) * u_dim1 + 1], &c__1, &u[(*k + i__) *
u_dim1 + 1], &c__1, &csu, &snu);
}
if (wantv) {
crot_(p, &v[j * v_dim1 + 1], &c__1, &v[i__ * v_dim1 + 1],
&c__1, &csv, &snv);
}
if (wantq) {
crot_(n, &q[(*n - *l + j) * q_dim1 + 1], &c__1, &q[(*n - *
l + i__) * q_dim1 + 1], &c__1, &csq, &snq);
}
/* L10: */
}
/* L20: */
}
if (! upper) {
/* The matrices A13 and B13 were lower triangular at the start */
/* of the cycle, and are now upper triangular. */
/* Convergence test: test the parallelism of the corresponding */
/* rows of A and B. */
error = 0.f;
/* Computing MIN */
i__2 = *l, i__3 = *m - *k;
i__1 = min(i__2,i__3);
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *l - i__ + 1;
ccopy_(&i__2, &a[*k + i__ + (*n - *l + i__) * a_dim1], lda, &
work[1], &c__1);
i__2 = *l - i__ + 1;
ccopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &work[*
l + 1], &c__1);
i__2 = *l - i__ + 1;
clapll_(&i__2, &work[1], &c__1, &work[*l + 1], &c__1, &ssmin);
error = dmax(error,ssmin);
/* L30: */
}
if (dabs(error) <= dmin(*tola,*tolb)) {
goto L50;
}
}
/* End of cycle loop */
/* L40: */
}
/* The algorithm has not converged after MAXIT cycles. */
*info = 1;
goto L100;
L50:
/* If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged. */
/* Compute the generalized singular value pairs (ALPHA, BETA), and */
/* set the triangular matrix R to array A. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
alpha[i__] = 1.f;
beta[i__] = 0.f;
/* L60: */
}
/* Computing MIN */
i__2 = *l, i__3 = *m - *k;
i__1 = min(i__2,i__3);
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *k + i__ + (*n - *l + i__) * a_dim1;
a1 = a[i__2].r;
i__2 = i__ + (*n - *l + i__) * b_dim1;
b1 = b[i__2].r;
if (a1 != 0.f) {
gamma = b1 / a1;
if (gamma < 0.f) {
i__2 = *l - i__ + 1;
csscal_(&i__2, &c_b39, &b[i__ + (*n - *l + i__) * b_dim1],
ldb);
if (wantv) {
csscal_(p, &c_b39, &v[i__ * v_dim1 + 1], &c__1);
}
}
r__1 = dabs(gamma);
slartg_(&r__1, &c_b42, &beta[*k + i__], &alpha[*k + i__], &rwk);
if (alpha[*k + i__] >= beta[*k + i__]) {
i__2 = *l - i__ + 1;
r__1 = 1.f / alpha[*k + i__];
csscal_(&i__2, &r__1, &a[*k + i__ + (*n - *l + i__) * a_dim1],
lda);
} else {
i__2 = *l - i__ + 1;
r__1 = 1.f / beta[*k + i__];
csscal_(&i__2, &r__1, &b[i__ + (*n - *l + i__) * b_dim1], ldb)
;
i__2 = *l - i__ + 1;
ccopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k
+ i__ + (*n - *l + i__) * a_dim1], lda);
}
} else {
alpha[*k + i__] = 0.f;
beta[*k + i__] = 1.f;
i__2 = *l - i__ + 1;
ccopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k +
i__ + (*n - *l + i__) * a_dim1], lda);
}
/* L70: */
}
/* Post-assignment */
i__1 = *k + *l;
for (i__ = *m + 1; i__ <= i__1; ++i__) {
alpha[i__] = 0.f;
beta[i__] = 1.f;
/* L80: */
}
if (*k + *l < *n) {
i__1 = *n;
for (i__ = *k + *l + 1; i__ <= i__1; ++i__) {
alpha[i__] = 0.f;
beta[i__] = 0.f;
/* L90: */
}
}
L100:
*ncycle = kcycle;
return 0;
/* End of CTGSJA */
} /* ctgsja_ */
/* Subroutine */ int cdrvgb_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, complex *a, integer *la,
complex *afb, integer *lafb, complex *asav, complex *b, complex *
bsav, complex *x, complex *xact, real *s, complex *work, real *rwork,
integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char transs[1*3] = "N" "T" "C";
static char facts[1*3] = "F" "N" "E";
static char equeds[1*4] = "N" "R" "C" "B";
/* Format strings */
static char fmt_9999[] = "(\002 *** In CDRVGB, LA=\002,i5,\002 is too sm"
"all for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> In"
"crease LA to at least \002,i5)";
static char fmt_9998[] = "(\002 *** In CDRVGB, LAFB=\002,i5,\002 is too "
"small for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> "
"Increase LAFB to at least \002,i5)";
static char fmt_9997[] = "(1x,a,\002, N=\002,i5,\002, KL=\002,i5,\002, K"
"U=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)"
;
static char fmt_9995[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002"
",i5,\002,\002,i5,\002,\002,i5,\002,...), EQUED='\002,a1,\002', t"
"ype \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002"
",i5,\002,\002,i5,\002,\002,i5,\002,...), type \002,i1,\002, test("
"\002,i1,\002)=\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10,
i__11[2];
real r__1, r__2;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
double c_abs(complex *);
/* Local variables */
integer i__, j, k, n, i1, i2, k1, nb, in, kl, ku, nt, lda, ldb, ikl, nkl,
iku, nku;
char fact[1];
integer ioff, mode;
real amax;
char path[3];
integer imat, info;
char dist[1];
real rdum[1];
char type__[1];
integer nrun, ldafb;
extern /* Subroutine */ int cgbt01_(integer *, integer *, integer *,
integer *, complex *, integer *, complex *, integer *, integer *,
complex *, real *), cgbt02_(char *, integer *, integer *, integer
*, integer *, integer *, complex *, integer *, complex *, integer
*, complex *, integer *, real *), cgbt05_(char *, integer
*, integer *, integer *, integer *, complex *, integer *, complex
*, integer *, complex *, integer *, complex *, integer *, real *,
real *, real *);
integer ifact;
extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
integer *, complex *, integer *, real *, real *);
integer nfail, iseed[4], nfact;
extern logical lsame_(char *, char *);
char equed[1];
integer nbmin;
real rcond, roldc;
extern /* Subroutine */ int cgbsv_(integer *, integer *, integer *,
integer *, complex *, integer *, integer *, complex *, integer *,
integer *);
integer nimat;
real roldi;
extern doublereal sget06_(real *, real *);
real anorm;
integer itran;
logical equil;
real roldo;
char trans[1];
integer izero, nerrs;
logical zerot;
char xtype[1];
extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, real *, integer *, real *, char *
), aladhd_(integer *, char *);
extern doublereal clangb_(char *, integer *, integer *, integer *,
complex *, integer *, real *), clange_(char *, integer *,
integer *, complex *, integer *, real *);
extern /* Subroutine */ int claqgb_(integer *, integer *, integer *,
integer *, complex *, integer *, real *, real *, real *, real *,
real *, char *), alaerh_(char *, char *, integer *,
integer *, char *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *);
logical prefac;
real colcnd;
extern doublereal clantb_(char *, char *, char *, integer *, integer *,
complex *, integer *, real *);
extern /* Subroutine */ int cgbequ_(integer *, integer *, integer *,
integer *, complex *, integer *, real *, real *, real *, real *,
real *, integer *);
real rcondc;
extern doublereal slamch_(char *);
logical nofact;
extern /* Subroutine */ int cgbtrf_(integer *, integer *, integer *,
integer *, complex *, integer *, integer *, integer *);
integer iequed;
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *);
real rcondi;
extern /* Subroutine */ int clarhs_(char *, char *, char *, char *,
integer *, integer *, integer *, integer *, integer *, complex *,
integer *, complex *, integer *, complex *, integer *, integer *,
integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *), alasvm_(char *, integer *, integer *, integer *, integer
*);
real cndnum, anormi, rcondo, ainvnm;
extern /* Subroutine */ int cgbtrs_(char *, integer *, integer *, integer
*, integer *, complex *, integer *, integer *, complex *, integer
*, integer *), clatms_(integer *, integer *, char *,
integer *, char *, real *, integer *, real *, real *, integer *,
integer *, char *, complex *, integer *, complex *, integer *);
logical trfcon;
real anormo, rowcnd;
extern /* Subroutine */ int cgbsvx_(char *, char *, integer *, integer *,
integer *, integer *, complex *, integer *, complex *, integer *,
integer *, char *, real *, real *, complex *, integer *, complex *
, integer *, real *, real *, real *, complex *, real *, integer *), xlaenv_(integer *, integer *);
real anrmpv;
extern /* Subroutine */ int cerrvx_(char *, integer *);
real result[7], rpvgrw;
/* Fortran I/O blocks */
static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___65 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___73 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___74 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___75 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___76 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___77 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___78 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___79 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___80 = { 0, 0, 0, fmt_9996, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CDRVGB tests the driver routines CGBSV and -SVX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) COMPLEX array, dimension (LA) */
/* LA (input) INTEGER */
/* The length of the array A. LA >= (2*NMAX-1)*NMAX */
/* where NMAX is the largest entry in NVAL. */
/* AFB (workspace) COMPLEX array, dimension (LAFB) */
/* LAFB (input) INTEGER */
/* The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX */
/* where NMAX is the largest entry in NVAL. */
/* ASAV (workspace) COMPLEX array, dimension (LA) */
/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* BSAV (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* S (workspace) REAL array, dimension (2*NMAX) */
/* WORK (workspace) COMPLEX array, dimension */
/* (NMAX*max(3,NRHS,NMAX)) */
/* RWORK (workspace) REAL array, dimension */
/* (max(NMAX,2*NRHS)) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--s;
--xact;
--x;
--bsav;
--b;
--asav;
--afb;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "GB", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
cerrvx_(path, nout);
}
infoc_1.infot = 0;
/* Set the block size and minimum block size for testing. */
nb = 1;
nbmin = 2;
xlaenv_(&c__1, &nb);
xlaenv_(&c__2, &nbmin);
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
ldb = max(n,1);
*(unsigned char *)xtype = 'N';
/* Set limits on the number of loop iterations. */
/* Computing MAX */
i__2 = 1, i__3 = min(n,4);
nkl = max(i__2,i__3);
if (n == 0) {
nkl = 1;
}
nku = nkl;
nimat = 8;
if (n <= 0) {
nimat = 1;
}
i__2 = nkl;
for (ikl = 1; ikl <= i__2; ++ikl) {
/* Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes */
/* it easier to skip redundant values for small values of N. */
if (ikl == 1) {
kl = 0;
} else if (ikl == 2) {
/* Computing MAX */
i__3 = n - 1;
kl = max(i__3,0);
} else if (ikl == 3) {
kl = (n * 3 - 1) / 4;
} else if (ikl == 4) {
kl = (n + 1) / 4;
}
i__3 = nku;
for (iku = 1; iku <= i__3; ++iku) {
/* Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order */
/* makes it easier to skip redundant values for small */
/* values of N. */
if (iku == 1) {
ku = 0;
} else if (iku == 2) {
/* Computing MAX */
i__4 = n - 1;
ku = max(i__4,0);
} else if (iku == 3) {
ku = (n * 3 - 1) / 4;
} else if (iku == 4) {
ku = (n + 1) / 4;
}
/* Check that A and AFB are big enough to generate this */
/* matrix. */
lda = kl + ku + 1;
ldafb = (kl << 1) + ku + 1;
if (lda * n > *la || ldafb * n > *lafb) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (lda * n > *la) {
io___26.ciunit = *nout;
s_wsfe(&io___26);
do_fio(&c__1, (char *)&(*la), (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
i__4 = n * (kl + ku + 1);
do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
e_wsfe();
++nerrs;
}
if (ldafb * n > *lafb) {
io___27.ciunit = *nout;
s_wsfe(&io___27);
do_fio(&c__1, (char *)&(*lafb), (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
i__4 = n * ((kl << 1) + ku + 1);
do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
e_wsfe();
++nerrs;
}
goto L130;
}
i__4 = nimat;
for (imat = 1; imat <= i__4; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L120;
}
/* Skip types 2, 3, or 4 if the matrix is too small. */
zerot = imat >= 2 && imat <= 4;
if (zerot && n < imat - 1) {
goto L120;
}
/* Set up parameters with CLATB4 and generate a */
/* test matrix with CLATMS. */
clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
mode, &cndnum, dist);
rcondc = 1.f / cndnum;
s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, "Z", &a[1], &lda, &work[
1], &info);
/* Check the error code from CLATMS. */
if (info != 0) {
alaerh_(path, "CLATMS", &info, &c__0, " ", &n, &n, &
kl, &ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L120;
}
/* For types 2, 3, and 4, zero one or more columns of */
/* the matrix to test that INFO is returned correctly. */
izero = 0;
if (zerot) {
if (imat == 2) {
izero = 1;
} else if (imat == 3) {
izero = n;
} else {
izero = n / 2 + 1;
}
ioff = (izero - 1) * lda;
if (imat < 4) {
/* Computing MAX */
i__5 = 1, i__6 = ku + 2 - izero;
i1 = max(i__5,i__6);
/* Computing MIN */
i__5 = kl + ku + 1, i__6 = ku + 1 + (n - izero);
i2 = min(i__5,i__6);
i__5 = i2;
for (i__ = i1; i__ <= i__5; ++i__) {
i__6 = ioff + i__;
a[i__6].r = 0.f, a[i__6].i = 0.f;
/* L20: */
}
} else {
i__5 = n;
for (j = izero; j <= i__5; ++j) {
/* Computing MAX */
i__6 = 1, i__7 = ku + 2 - j;
/* Computing MIN */
i__9 = kl + ku + 1, i__10 = ku + 1 + (n - j);
i__8 = min(i__9,i__10);
for (i__ = max(i__6,i__7); i__ <= i__8; ++i__)
{
i__6 = ioff + i__;
a[i__6].r = 0.f, a[i__6].i = 0.f;
/* L30: */
}
ioff += lda;
/* L40: */
}
}
}
/* Save a copy of the matrix A in ASAV. */
i__5 = kl + ku + 1;
clacpy_("Full", &i__5, &n, &a[1], &lda, &asav[1], &lda);
for (iequed = 1; iequed <= 4; ++iequed) {
*(unsigned char *)equed = *(unsigned char *)&equeds[
iequed - 1];
if (iequed == 1) {
nfact = 3;
} else {
nfact = 1;
}
i__5 = nfact;
for (ifact = 1; ifact <= i__5; ++ifact) {
*(unsigned char *)fact = *(unsigned char *)&facts[
ifact - 1];
prefac = lsame_(fact, "F");
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (zerot) {
if (prefac) {
goto L100;
}
rcondo = 0.f;
rcondi = 0.f;
} else if (! nofact) {
/* Compute the condition number for comparison */
/* with the value returned by SGESVX (FACT = */
/* 'N' reuses the condition number from the */
/* previous iteration with FACT = 'F'). */
i__8 = kl + ku + 1;
clacpy_("Full", &i__8, &n, &asav[1], &lda, &
afb[kl + 1], &ldafb);
if (equil || iequed > 1) {
/* Compute row and column scale factors to */
/* equilibrate the matrix A. */
cgbequ_(&n, &n, &kl, &ku, &afb[kl + 1], &
ldafb, &s[1], &s[n + 1], &rowcnd,
&colcnd, &amax, &info);
if (info == 0 && n > 0) {
if (lsame_(equed, "R")) {
rowcnd = 0.f;
colcnd = 1.f;
} else if (lsame_(equed, "C")) {
rowcnd = 1.f;
colcnd = 0.f;
} else if (lsame_(equed, "B")) {
rowcnd = 0.f;
colcnd = 0.f;
}
/* Equilibrate the matrix. */
claqgb_(&n, &n, &kl, &ku, &afb[kl + 1]
, &ldafb, &s[1], &s[n + 1], &
rowcnd, &colcnd, &amax, equed);
}
}
/* Save the condition number of the */
/* non-equilibrated system for use in CGET04. */
if (equil) {
roldo = rcondo;
roldi = rcondi;
}
/* Compute the 1-norm and infinity-norm of A. */
anormo = clangb_("1", &n, &kl, &ku, &afb[kl +
1], &ldafb, &rwork[1]);
anormi = clangb_("I", &n, &kl, &ku, &afb[kl +
1], &ldafb, &rwork[1]);
/* Factor the matrix A. */
cgbtrf_(&n, &n, &kl, &ku, &afb[1], &ldafb, &
iwork[1], &info);
/* Form the inverse of A. */
claset_("Full", &n, &n, &c_b48, &c_b49, &work[
1], &ldb);
s_copy(srnamc_1.srnamt, "CGBTRS", (ftnlen)32,
(ftnlen)6);
cgbtrs_("No transpose", &n, &kl, &ku, &n, &
afb[1], &ldafb, &iwork[1], &work[1], &
ldb, &info);
/* Compute the 1-norm condition number of A. */
ainvnm = clange_("1", &n, &n, &work[1], &ldb,
&rwork[1]);
if (anormo <= 0.f || ainvnm <= 0.f) {
rcondo = 1.f;
} else {
rcondo = 1.f / anormo / ainvnm;
}
/* Compute the infinity-norm condition number */
/* of A. */
ainvnm = clange_("I", &n, &n, &work[1], &ldb,
&rwork[1]);
if (anormi <= 0.f || ainvnm <= 0.f) {
rcondi = 1.f;
} else {
rcondi = 1.f / anormi / ainvnm;
}
}
for (itran = 1; itran <= 3; ++itran) {
/* Do for each value of TRANS. */
*(unsigned char *)trans = *(unsigned char *)&
transs[itran - 1];
if (itran == 1) {
rcondc = rcondo;
} else {
rcondc = rcondi;
}
/* Restore the matrix A. */
i__8 = kl + ku + 1;
clacpy_("Full", &i__8, &n, &asav[1], &lda, &a[
1], &lda);
/* Form an exact solution and set the right hand */
/* side. */
s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32,
(ftnlen)6);
clarhs_(path, xtype, "Full", trans, &n, &n, &
kl, &ku, nrhs, &a[1], &lda, &xact[1],
&ldb, &b[1], &ldb, iseed, &info);
*(unsigned char *)xtype = 'C';
clacpy_("Full", &n, nrhs, &b[1], &ldb, &bsav[
1], &ldb);
if (nofact && itran == 1) {
/* --- Test CGBSV --- */
/* Compute the LU factorization of the matrix */
/* and solve the system. */
i__8 = kl + ku + 1;
clacpy_("Full", &i__8, &n, &a[1], &lda, &
afb[kl + 1], &ldafb);
clacpy_("Full", &n, nrhs, &b[1], &ldb, &x[
1], &ldb);
s_copy(srnamc_1.srnamt, "CGBSV ", (ftnlen)
32, (ftnlen)6);
cgbsv_(&n, &kl, &ku, nrhs, &afb[1], &
ldafb, &iwork[1], &x[1], &ldb, &
info);
/* Check error code from CGBSV . */
if (info != izero) {
alaerh_(path, "CGBSV ", &info, &izero,
" ", &n, &n, &kl, &ku, nrhs,
&imat, &nfail, &nerrs, nout);
}
/* Reconstruct matrix from factors and */
/* compute residual. */
cgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
afb[1], &ldafb, &iwork[1], &work[
1], result);
nt = 1;
if (izero == 0) {
/* Compute residual of the computed */
/* solution. */
clacpy_("Full", &n, nrhs, &b[1], &ldb,
&work[1], &ldb);
cgbt02_("No transpose", &n, &n, &kl, &
ku, nrhs, &a[1], &lda, &x[1],
&ldb, &work[1], &ldb, &result[
1]);
/* Check solution from generated exact */
/* solution. */
cget04_(&n, nrhs, &x[1], &ldb, &xact[
1], &ldb, &rcondc, &result[2])
;
nt = 3;
}
/* Print information about the tests that did */
/* not pass the threshold. */
i__8 = nt;
for (k = 1; k <= i__8; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___65.ciunit = *nout;
s_wsfe(&io___65);
do_fio(&c__1, "CGBSV ", (ftnlen)6)
;
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&kl, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ku, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&result[k -
1], (ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
/* L50: */
}
nrun += nt;
}
/* --- Test CGBSVX --- */
if (! prefac) {
i__8 = (kl << 1) + ku + 1;
claset_("Full", &i__8, &n, &c_b48, &c_b48,
&afb[1], &ldafb);
}
claset_("Full", &n, nrhs, &c_b48, &c_b48, &x[
1], &ldb);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT = 'F' and */
/* EQUED = 'R', 'C', or 'B'. */
claqgb_(&n, &n, &kl, &ku, &a[1], &lda, &s[
1], &s[n + 1], &rowcnd, &colcnd, &
amax, equed);
}
/* Solve the system and compute the condition */
/* number and error bounds using CGBSVX. */
s_copy(srnamc_1.srnamt, "CGBSVX", (ftnlen)32,
(ftnlen)6);
cgbsvx_(fact, trans, &n, &kl, &ku, nrhs, &a[1]
, &lda, &afb[1], &ldafb, &iwork[1],
equed, &s[1], &s[ldb + 1], &b[1], &
ldb, &x[1], &ldb, &rcond, &rwork[1], &
rwork[*nrhs + 1], &work[1], &rwork[(*
nrhs << 1) + 1], &info);
/* Check the error code from CGBSVX. */
if (info != izero) {
/* Writing concatenation */
i__11[0] = 1, a__1[0] = fact;
i__11[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__11, &c__2, (ftnlen)
2);
alaerh_(path, "CGBSVX", &info, &izero,
ch__1, &n, &n, &kl, &ku, nrhs, &
imat, &nfail, &nerrs, nout);
}
/* Compare RWORK(2*NRHS+1) from CGBSVX with the */
/* computed reciprocal pivot growth RPVGRW */
if (info != 0) {
anrmpv = 0.f;
i__8 = info;
for (j = 1; j <= i__8; ++j) {
/* Computing MAX */
i__6 = ku + 2 - j;
/* Computing MIN */
i__9 = n + ku + 1 - j, i__10 = kl +
ku + 1;
i__7 = min(i__9,i__10);
for (i__ = max(i__6,1); i__ <= i__7;
++i__) {
/* Computing MAX */
r__1 = anrmpv, r__2 = c_abs(&a[
i__ + (j - 1) * lda]);
anrmpv = dmax(r__1,r__2);
/* L60: */
}
/* L70: */
}
/* Computing MIN */
i__7 = info - 1, i__6 = kl + ku;
i__8 = min(i__7,i__6);
/* Computing MAX */
i__9 = 1, i__10 = kl + ku + 2 - info;
rpvgrw = clantb_("M", "U", "N", &info, &
i__8, &afb[max(i__9, i__10)], &
ldafb, rdum);
if (rpvgrw == 0.f) {
rpvgrw = 1.f;
} else {
rpvgrw = anrmpv / rpvgrw;
}
} else {
i__8 = kl + ku;
rpvgrw = clantb_("M", "U", "N", &n, &i__8,
&afb[1], &ldafb, rdum);
if (rpvgrw == 0.f) {
rpvgrw = 1.f;
} else {
rpvgrw = clangb_("M", &n, &kl, &ku, &
a[1], &lda, rdum) /
rpvgrw;
}
}
/* Computing MAX */
r__2 = rwork[(*nrhs << 1) + 1];
result[6] = (r__1 = rpvgrw - rwork[(*nrhs <<
1) + 1], dabs(r__1)) / dmax(r__2,
rpvgrw) / slamch_("E");
if (! prefac) {
/* Reconstruct matrix from factors and */
/* compute residual. */
cgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
afb[1], &ldafb, &iwork[1], &work[
1], result);
k1 = 1;
} else {
k1 = 2;
}
if (info == 0) {
trfcon = FALSE_;
/* Compute residual of the computed solution. */
clacpy_("Full", &n, nrhs, &bsav[1], &ldb,
&work[1], &ldb);
cgbt02_(trans, &n, &n, &kl, &ku, nrhs, &
asav[1], &lda, &x[1], &ldb, &work[
1], &ldb, &result[1]);
/* Check solution from generated exact */
/* solution. */
if (nofact || prefac && lsame_(equed,
"N")) {
cget04_(&n, nrhs, &x[1], &ldb, &xact[
1], &ldb, &rcondc, &result[2])
;
} else {
if (itran == 1) {
roldc = roldo;
} else {
roldc = roldi;
}
cget04_(&n, nrhs, &x[1], &ldb, &xact[
1], &ldb, &roldc, &result[2]);
}
/* Check the error bounds from iterative */
/* refinement. */
cgbt05_(trans, &n, &kl, &ku, nrhs, &asav[
1], &lda, &bsav[1], &ldb, &x[1], &
ldb, &xact[1], &ldb, &rwork[1], &
rwork[*nrhs + 1], &result[3]);
} else {
trfcon = TRUE_;
}
/* Compare RCOND from CGBSVX with the computed */
/* value in RCONDC. */
result[5] = sget06_(&rcond, &rcondc);
/* Print information about the tests that did */
/* not pass the threshold. */
if (! trfcon) {
for (k = k1; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___73.ciunit = *nout;
s_wsfe(&io___73);
do_fio(&c__1, "CGBSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
} else {
io___74.ciunit = *nout;
s_wsfe(&io___74);
do_fio(&c__1, "CGBSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
}
++nfail;
}
/* L80: */
}
nrun = nrun + 7 - k1;
} else {
if (result[0] >= *thresh && ! prefac) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___75.ciunit = *nout;
s_wsfe(&io___75);
do_fio(&c__1, "CGBSVX", (ftnlen)6)
;
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&kl, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ku, (
ftnlen)sizeof(integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[0],
(ftnlen)sizeof(real));
e_wsfe();
} else {
io___76.ciunit = *nout;
s_wsfe(&io___76);
do_fio(&c__1, "CGBSVX", (ftnlen)6)
;
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&kl, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ku, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[0],
(ftnlen)sizeof(real));
e_wsfe();
}
++nfail;
++nrun;
}
if (result[5] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___77.ciunit = *nout;
s_wsfe(&io___77);
do_fio(&c__1, "CGBSVX", (ftnlen)6)
;
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&kl, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ku, (
ftnlen)sizeof(integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__6, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[5],
(ftnlen)sizeof(real));
e_wsfe();
} else {
io___78.ciunit = *nout;
s_wsfe(&io___78);
do_fio(&c__1, "CGBSVX", (ftnlen)6)
;
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&kl, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ku, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__6, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[5],
(ftnlen)sizeof(real));
e_wsfe();
}
++nfail;
++nrun;
}
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___79.ciunit = *nout;
s_wsfe(&io___79);
do_fio(&c__1, "CGBSVX", (ftnlen)6)
;
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&kl, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ku, (
ftnlen)sizeof(integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__7, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[6],
(ftnlen)sizeof(real));
e_wsfe();
} else {
io___80.ciunit = *nout;
s_wsfe(&io___80);
do_fio(&c__1, "CGBSVX", (ftnlen)6)
;
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&kl, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ku, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__7, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[6],
(ftnlen)sizeof(real));
e_wsfe();
}
++nfail;
++nrun;
}
}
/* L90: */
}
L100:
;
}
/* L110: */
}
L120:
;
}
L130:
;
}
/* L140: */
}
/* L150: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of CDRVGB */
} /* cdrvgb_ */
/* Subroutine */ int cgtt02_(char *trans, integer *n, integer *nrhs, complex *
dl, complex *d__, complex *du, complex *x, integer *ldx, complex *b,
integer *ldb, real *rwork, real *resid)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1;
real r__1, r__2;
/* Local variables */
integer j;
real eps;
extern logical lsame_(char *, char *);
real anorm, bnorm, xnorm;
extern doublereal slamch_(char *), clangt_(char *, integer *,
complex *, complex *, complex *);
extern /* Subroutine */ int clagtm_(char *, integer *, integer *, real *,
complex *, complex *, complex *, complex *, integer *, real *,
complex *, integer *);
extern doublereal scasum_(integer *, complex *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGTT02 computes the residual for the solution to a tridiagonal */
/* system of equations: */
/* RESID = norm(B - op(A)*X) / (norm(A) * norm(X) * EPS), */
/* where EPS is the machine epsilon. */
/* Arguments */
/* ========= */
/* TRANS (input) CHARACTER */
/* Specifies the form of the residual. */
/* = 'N': B - A * X (No transpose) */
/* = 'T': B - A**T * X (Transpose) */
/* = 'C': B - A**H * X (Conjugate transpose) */
/* N (input) INTEGTER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* DL (input) COMPLEX array, dimension (N-1) */
/* The (n-1) sub-diagonal elements of A. */
/* D (input) COMPLEX array, dimension (N) */
/* The diagonal elements of A. */
/* DU (input) COMPLEX array, dimension (N-1) */
/* The (n-1) super-diagonal elements of A. */
/* X (input) COMPLEX array, dimension (LDX,NRHS) */
/* The computed solution vectors X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
/* On entry, the right hand side vectors for the system of */
/* linear equations. */
/* On exit, B is overwritten with the difference B - op(A)*X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* norm(B - op(A)*X) / (norm(A) * norm(X) * EPS) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 or NRHS = 0 */
/* Parameter adjustments */
--dl;
--d__;
--du;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--rwork;
/* Function Body */
*resid = 0.f;
if (*n <= 0 || *nrhs == 0) {
return 0;
}
/* Compute the maximum over the number of right hand sides of */
/* norm(B - op(A)*X) / ( norm(A) * norm(X) * EPS ). */
if (lsame_(trans, "N")) {
anorm = clangt_("1", n, &dl[1], &d__[1], &du[1]);
} else {
anorm = clangt_("I", n, &dl[1], &d__[1], &du[1]);
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Compute B - op(A)*X. */
clagtm_(trans, n, nrhs, &c_b6, &dl[1], &d__[1], &du[1], &x[x_offset], ldx,
&c_b7, &b[b_offset], ldb);
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
bnorm = scasum_(n, &b[j * b_dim1 + 1], &c__1);
xnorm = scasum_(n, &x[j * x_dim1 + 1], &c__1);
if (xnorm <= 0.f) {
*resid = 1.f / eps;
} else {
/* Computing MAX */
r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
*resid = dmax(r__1,r__2);
}
/* L10: */
}
return 0;
/* End of CGTT02 */
} /* cgtt02_ */
/* Subroutine */ int cpbrfs_(char *uplo, integer *n, integer *kd, integer *
nrhs, complex *ab, integer *ldab, complex *afb, integer *ldafb,
complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *
berr, complex *work, real *rwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CPBRFS improves the computed solution to a system of linear
equations when the coefficient matrix is Hermitian positive definite
and banded, and provides error bounds and backward error estimates
for the solution.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of superdiagonals of the matrix A if UPLO = 'U',
or the number of subdiagonals if UPLO = 'L'. KD >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
AB (input) REAL array, dimension (LDAB,N)
The upper or lower triangle of the Hermitian band matrix A,
stored in the first KD+1 rows of the array. The j-th column
of A is stored in the j-th column of the array AB as follows:
if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
AFB (input) COMPLEX array, dimension (LDAFB,N)
The triangular factor U or L from the Cholesky factorization
A = U**H*U or A = L*L**H of the band matrix A as computed by
CPBTRF, in the same storage format as A (see AB).
LDAFB (input) INTEGER
The leading dimension of the array AFB. LDAFB >= KD+1.
B (input) COMPLEX array, dimension (LDB,NRHS)
The right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input/output) COMPLEX array, dimension (LDX,NRHS)
On entry, the solution matrix X, as computed by CPBTRS.
On exit, the improved solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
FERR (output) REAL array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) REAL array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace) COMPLEX array, dimension (2*N)
RWORK (workspace) REAL array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Internal Parameters
===================
ITMAX is the maximum number of steps of iterative refinement.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer kase;
static real safe1, safe2;
static integer i, j, k, l;
static real s;
extern /* Subroutine */ int chbmv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static integer count;
static logical upper;
extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
*, integer *);
static real xk;
extern doublereal slamch_(char *);
static integer nz;
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), cpbtrs_(
char *, integer *, integer *, integer *, complex *, integer *,
complex *, integer *, integer *);
static real lstres, eps;
#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
#define AFB(I,J) afb[(I)-1 + ((J)-1)* ( *ldafb)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kd < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*ldab < *kd + 1) {
*info = -6;
} else if (*ldafb < *kd + 1) {
*info = -8;
} else if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldx < max(1,*n)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPBRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
FERR(j) = 0.f;
BERR(j) = 0.f;
/* L10: */
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1
Computing MIN */
i__1 = *n + 1, i__2 = (*kd << 1) + 2;
nz = min(i__1,i__2);
eps = slamch_("Epsilon");
safmin = slamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
count = 1;
lstres = 3.f;
L20:
/* Loop until stopping criterion is satisfied.
Compute residual R = B - A * X */
ccopy_(n, &B(1,j), &c__1, &WORK(1), &c__1);
q__1.r = -1.f, q__1.i = 0.f;
chbmv_(uplo, n, kd, &q__1, &AB(1,1), ldab, &X(1,j), &
c__1, &c_b1, &WORK(1), &c__1);
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
where abs(Z) is the componentwise absolute value of the matr
ix
or vector Z. If the i-th component of the denominator is le
ss
than SAFE2, then SAFE1 is added to the i-th components of th
e
numerator and denominator before dividing. */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
i__3 = i + j * b_dim1;
RWORK(i) = (r__1 = B(i,j).r, dabs(r__1)) + (r__2 = r_imag(&B(i,j)), dabs(r__2));
/* L30: */
}
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = 0.f;
i__3 = k + j * x_dim1;
xk = (r__1 = X(k,j).r, dabs(r__1)) + (r__2 = r_imag(&X(k,j)), dabs(r__2));
l = *kd + 1 - k;
/* Computing MAX */
i__3 = 1, i__4 = k - *kd;
i__5 = k - 1;
for (i = max(1,k-*kd); i <= k-1; ++i) {
i__3 = l + i + k * ab_dim1;
RWORK(i) += ((r__1 = AB(l+i,k).r, dabs(r__1)) + (r__2 =
r_imag(&AB(l+i,k)), dabs(r__2))) *
xk;
i__3 = l + i + k * ab_dim1;
i__4 = i + j * x_dim1;
s += ((r__1 = AB(l+i,k).r, dabs(r__1)) + (r__2 = r_imag(&
AB(l+i,k)), dabs(r__2))) * ((r__3 =
X(i,j).r, dabs(r__3)) + (r__4 = r_imag(&X(i,j)), dabs(r__4)));
/* L40: */
}
i__5 = *kd + 1 + k * ab_dim1;
RWORK(k) = RWORK(k) + (r__1 = AB(*kd+1,k).r, dabs(r__1)) * xk +
s;
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = 0.f;
i__5 = k + j * x_dim1;
xk = (r__1 = X(k,j).r, dabs(r__1)) + (r__2 = r_imag(&X(k,j)), dabs(r__2));
i__5 = k * ab_dim1 + 1;
RWORK(k) += (r__1 = AB(1,k).r, dabs(r__1)) * xk;
l = 1 - k;
/* Computing MIN */
i__3 = *n, i__4 = k + *kd;
i__5 = min(i__3,i__4);
for (i = k + 1; i <= min(*n,k+*kd); ++i) {
i__3 = l + i + k * ab_dim1;
RWORK(i) += ((r__1 = AB(l+i,k).r, dabs(r__1)) + (r__2 =
r_imag(&AB(l+i,k)), dabs(r__2))) *
xk;
i__3 = l + i + k * ab_dim1;
i__4 = i + j * x_dim1;
s += ((r__1 = AB(l+i,k).r, dabs(r__1)) + (r__2 = r_imag(&
AB(l+i,k)), dabs(r__2))) * ((r__3 =
X(i,j).r, dabs(r__3)) + (r__4 = r_imag(&X(i,j)), dabs(r__4)));
/* L60: */
}
RWORK(k) += s;
/* L70: */
}
}
s = 0.f;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (RWORK(i) > safe2) {
/* Computing MAX */
i__5 = i;
r__3 = s, r__4 = ((r__1 = WORK(i).r, dabs(r__1)) + (r__2 =
r_imag(&WORK(i)), dabs(r__2))) / RWORK(i);
s = dmax(r__3,r__4);
} else {
/* Computing MAX */
i__5 = i;
r__3 = s, r__4 = ((r__1 = WORK(i).r, dabs(r__1)) + (r__2 =
r_imag(&WORK(i)), dabs(r__2)) + safe1) / (RWORK(i) +
safe1);
s = dmax(r__3,r__4);
}
/* L80: */
}
BERR(j) = s;
/* Test stopping criterion. Continue iterating if
1) The residual BERR(J) is larger than machine epsilon, a
nd
2) BERR(J) decreased by at least a factor of 2 during the
last iteration, and
3) At most ITMAX iterations tried. */
if (BERR(j) > eps && BERR(j) * 2.f <= lstres && count <= 5) {
/* Update solution and try again. */
cpbtrs_(uplo, n, kd, &c__1, &AFB(1,1), ldafb, &WORK(1), n,
info);
caxpy_(n, &c_b1, &WORK(1), &c__1, &X(1,j), &c__1);
lstres = BERR(j);
++count;
goto L20;
}
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(A))*
( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
where
norm(Z) is the magnitude of the largest component of Z
inv(A) is the inverse of A
abs(Z) is the componentwise absolute value of the matrix o
r
vector Z
NZ is the maximum number of nonzeros in any row of A, plus
1
EPS is machine epsilon
The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
is incremented by SAFE1 if the i-th component of
abs(A)*abs(X) + abs(B) is less than SAFE2.
Use CLACON to estimate the infinity-norm of the matrix
inv(A) * diag(W),
where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (RWORK(i) > safe2) {
i__5 = i;
RWORK(i) = (r__1 = WORK(i).r, dabs(r__1)) + (r__2 = r_imag(
&WORK(i)), dabs(r__2)) + nz * eps * RWORK(i);
} else {
i__5 = i;
RWORK(i) = (r__1 = WORK(i).r, dabs(r__1)) + (r__2 = r_imag(
&WORK(i)), dabs(r__2)) + nz * eps * RWORK(i) + safe1;
}
/* L90: */
}
kase = 0;
L100:
clacon_(n, &WORK(*n + 1), &WORK(1), &FERR(j), &kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(A'). */
cpbtrs_(uplo, n, kd, &c__1, &AFB(1,1), ldafb, &WORK(1),
n, info);
i__2 = *n;
for (i = 1; i <= *n; ++i) {
i__5 = i;
i__3 = i;
i__4 = i;
q__1.r = RWORK(i) * WORK(i).r, q__1.i = RWORK(i)
* WORK(i).i;
WORK(i).r = q__1.r, WORK(i).i = q__1.i;
/* L110: */
}
} else if (kase == 2) {
/* Multiply by inv(A)*diag(W). */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
i__5 = i;
i__3 = i;
i__4 = i;
q__1.r = RWORK(i) * WORK(i).r, q__1.i = RWORK(i)
* WORK(i).i;
WORK(i).r = q__1.r, WORK(i).i = q__1.i;
/* L120: */
}
cpbtrs_(uplo, n, kd, &c__1, &AFB(1,1), ldafb, &WORK(1),
n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
/* Computing MAX */
i__5 = i + j * x_dim1;
r__3 = lstres, r__4 = (r__1 = X(i,j).r, dabs(r__1)) + (r__2 =
r_imag(&X(i,j)), dabs(r__2));
lstres = dmax(r__3,r__4);
/* L130: */
}
if (lstres != 0.f) {
FERR(j) /= lstres;
}
/* L140: */
}
return 0;
/* End of CPBRFS */
} /* cpbrfs_ */
/* Subroutine */ int ssbt21_(char *uplo, integer *n, integer *ka, integer *ks,
real *a, integer *lda, real *d__, real *e, real *u, integer *ldu,
real *work, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, u_dim1, u_offset, i__1, i__2, i__3, i__4;
real r__1, r__2;
/* Local variables */
integer j, jc, jr, lw, ika;
real ulp, unfl;
extern /* Subroutine */ int sspr_(char *, integer *, real *, real *,
integer *, real *), sspr2_(char *, integer *, real *,
real *, integer *, real *, integer *, real *);
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
real anorm;
char cuplo[1];
logical lower;
real wnorm;
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *), slansb_(char *,
char *, integer *, integer *, real *, integer *, real *), slansp_(char *, char *, integer *, real *, real *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SSBT21 generally checks a decomposition of the form */
/* A = U S U' */
/* where ' means transpose, A is symmetric banded, U is */
/* orthogonal, and S is diagonal (if KS=0) or symmetric */
/* tridiagonal (if KS=1). */
/* Specifically: */
/* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and* */
/* RESULT(2) = | I - UU' | / ( n ulp ) */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER */
/* If UPLO='U', the upper triangle of A and V will be used and */
/* the (strictly) lower triangle will not be referenced. */
/* If UPLO='L', the lower triangle of A and V will be used and */
/* the (strictly) upper triangle will not be referenced. */
/* N (input) INTEGER */
/* The size of the matrix. If it is zero, SSBT21 does nothing. */
/* It must be at least zero. */
/* KA (input) INTEGER */
/* The bandwidth of the matrix A. It must be at least zero. If */
/* it is larger than N-1, then max( 0, N-1 ) will be used. */
/* KS (input) INTEGER */
/* The bandwidth of the matrix S. It may only be zero or one. */
/* If zero, then S is diagonal, and E is not referenced. If */
/* one, then S is symmetric tri-diagonal. */
/* A (input) REAL array, dimension (LDA, N) */
/* The original (unfactored) matrix. It is assumed to be */
/* symmetric, and only the upper (UPLO='U') or only the lower */
/* (UPLO='L') will be referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of A. It must be at least 1 */
/* and at least min( KA, N-1 ). */
/* D (input) REAL array, dimension (N) */
/* The diagonal of the (symmetric tri-) diagonal matrix S. */
/* E (input) REAL array, dimension (N-1) */
/* The off-diagonal of the (symmetric tri-) diagonal matrix S. */
/* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and */
/* (3,2) element, etc. */
/* Not referenced if KS=0. */
/* U (input) REAL array, dimension (LDU, N) */
/* The orthogonal matrix in the decomposition, expressed as a */
/* dense matrix (i.e., not as a product of Householder */
/* transformations, Givens transformations, etc.) */
/* LDU (input) INTEGER */
/* The leading dimension of U. LDU must be at least N and */
/* at least 1. */
/* WORK (workspace) REAL array, dimension (N**2+N) */
/* RESULT (output) REAL array, dimension (2) */
/* The values computed by the two tests described above. The */
/* values are currently limited to 1/ulp, to avoid overflow. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Constants */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--d__;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
--work;
--result;
/* Function Body */
result[1] = 0.f;
result[2] = 0.f;
if (*n <= 0) {
return 0;
}
/* Computing MAX */
/* Computing MIN */
i__3 = *n - 1;
i__1 = 0, i__2 = min(i__3,*ka);
ika = max(i__1,i__2);
lw = *n * (*n + 1) / 2;
if (lsame_(uplo, "U")) {
lower = FALSE_;
*(unsigned char *)cuplo = 'U';
} else {
lower = TRUE_;
*(unsigned char *)cuplo = 'L';
}
unfl = slamch_("Safe minimum");
ulp = slamch_("Epsilon") * slamch_("Base");
/* Some Error Checks */
/* Do Test 1 */
/* Norm of A: */
/* Computing MAX */
r__1 = slansb_("1", cuplo, n, &ika, &a[a_offset], lda, &work[1]);
anorm = dmax(r__1,unfl);
/* Compute error matrix: Error = A - U S U' */
/* Copy A from SB to SP storage format. */
j = 0;
i__1 = *n;
for (jc = 1; jc <= i__1; ++jc) {
if (lower) {
/* Computing MIN */
i__3 = ika + 1, i__4 = *n + 1 - jc;
i__2 = min(i__3,i__4);
for (jr = 1; jr <= i__2; ++jr) {
++j;
work[j] = a[jr + jc * a_dim1];
/* L10: */
}
i__2 = *n + 1 - jc;
for (jr = ika + 2; jr <= i__2; ++jr) {
++j;
work[j] = 0.f;
/* L20: */
}
} else {
i__2 = jc;
for (jr = ika + 2; jr <= i__2; ++jr) {
++j;
work[j] = 0.f;
/* L30: */
}
/* Computing MIN */
i__2 = ika, i__3 = jc - 1;
for (jr = min(i__2,i__3); jr >= 0; --jr) {
++j;
work[j] = a[ika + 1 - jr + jc * a_dim1];
/* L40: */
}
}
/* L50: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
r__1 = -d__[j];
sspr_(cuplo, n, &r__1, &u[j * u_dim1 + 1], &c__1, &work[1])
;
/* L60: */
}
if (*n > 1 && *ks == 1) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
r__1 = -e[j];
sspr2_(cuplo, n, &r__1, &u[j * u_dim1 + 1], &c__1, &u[(j + 1) *
u_dim1 + 1], &c__1, &work[1]);
/* L70: */
}
}
wnorm = slansp_("1", cuplo, n, &work[1], &work[lw + 1]);
if (anorm > wnorm) {
result[1] = wnorm / anorm / (*n * ulp);
} else {
if (anorm < 1.f) {
/* Computing MIN */
r__1 = wnorm, r__2 = *n * anorm;
result[1] = dmin(r__1,r__2) / anorm / (*n * ulp);
} else {
/* Computing MIN */
r__1 = wnorm / anorm, r__2 = (real) (*n);
result[1] = dmin(r__1,r__2) / (*n * ulp);
}
}
/* Do Test 2 */
/* Compute UU' - I */
sgemm_("N", "C", n, n, n, &c_b22, &u[u_offset], ldu, &u[u_offset], ldu, &
c_b23, &work[1], n);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
work[(*n + 1) * (j - 1) + 1] += -1.f;
/* L80: */
}
/* Computing MIN */
/* Computing 2nd power */
i__1 = *n;
r__1 = slange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]),
r__2 = (real) (*n);
result[2] = dmin(r__1,r__2) / (*n * ulp);
return 0;
/* End of SSBT21 */
} /* ssbt21_ */
/* Subroutine */ int cchkhs_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, real *thresh, integer *nounit,
complex *a, integer *lda, complex *h__, complex *t1, complex *t2,
complex *u, integer *ldu, complex *z__, complex *uz, complex *w1,
complex *w3, complex *evectl, complex *evectr, complex *evecty,
complex *evectx, complex *uu, complex *tau, complex *work, integer *
nwork, real *rwork, integer *iwork, logical *select, real *result,
integer *info)
{
/* Initialized data */
static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
/* Format strings */
static char fmt_9999[] = "(\002 CCHKHS: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 CCHKHS: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
"i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(\002 CCHKHS: Selected \002,a,\002 Eigenvector"
"s from \002,a,\002 do not match other eigenvectors \002,9x,\002N="
"\002,i6,\002, JTYPE=\002,i6,\002, ISEED=(\002,3(i5,\002,\002),i5,"
"\002)\002)";
/* System generated locals */
integer a_dim1, a_offset, evectl_dim1, evectl_offset, evectr_dim1,
evectr_offset, evectx_dim1, evectx_offset, evecty_dim1,
evecty_offset, h_dim1, h_offset, t1_dim1, t1_offset, t2_dim1,
t2_offset, u_dim1, u_offset, uu_dim1, uu_offset, uz_dim1,
uz_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
real r__1, r__2;
complex q__1;
/* Local variables */
integer i__, j, k, n, n1, jj, in, ihi, ilo;
real ulp, cond;
integer jcol, nmax;
real unfl, ovfl, temp1, temp2;
logical badnn;
extern /* Subroutine */ int cget10_(integer *, integer *, complex *,
integer *, complex *, integer *, complex *, real *, real *),
cget22_(char *, char *, char *, integer *, complex *, integer *,
complex *, integer *, complex *, complex *, real *, real *), cgemm_(char *, char *, integer *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *, complex *, complex *, integer *);
logical match;
integer imode;
extern /* Subroutine */ int chst01_(integer *, integer *, integer *,
complex *, integer *, complex *, integer *, complex *, integer *,
complex *, integer *, real *, real *);
real dumma[4];
integer iinfo;
real conds, aninv, anorm;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
integer nmats, jsize, nerrs, itype, jtype, ntest;
real rtulp;
extern /* Subroutine */ int slabad_(real *, real *), cgehrd_(integer *,
integer *, integer *, complex *, integer *, complex *, complex *,
integer *, integer *), clatme_(integer *, char *, integer *,
complex *, integer *, real *, complex *, char *, char *, char *,
char *, real *, integer *, real *, integer *, integer *, real *,
complex *, integer *, complex *, integer *);
complex cdumma[4];
extern doublereal slamch_(char *);
extern /* Subroutine */ int chsein_(char *, char *, char *, logical *,
integer *, complex *, integer *, complex *, complex *, integer *,
complex *, integer *, integer *, integer *, complex *, real *,
integer *, integer *, integer *), clacpy_(
char *, integer *, integer *, complex *, integer *, complex *,
integer *);
integer idumma[1];
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *);
integer ioldsd[4];
extern /* Subroutine */ int xerbla_(char *, integer *), clatmr_(
integer *, integer *, char *, integer *, char *, complex *,
integer *, real *, complex *, char *, char *, complex *, integer *
, real *, complex *, integer *, real *, char *, integer *,
integer *, integer *, real *, real *, char *, complex *, integer *
, integer *, integer *), clatms_(integer *, integer *, char *, integer *, char *,
real *, integer *, real *, real *, integer *, integer *, char *,
complex *, integer *, complex *, integer *), chseqr_(char *, char *, integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, complex *,
integer *, integer *), ctrevc_(char *, char *,
logical *, integer *, complex *, integer *, complex *, integer *,
complex *, integer *, integer *, integer *, complex *, real *,
integer *), cunghr_(integer *, integer *, integer
*, complex *, integer *, complex *, complex *, integer *, integer
*), cunmhr_(char *, char *, integer *, integer *, integer *,
integer *, complex *, integer *, complex *, complex *, integer *,
complex *, integer *, integer *), slafts_(char *,
integer *, integer *, integer *, integer *, real *, integer *,
real *, integer *, integer *), slasum_(char *, integer *,
integer *, integer *);
real rtunfl, rtovfl, rtulpi, ulpinv;
integer mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___60 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___61 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___62 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___63 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___64 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* February 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CCHKHS checks the nonsymmetric eigenvalue problem routines. */
/* CGEHRD factors A as U H U' , where ' means conjugate */
/* transpose, H is hessenberg, and U is unitary. */
/* CUNGHR generates the unitary matrix U. */
/* CUNMHR multiplies a matrix by the unitary matrix U. */
/* CHSEQR factors H as Z T Z' , where Z is unitary and T */
/* is upper triangular. It also computes the eigenvalues, */
/* w(1), ..., w(n); we define a diagonal matrix W whose */
/* (diagonal) entries are the eigenvalues. */
/* CTREVC computes the left eigenvector matrix L and the */
/* right eigenvector matrix R for the matrix T. The */
/* columns of L are the complex conjugates of the left */
/* eigenvectors of T. The columns of R are the right */
/* eigenvectors of T. L is lower triangular, and R is */
/* upper triangular. */
/* CHSEIN computes the left eigenvector matrix Y and the */
/* right eigenvector matrix X for the matrix H. The */
/* columns of Y are the complex conjugates of the left */
/* eigenvectors of H. The columns of X are the right */
/* eigenvectors of H. Y is lower triangular, and X is */
/* upper triangular. */
/* When CCHKHS is called, a number of matrix "sizes" ("n's") and a */
/* number of matrix "types" are specified. For each size ("n") */
/* and each type of matrix, one matrix will be generated and used */
/* to test the nonsymmetric eigenroutines. For each matrix, 14 */
/* tests will be performed: */
/* (1) | A - U H U**H | / ( |A| n ulp ) */
/* (2) | I - UU**H | / ( n ulp ) */
/* (3) | H - Z T Z**H | / ( |H| n ulp ) */
/* (4) | I - ZZ**H | / ( n ulp ) */
/* (5) | A - UZ H (UZ)**H | / ( |A| n ulp ) */
/* (6) | I - UZ (UZ)**H | / ( n ulp ) */
/* (7) | T(Z computed) - T(Z not computed) | / ( |T| ulp ) */
/* (8) | W(Z computed) - W(Z not computed) | / ( |W| ulp ) */
/* (9) | TR - RW | / ( |T| |R| ulp ) */
/* (10) | L**H T - W**H L | / ( |T| |L| ulp ) */
/* (11) | HX - XW | / ( |H| |X| ulp ) */
/* (12) | Y**H H - W**H Y | / ( |H| |Y| ulp ) */
/* (13) | AX - XW | / ( |A| |X| ulp ) */
/* (14) | Y**H A - W**H Y | / ( |A| |Y| ulp ) */
/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
/* each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
/* (4) A diagonal matrix with evenly spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (5) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random complex angles. */
/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random complex angles. */
/* (7) Same as (4), but multiplied by SQRT( overflow threshold ) */
/* (8) Same as (4), but multiplied by SQRT( underflow threshold ) */
/* (9) A matrix of the form U' T U, where U is unitary and */
/* T has evenly spaced entries 1, ..., ULP with random complex */
/* angles on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (10) A matrix of the form U' T U, where U is unitary and */
/* T has geometrically spaced entries 1, ..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (11) A matrix of the form U' T U, where U is unitary and */
/* T has "clustered" entries 1, ULP,..., ULP with random */
/* complex angles on the diagonal and random O(1) entries in */
/* the upper triangle. */
/* (12) A matrix of the form U' T U, where U is unitary and */
/* T has complex eigenvalues randomly chosen from */
/* ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (13) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (14) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has geometrically spaced entries */
/* 1, ..., ULP with random complex angles on the diagonal */
/* and random O(1) entries in the upper triangle. */
/* (15) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
/* with random complex angles on the diagonal and random O(1) */
/* entries in the upper triangle. */
/* (16) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has complex eigenvalues randomly chosen */
/* from ULP < |z| < 1 and random O(1) entries in the upper */
/* triangle. */
/* (17) Same as (16), but multiplied by SQRT( overflow threshold ) */
/* (18) Same as (16), but multiplied by SQRT( underflow threshold ) */
/* (19) Nonsymmetric matrix with random entries chosen from |z| < 1 */
/* (20) Same as (19), but multiplied by SQRT( overflow threshold ) */
/* (21) Same as (19), but multiplied by SQRT( underflow threshold ) */
/* Arguments */
/* ========== */
/* NSIZES - INTEGER */
/* The number of sizes of matrices to use. If it is zero, */
/* CCHKHS does nothing. It must be at least zero. */
/* Not modified. */
/* NN - INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* Not modified. */
/* NTYPES - INTEGER */
/* The number of elements in DOTYPE. If it is zero, CCHKHS */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A. This */
/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* Not modified. */
/* DOTYPE - LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* Not modified. */
/* ISEED - INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to CCHKHS to continue the same random number */
/* sequence. */
/* Modified. */
/* THRESH - REAL */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* Not modified. */
/* NOUNIT - INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* Not modified. */
/* A - COMPLEX array, dimension (LDA,max(NN)) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, A contains the last matrix actually */
/* used. */
/* Modified. */
/* LDA - INTEGER */
/* The leading dimension of A, H, T1 and T2. It must be at */
/* least 1 and at least max( NN ). */
/* Not modified. */
/* H - COMPLEX array, dimension (LDA,max(NN)) */
/* The upper hessenberg matrix computed by CGEHRD. On exit, */
/* H contains the Hessenberg form of the matrix in A. */
/* Modified. */
/* T1 - COMPLEX array, dimension (LDA,max(NN)) */
/* The Schur (="quasi-triangular") matrix computed by CHSEQR */
/* if Z is computed. On exit, T1 contains the Schur form of */
/* the matrix in A. */
/* Modified. */
/* T2 - COMPLEX array, dimension (LDA,max(NN)) */
/* The Schur matrix computed by CHSEQR when Z is not computed. */
/* This should be identical to T1. */
/* Modified. */
/* LDU - INTEGER */
/* The leading dimension of U, Z, UZ and UU. It must be at */
/* least 1 and at least max( NN ). */
/* Not modified. */
/* U - COMPLEX array, dimension (LDU,max(NN)) */
/* The unitary matrix computed by CGEHRD. */
/* Modified. */
/* Z - COMPLEX array, dimension (LDU,max(NN)) */
/* The unitary matrix computed by CHSEQR. */
/* Modified. */
/* UZ - COMPLEX array, dimension (LDU,max(NN)) */
/* The product of U times Z. */
/* Modified. */
/* W1 - COMPLEX array, dimension (max(NN)) */
/* The eigenvalues of A, as computed by a full Schur */
/* decomposition H = Z T Z'. On exit, W1 contains the */
/* eigenvalues of the matrix in A. */
/* Modified. */
/* W3 - COMPLEX array, dimension (max(NN)) */
/* The eigenvalues of A, as computed by a partial Schur */
/* decomposition (Z not computed, T only computed as much */
/* as is necessary for determining eigenvalues). On exit, */
/* W3 contains the eigenvalues of the matrix in A, possibly */
/* perturbed by CHSEIN. */
/* Modified. */
/* EVECTL - COMPLEX array, dimension (LDU,max(NN)) */
/* The conjugate transpose of the (upper triangular) left */
/* eigenvector matrix for the matrix in T1. */
/* Modified. */
/* EVECTR - COMPLEX array, dimension (LDU,max(NN)) */
/* The (upper triangular) right eigenvector matrix for the */
/* matrix in T1. */
/* Modified. */
/* EVECTY - COMPLEX array, dimension (LDU,max(NN)) */
/* The conjugate transpose of the left eigenvector matrix */
/* for the matrix in H. */
/* Modified. */
/* EVECTX - COMPLEX array, dimension (LDU,max(NN)) */
/* The right eigenvector matrix for the matrix in H. */
/* Modified. */
/* UU - COMPLEX array, dimension (LDU,max(NN)) */
/* Details of the unitary matrix computed by CGEHRD. */
/* Modified. */
/* TAU - COMPLEX array, dimension (max(NN)) */
/* Further details of the unitary matrix computed by CGEHRD. */
/* Modified. */
/* WORK - COMPLEX array, dimension (NWORK) */
/* Workspace. */
/* Modified. */
/* NWORK - INTEGER */
/* The number of entries in WORK. NWORK >= 4*NN(j)*NN(j) + 2. */
/* RWORK - REAL array, dimension (max(NN)) */
/* Workspace. Could be equivalenced to IWORK, but not SELECT. */
/* Modified. */
/* IWORK - INTEGER array, dimension (max(NN)) */
/* Workspace. */
/* Modified. */
/* SELECT - LOGICAL array, dimension (max(NN)) */
/* Workspace. Could be equivalenced to IWORK, but not RWORK. */
/* Modified. */
/* RESULT - REAL array, dimension (14) */
/* The values computed by the fourteen tests described above. */
/* The values are currently limited to 1/ulp, to avoid */
/* overflow. */
/* Modified. */
/* INFO - INTEGER */
/* If 0, then everything ran OK. */
/* -1: NSIZES < 0 */
/* -2: Some NN(j) < 0 */
/* -3: NTYPES < 0 */
/* -6: THRESH < 0 */
/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
/* -14: LDU < 1 or LDU < NMAX. */
/* -26: NWORK too small. */
/* If CLATMR, CLATMS, or CLATME returns an error code, the */
/* absolute value of it is returned. */
/* If 1, then CHSEQR could not find all the shifts. */
/* If 2, then the EISPACK code (for small blocks) failed. */
/* If >2, then 30*N iterations were not enough to find an */
/* eigenvalue or to decompose the problem. */
/* Modified. */
/* ----------------------------------------------------------------------- */
/* Some Local Variables and Parameters: */
/* ---- ----- --------- --- ---------- */
/* ZERO, ONE Real 0 and 1. */
/* MAXTYP The number of types defined. */
/* MTEST The number of tests defined: care must be taken */
/* that (1) the size of RESULT, (2) the number of */
/* tests actually performed, and (3) MTEST agree. */
/* NTEST The number of tests performed on this matrix */
/* so far. This should be less than MTEST, and */
/* equal to it by the last test. It will be less */
/* if any of the routines being tested indicates */
/* that it could not compute the matrices that */
/* would be tested. */
/* NMAX Largest value in NN. */
/* NMATS The number of matrices generated so far. */
/* NERRS The number of tests which have exceeded THRESH */
/* so far (computed by SLAFTS). */
/* COND, CONDS, */
/* IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* RTOVFL, RTUNFL, */
/* RTULP, RTULPI Square roots of the previous 4 values. */
/* The following four arrays decode JTYPE: */
/* KTYPE(j) The general type (1-10) for type "j". */
/* KMODE(j) The MODE value to be passed to the matrix */
/* generator for type "j". */
/* KMAGN(j) The order of magnitude ( O(1), */
/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
/* KCONDS(j) Selects whether CONDS is to be 1 or */
/* 1/sqrt(ulp). (0 means irrelevant.) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
t2_dim1 = *lda;
t2_offset = 1 + t2_dim1;
t2 -= t2_offset;
t1_dim1 = *lda;
t1_offset = 1 + t1_dim1;
t1 -= t1_offset;
h_dim1 = *lda;
h_offset = 1 + h_dim1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
uu_dim1 = *ldu;
uu_offset = 1 + uu_dim1;
uu -= uu_offset;
evectx_dim1 = *ldu;
evectx_offset = 1 + evectx_dim1;
evectx -= evectx_offset;
evecty_dim1 = *ldu;
evecty_offset = 1 + evecty_dim1;
evecty -= evecty_offset;
evectr_dim1 = *ldu;
evectr_offset = 1 + evectr_dim1;
evectr -= evectr_offset;
evectl_dim1 = *ldu;
evectl_offset = 1 + evectl_dim1;
evectl -= evectl_offset;
uz_dim1 = *ldu;
uz_offset = 1 + uz_dim1;
uz -= uz_offset;
z_dim1 = *ldu;
z_offset = 1 + z_dim1;
z__ -= z_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
--w1;
--w3;
--tau;
--work;
--rwork;
--iwork;
--select;
--result;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
ntestt = 0;
*info = 0;
badnn = FALSE_;
nmax = 0;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.f) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -9;
} else if (*ldu <= 1 || *ldu < nmax) {
*info = -14;
} else if ((nmax << 2) * nmax + 2 > *nwork) {
*info = -26;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CCHKHS", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
/* More important constants */
unfl = slamch_("Safe minimum");
ovfl = slamch_("Overflow");
slabad_(&unfl, &ovfl);
ulp = slamch_("Epsilon") * slamch_("Base");
ulpinv = 1.f / ulp;
rtunfl = sqrt(unfl);
rtovfl = sqrt(ovfl);
rtulp = sqrt(ulp);
rtulpi = 1.f / rtulp;
/* Loop over sizes, types */
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
n1 = max(1,n);
aninv = 1.f / (real) n1;
if (*nsizes != 1) {
mtypes = min(21,*ntypes);
} else {
mtypes = min(22,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L250;
}
++nmats;
ntest = 0;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Initialize RESULT */
for (j = 1; j <= 14; ++j) {
result[j] = 0.f;
/* L30: */
}
/* Compute "A" */
/* Control parameters: */
/* KMAGN KCONDS KMODE KTYPE */
/* =1 O(1) 1 clustered 1 zero */
/* =2 large large clustered 2 identity */
/* =3 small exponential Jordan */
/* =4 arithmetic diagonal, (w/ eigenvalues) */
/* =5 random log hermitian, w/ eigenvalues */
/* =6 random general, w/ eigenvalues */
/* =7 random diagonal */
/* =8 random hermitian */
/* =9 random general */
/* =10 random triangular */
if (mtypes > 21) {
goto L100;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L40;
case 2: goto L50;
case 3: goto L60;
}
L40:
anorm = 1.f;
goto L70;
L50:
anorm = rtovfl * ulp * aninv;
goto L70;
L60:
anorm = rtunfl * n * ulpinv;
goto L70;
L70:
claset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
/* Special Matrices */
if (itype == 1) {
/* Zero */
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
a[i__4].r = anorm, a[i__4].i = 0.f;
/* L80: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
i__4 = jcol + jcol * a_dim1;
a[i__4].r = anorm, a[i__4].i = 0.f;
if (jcol > 1) {
i__4 = jcol + (jcol - 1) * a_dim1;
a[i__4].r = 1.f, a[i__4].i = 0.f;
}
/* L90: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &imode, &cond,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &c__0, &
c__0, &c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 5) {
/* Hermitian, eigenvalues specified */
clatms_(&n, &n, "D", &iseed[1], "H", &rwork[1], &imode, &cond,
&anorm, &n, &n, "N", &a[a_offset], lda, &work[1], &
iinfo);
} else if (itype == 6) {
/* General, eigenvalues specified */
if (kconds[jtype - 1] == 1) {
conds = 1.f;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.f;
}
clatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2,
" ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n,
&anorm, &a[a_offset], lda, &work[n + 1], &iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &c__0, &
c__0, &c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 8) {
/* Hermitian, random eigenvalues */
clatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &n, &
c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &n, &
c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 10) {
/* Triangular, random eigenvalues */
clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
&c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &c__0, &
c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___35.ciunit = *nounit;
s_wsfe(&io___35);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L100:
/* Call CGEHRD to compute H and U, do tests. */
clacpy_(" ", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
ntest = 1;
ilo = 1;
ihi = n;
i__3 = *nwork - n;
cgehrd_(&n, &ilo, &ihi, &h__[h_offset], lda, &work[1], &work[n +
1], &i__3, &iinfo);
if (iinfo != 0) {
result[1] = ulpinv;
io___38.ciunit = *nounit;
s_wsfe(&io___38);
do_fio(&c__1, "CGEHRD", (ftnlen)6);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
i__3 = n - 1;
for (j = 1; j <= i__3; ++j) {
i__4 = j + 1 + j * uu_dim1;
uu[i__4].r = 0.f, uu[i__4].i = 0.f;
i__4 = n;
for (i__ = j + 2; i__ <= i__4; ++i__) {
i__5 = i__ + j * u_dim1;
i__6 = i__ + j * h_dim1;
u[i__5].r = h__[i__6].r, u[i__5].i = h__[i__6].i;
i__5 = i__ + j * uu_dim1;
i__6 = i__ + j * h_dim1;
uu[i__5].r = h__[i__6].r, uu[i__5].i = h__[i__6].i;
i__5 = i__ + j * h_dim1;
h__[i__5].r = 0.f, h__[i__5].i = 0.f;
/* L110: */
}
/* L120: */
}
i__3 = n - 1;
ccopy_(&i__3, &work[1], &c__1, &tau[1], &c__1);
i__3 = *nwork - n;
cunghr_(&n, &ilo, &ihi, &u[u_offset], ldu, &work[1], &work[n + 1],
&i__3, &iinfo);
ntest = 2;
chst01_(&n, &ilo, &ihi, &a[a_offset], lda, &h__[h_offset], lda, &
u[u_offset], ldu, &work[1], nwork, &rwork[1], &result[1]);
/* Call CHSEQR to compute T1, T2 and Z, do tests. */
/* Eigenvalues only (W3) */
clacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
ntest = 3;
result[3] = ulpinv;
chseqr_("E", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &w3[1], &
uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0) {
io___40.ciunit = *nounit;
s_wsfe(&io___40);
do_fio(&c__1, "CHSEQR(E)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
if (iinfo <= n + 2) {
*info = abs(iinfo);
goto L240;
}
}
/* Eigenvalues (W1) and Full Schur Form (T2) */
clacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
chseqr_("S", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &w1[1], &
uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0 && iinfo <= n + 2) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, "CHSEQR(S)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
/* Eigenvalues (W1), Schur Form (T1), and Schur Vectors (UZ) */
clacpy_(" ", &n, &n, &h__[h_offset], lda, &t1[t1_offset], lda);
clacpy_(" ", &n, &n, &u[u_offset], ldu, &uz[uz_offset], ldu);
chseqr_("S", "V", &n, &ilo, &ihi, &t1[t1_offset], lda, &w1[1], &
uz[uz_offset], ldu, &work[1], nwork, &iinfo);
if (iinfo != 0 && iinfo <= n + 2) {
io___42.ciunit = *nounit;
s_wsfe(&io___42);
do_fio(&c__1, "CHSEQR(V)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
/* Compute Z = U' UZ */
cgemm_("C", "N", &n, &n, &n, &c_b2, &u[u_offset], ldu, &uz[
uz_offset], ldu, &c_b1, &z__[z_offset], ldu);
ntest = 8;
/* Do Tests 3: | H - Z T Z' | / ( |H| n ulp ) */
/* and 4: | I - Z Z' | / ( n ulp ) */
chst01_(&n, &ilo, &ihi, &h__[h_offset], lda, &t1[t1_offset], lda,
&z__[z_offset], ldu, &work[1], nwork, &rwork[1], &result[
3]);
/* Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp ) */
/* and 6: | I - UZ (UZ)' | / ( n ulp ) */
chst01_(&n, &ilo, &ihi, &a[a_offset], lda, &t1[t1_offset], lda, &
uz[uz_offset], ldu, &work[1], nwork, &rwork[1], &result[5]
);
/* Do Test 7: | T2 - T1 | / ( |T| n ulp ) */
cget10_(&n, &n, &t2[t2_offset], lda, &t1[t1_offset], lda, &work[1]
, &rwork[1], &result[7]);
/* Do Test 8: | W3 - W1 | / ( max(|W1|,|W3|) ulp ) */
temp1 = 0.f;
temp2 = 0.f;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
/* Computing MAX */
r__1 = temp1, r__2 = c_abs(&w1[j]), r__1 = max(r__1,r__2),
r__2 = c_abs(&w3[j]);
temp1 = dmax(r__1,r__2);
/* Computing MAX */
i__4 = j;
i__5 = j;
q__1.r = w1[i__4].r - w3[i__5].r, q__1.i = w1[i__4].i - w3[
i__5].i;
r__1 = temp2, r__2 = c_abs(&q__1);
temp2 = dmax(r__1,r__2);
/* L130: */
}
/* Computing MAX */
r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
result[8] = temp2 / dmax(r__1,r__2);
/* Compute the Left and Right Eigenvectors of T */
/* Compute the Right eigenvector Matrix: */
ntest = 9;
result[9] = ulpinv;
/* Select every other eigenvector */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
select[j] = FALSE_;
/* L140: */
}
i__3 = n;
for (j = 1; j <= i__3; j += 2) {
select[j] = TRUE_;
/* L150: */
}
ctrevc_("Right", "All", &select[1], &n, &t1[t1_offset], lda,
cdumma, ldu, &evectr[evectr_offset], ldu, &n, &in, &work[
1], &rwork[1], &iinfo);
if (iinfo != 0) {
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, "CTREVC(R,A)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
/* Test 9: | TR - RW | / ( |T| |R| ulp ) */
cget22_("N", "N", "N", &n, &t1[t1_offset], lda, &evectr[
evectr_offset], ldu, &w1[1], &work[1], &rwork[1], dumma);
result[9] = dumma[0];
if (dumma[1] > *thresh) {
io___49.ciunit = *nounit;
s_wsfe(&io___49);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "CTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute selected right eigenvectors and confirm that */
/* they agree with previous right eigenvectors */
ctrevc_("Right", "Some", &select[1], &n, &t1[t1_offset], lda,
cdumma, ldu, &evectl[evectl_offset], ldu, &n, &in, &work[
1], &rwork[1], &iinfo);
if (iinfo != 0) {
io___50.ciunit = *nounit;
s_wsfe(&io___50);
do_fio(&c__1, "CTREVC(R,S)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
k = 1;
match = TRUE_;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
if (select[j]) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
i__5 = jj + j * evectr_dim1;
i__6 = jj + k * evectl_dim1;
if (evectr[i__5].r != evectl[i__6].r || evectr[i__5]
.i != evectl[i__6].i) {
match = FALSE_;
goto L180;
}
/* L160: */
}
++k;
}
/* L170: */
}
L180:
if (! match) {
io___54.ciunit = *nounit;
s_wsfe(&io___54);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "CTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute the Left eigenvector Matrix: */
ntest = 10;
result[10] = ulpinv;
ctrevc_("Left", "All", &select[1], &n, &t1[t1_offset], lda, &
evectl[evectl_offset], ldu, cdumma, ldu, &n, &in, &work[1]
, &rwork[1], &iinfo);
if (iinfo != 0) {
io___55.ciunit = *nounit;
s_wsfe(&io___55);
do_fio(&c__1, "CTREVC(L,A)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
/* Test 10: | LT - WL | / ( |T| |L| ulp ) */
cget22_("C", "N", "C", &n, &t1[t1_offset], lda, &evectl[
evectl_offset], ldu, &w1[1], &work[1], &rwork[1], &dumma[
2]);
result[10] = dumma[2];
if (dumma[3] > *thresh) {
io___56.ciunit = *nounit;
s_wsfe(&io___56);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "CTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Compute selected left eigenvectors and confirm that */
/* they agree with previous left eigenvectors */
ctrevc_("Left", "Some", &select[1], &n, &t1[t1_offset], lda, &
evectr[evectr_offset], ldu, cdumma, ldu, &n, &in, &work[1]
, &rwork[1], &iinfo);
if (iinfo != 0) {
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, "CTREVC(L,S)", (ftnlen)11);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L240;
}
k = 1;
match = TRUE_;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
if (select[j]) {
i__4 = n;
for (jj = 1; jj <= i__4; ++jj) {
i__5 = jj + j * evectl_dim1;
i__6 = jj + k * evectr_dim1;
if (evectl[i__5].r != evectr[i__6].r || evectl[i__5]
.i != evectr[i__6].i) {
match = FALSE_;
goto L210;
}
/* L190: */
}
++k;
}
/* L200: */
}
L210:
if (! match) {
io___58.ciunit = *nounit;
s_wsfe(&io___58);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "CTREVC", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Call CHSEIN for Right eigenvectors of H, do test 11 */
ntest = 11;
result[11] = ulpinv;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
select[j] = TRUE_;
/* L220: */
}
chsein_("Right", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
lda, &w3[1], cdumma, ldu, &evectx[evectx_offset], ldu, &
n1, &in, &work[1], &rwork[1], &iwork[1], &iwork[1], &
iinfo);
if (iinfo != 0) {
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, "CHSEIN(R)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L240;
}
} else {
/* Test 11: | HX - XW | / ( |H| |X| ulp ) */
/* (from inverse iteration) */
cget22_("N", "N", "N", &n, &h__[h_offset], lda, &evectx[
evectx_offset], ldu, &w3[1], &work[1], &rwork[1],
dumma);
if (dumma[0] < ulpinv) {
result[11] = dumma[0] * aninv;
}
if (dumma[1] > *thresh) {
io___60.ciunit = *nounit;
s_wsfe(&io___60);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "CHSEIN", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
}
}
/* Call CHSEIN for Left eigenvectors of H, do test 12 */
ntest = 12;
result[12] = ulpinv;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
select[j] = TRUE_;
/* L230: */
}
chsein_("Left", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
lda, &w3[1], &evecty[evecty_offset], ldu, cdumma, ldu, &
n1, &in, &work[1], &rwork[1], &iwork[1], &iwork[1], &
iinfo);
if (iinfo != 0) {
io___61.ciunit = *nounit;
s_wsfe(&io___61);
do_fio(&c__1, "CHSEIN(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L240;
}
} else {
/* Test 12: | YH - WY | / ( |H| |Y| ulp ) */
/* (from inverse iteration) */
cget22_("C", "N", "C", &n, &h__[h_offset], lda, &evecty[
evecty_offset], ldu, &w3[1], &work[1], &rwork[1], &
dumma[2]);
if (dumma[2] < ulpinv) {
result[12] = dumma[2] * aninv;
}
if (dumma[3] > *thresh) {
io___62.ciunit = *nounit;
s_wsfe(&io___62);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "CHSEIN", (ftnlen)6);
do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
}
}
/* Call CUNMHR for Right eigenvectors of A, do test 13 */
ntest = 13;
result[13] = ulpinv;
cunmhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
, ldu, &tau[1], &evectx[evectx_offset], ldu, &work[1],
nwork, &iinfo);
if (iinfo != 0) {
io___63.ciunit = *nounit;
s_wsfe(&io___63);
do_fio(&c__1, "CUNMHR(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L240;
}
} else {
/* Test 13: | AX - XW | / ( |A| |X| ulp ) */
/* (from inverse iteration) */
cget22_("N", "N", "N", &n, &a[a_offset], lda, &evectx[
evectx_offset], ldu, &w3[1], &work[1], &rwork[1],
dumma);
if (dumma[0] < ulpinv) {
result[13] = dumma[0] * aninv;
}
}
/* Call CUNMHR for Left eigenvectors of A, do test 14 */
ntest = 14;
result[14] = ulpinv;
cunmhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
, ldu, &tau[1], &evecty[evecty_offset], ldu, &work[1],
nwork, &iinfo);
if (iinfo != 0) {
io___64.ciunit = *nounit;
s_wsfe(&io___64);
do_fio(&c__1, "CUNMHR(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
goto L240;
}
} else {
/* Test 14: | YA - WY | / ( |A| |Y| ulp ) */
/* (from inverse iteration) */
cget22_("C", "N", "C", &n, &a[a_offset], lda, &evecty[
evecty_offset], ldu, &w3[1], &work[1], &rwork[1], &
dumma[2]);
if (dumma[2] < ulpinv) {
result[14] = dumma[2] * aninv;
}
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L240:
ntestt += ntest;
slafts_("CHS", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh,
nounit, &nerrs);
L250:
;
}
/* L260: */
}
/* Summary */
slasum_("CHS", nounit, &nerrs, &ntestt);
return 0;
/* End of CCHKHS */
} /* cchkhs_ */
/* Subroutine */ int slasq3_(integer *i0, integer *n0, real *z__, integer *pp,
real *dmin__, real *sigma, real *desig, real *qmax, integer *nfail,
integer *iter, integer *ndiv, logical *ieee, integer *ttype, real *
dmin1, real *dmin2, real *dn, real *dn1, real *dn2, real *g, real *
tau)
{
/* System generated locals */
integer i__1;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
real s, t;
integer j4, nn;
real eps, tol;
integer n0in, ipn4;
real tol2, temp;
extern /* Subroutine */ int slasq4_(integer *, integer *, real *, integer
*, integer *, real *, real *, real *, real *, real *, real *,
real *, integer *, real *), slasq5_(integer *, integer *, real *,
integer *, real *, real *, real *, real *, real *, real *, real *,
logical *), slasq6_(integer *, integer *, real *, integer *,
real *, real *, real *, real *, real *, real *);
extern doublereal slamch_(char *);
extern logical sisnan_(real *);
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
/* -- Berkeley -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLASQ3 checks for deflation, computes a shift (TAU) and calls dqds. */
/* In case of failure it changes shifts, and tries again until output */
/* is positive. */
/* Arguments */
/* ========= */
/* I0 (input) INTEGER */
/* First index. */
/* N0 (input) INTEGER */
/* Last index. */
/* Z (input) REAL array, dimension ( 4*N ) */
/* Z holds the qd array. */
/* PP (input/output) INTEGER */
/* PP=0 for ping, PP=1 for pong. */
/* PP=2 indicates that flipping was applied to the Z array */
/* and that the initial tests for deflation should not be */
/* performed. */
/* DMIN (output) REAL */
/* Minimum value of d. */
/* SIGMA (output) REAL */
/* Sum of shifts used in current segment. */
/* DESIG (input/output) REAL */
/* Lower order part of SIGMA */
/* QMAX (input) REAL */
/* Maximum value of q. */
/* NFAIL (output) INTEGER */
/* Number of times shift was too big. */
/* ITER (output) INTEGER */
/* Number of iterations. */
/* NDIV (output) INTEGER */
/* Number of divisions. */
/* IEEE (input) LOGICAL */
/* Flag for IEEE or non IEEE arithmetic (passed to SLASQ5). */
/* TTYPE (input/output) INTEGER */
/* Shift type. */
/* DMIN1, DMIN2, DN, DN1, DN2, G, TAU (input/output) REAL */
/* These are passed as arguments in order to save their values */
/* between calls to SLASQ3. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Function .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--z__;
/* Function Body */
n0in = *n0;
eps = slamch_("Precision");
tol = eps * 100.f;
/* Computing 2nd power */
r__1 = tol;
tol2 = r__1 * r__1;
/* Check for deflation. */
L10:
if (*n0 < *i0) {
return 0;
}
if (*n0 == *i0) {
goto L20;
}
nn = (*n0 << 2) + *pp;
if (*n0 == *i0 + 1) {
goto L40;
}
/* Check whether E(N0-1) is negligible, 1 eigenvalue. */
if (z__[nn - 5] > tol2 * (*sigma + z__[nn - 3]) && z__[nn - (*pp << 1) -
4] > tol2 * z__[nn - 7]) {
goto L30;
}
L20:
z__[(*n0 << 2) - 3] = z__[(*n0 << 2) + *pp - 3] + *sigma;
--(*n0);
goto L10;
/* Check whether E(N0-2) is negligible, 2 eigenvalues. */
L30:
if (z__[nn - 9] > tol2 * *sigma && z__[nn - (*pp << 1) - 8] > tol2 * z__[
nn - 11]) {
goto L50;
}
L40:
if (z__[nn - 3] > z__[nn - 7]) {
s = z__[nn - 3];
z__[nn - 3] = z__[nn - 7];
z__[nn - 7] = s;
}
if (z__[nn - 5] > z__[nn - 3] * tol2) {
t = (z__[nn - 7] - z__[nn - 3] + z__[nn - 5]) * .5f;
s = z__[nn - 3] * (z__[nn - 5] / t);
if (s <= t) {
s = z__[nn - 3] * (z__[nn - 5] / (t * (sqrt(s / t + 1.f) + 1.f)));
} else {
s = z__[nn - 3] * (z__[nn - 5] / (t + sqrt(t) * sqrt(t + s)));
}
t = z__[nn - 7] + (s + z__[nn - 5]);
z__[nn - 3] *= z__[nn - 7] / t;
z__[nn - 7] = t;
}
z__[(*n0 << 2) - 7] = z__[nn - 7] + *sigma;
z__[(*n0 << 2) - 3] = z__[nn - 3] + *sigma;
*n0 += -2;
goto L10;
L50:
if (*pp == 2) {
*pp = 0;
}
/* Reverse the qd-array, if warranted. */
if (*dmin__ <= 0.f || *n0 < n0in) {
if (z__[(*i0 << 2) + *pp - 3] * 1.5f < z__[(*n0 << 2) + *pp - 3]) {
ipn4 = *i0 + *n0 << 2;
i__1 = *i0 + *n0 - 1 << 1;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
temp = z__[j4 - 3];
z__[j4 - 3] = z__[ipn4 - j4 - 3];
z__[ipn4 - j4 - 3] = temp;
temp = z__[j4 - 2];
z__[j4 - 2] = z__[ipn4 - j4 - 2];
z__[ipn4 - j4 - 2] = temp;
temp = z__[j4 - 1];
z__[j4 - 1] = z__[ipn4 - j4 - 5];
z__[ipn4 - j4 - 5] = temp;
temp = z__[j4];
z__[j4] = z__[ipn4 - j4 - 4];
z__[ipn4 - j4 - 4] = temp;
/* L60: */
}
if (*n0 - *i0 <= 4) {
z__[(*n0 << 2) + *pp - 1] = z__[(*i0 << 2) + *pp - 1];
z__[(*n0 << 2) - *pp] = z__[(*i0 << 2) - *pp];
}
/* Computing MIN */
r__1 = *dmin2, r__2 = z__[(*n0 << 2) + *pp - 1];
*dmin2 = dmin(r__1,r__2);
/* Computing MIN */
r__1 = z__[(*n0 << 2) + *pp - 1], r__2 = z__[(*i0 << 2) + *pp - 1]
, r__1 = min(r__1,r__2), r__2 = z__[(*i0 << 2) + *pp + 3];
z__[(*n0 << 2) + *pp - 1] = dmin(r__1,r__2);
/* Computing MIN */
r__1 = z__[(*n0 << 2) - *pp], r__2 = z__[(*i0 << 2) - *pp], r__1 =
min(r__1,r__2), r__2 = z__[(*i0 << 2) - *pp + 4];
z__[(*n0 << 2) - *pp] = dmin(r__1,r__2);
/* Computing MAX */
r__1 = *qmax, r__2 = z__[(*i0 << 2) + *pp - 3], r__1 = max(r__1,
r__2), r__2 = z__[(*i0 << 2) + *pp + 1];
*qmax = dmax(r__1,r__2);
*dmin__ = -0.f;
}
}
/* Choose a shift. */
slasq4_(i0, n0, &z__[1], pp, &n0in, dmin__, dmin1, dmin2, dn, dn1, dn2,
tau, ttype, g);
/* Call dqds until DMIN > 0. */
L70:
slasq5_(i0, n0, &z__[1], pp, tau, dmin__, dmin1, dmin2, dn, dn1, dn2,
ieee);
*ndiv += *n0 - *i0 + 2;
++(*iter);
/* Check status. */
if (*dmin__ >= 0.f && *dmin1 > 0.f) {
/* Success. */
goto L90;
} else if (*dmin__ < 0.f && *dmin1 > 0.f && z__[(*n0 - 1 << 2) - *pp] <
tol * (*sigma + *dn1) && dabs(*dn) < tol * *sigma) {
/* Convergence hidden by negative DN. */
z__[(*n0 - 1 << 2) - *pp + 2] = 0.f;
*dmin__ = 0.f;
goto L90;
} else if (*dmin__ < 0.f) {
/* TAU too big. Select new TAU and try again. */
++(*nfail);
if (*ttype < -22) {
/* Failed twice. Play it safe. */
*tau = 0.f;
} else if (*dmin1 > 0.f) {
/* Late failure. Gives excellent shift. */
*tau = (*tau + *dmin__) * (1.f - eps * 2.f);
*ttype += -11;
} else {
/* Early failure. Divide by 4. */
*tau *= .25f;
*ttype += -12;
}
goto L70;
} else if (sisnan_(dmin__)) {
/* NaN. */
if (*tau == 0.f) {
goto L80;
} else {
*tau = 0.f;
goto L70;
}
} else {
/* Possible underflow. Play it safe. */
goto L80;
}
/* Risk of underflow. */
L80:
slasq6_(i0, n0, &z__[1], pp, dmin__, dmin1, dmin2, dn, dn1, dn2);
*ndiv += *n0 - *i0 + 2;
++(*iter);
*tau = 0.f;
L90:
if (*tau < *sigma) {
*desig += *tau;
t = *sigma + *desig;
*desig -= t - *sigma;
} else {
t = *sigma + *tau;
*desig = *sigma - (t - *tau) + *desig;
}
*sigma = t;
return 0;
/* End of SLASQ3 */
} /* slasq3_ */
/* Subroutine */ int cla_lin_berr__(integer *n, integer *nz, integer *nrhs,
complex *res, real *ayb, real *berr)
{
/* System generated locals */
integer ayb_dim1, ayb_offset, res_dim1, res_offset, i__1, i__2, i__3,
i__4;
real r__1, r__2, r__3;
complex q__1, q__2, q__3;
/* Local variables */
integer i__, j;
real tmp, safe1;
/* -- LAPACK routine (version 3.2.1) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- April 2009 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* Purpose */
/* ======= */
/* CLA_LIN_BERR computes componentwise relative backward error from */
/* the formula */
/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
/* where abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NZ (input) INTEGER */
/* We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to */
/* guard against spuriously zero residuals. Default value is N. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices AYB, RES, and BERR. NRHS >= 0. */
/* RES (input) DOUBLE PRECISION array, dimension (N,NRHS) */
/* The residual matrix, i.e., the matrix R in the relative backward */
/* error formula above. */
/* AYB (input) DOUBLE PRECISION array, dimension (N, NRHS) */
/* The denominator in the relative backward error formula above, i.e., */
/* the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B */
/* are from iterative refinement (see cla_gerfsx_extended.f). */
/* RES (output) COMPLEX array, dimension (NRHS) */
/* The componentwise relative backward error from the formula above. */
/* ===================================================================== */
/* Adding SAFE1 to the numerator guards against spuriously zero */
/* residuals. A similar safeguard is in the CLA_yyAMV routine used */
/* to compute AYB. */
/* Parameter adjustments */
--berr;
ayb_dim1 = *n;
ayb_offset = 1 + ayb_dim1;
ayb -= ayb_offset;
res_dim1 = *n;
res_offset = 1 + res_dim1;
res -= res_offset;
/* Function Body */
safe1 = slamch_("Safe minimum");
safe1 = (*nz + 1) * safe1;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
berr[j] = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (ayb[i__ + j * ayb_dim1] != 0.f) {
i__3 = i__ + j * res_dim1;
r__3 = (r__1 = res[i__3].r, dabs(r__1)) + (r__2 = r_imag(&res[
i__ + j * res_dim1]), dabs(r__2));
q__3.r = r__3, q__3.i = 0.f;
q__2.r = safe1 + q__3.r, q__2.i = q__3.i;
i__4 = i__ + j * ayb_dim1;
q__1.r = q__2.r / ayb[i__4], q__1.i = q__2.i / ayb[i__4];
tmp = q__1.r;
/* Computing MAX */
r__1 = berr[j];
berr[j] = dmax(r__1,tmp);
}
/* If AYB is exactly 0.0 (and if computed by CLA_yyAMV), then we know */
/* the true residual also must be exactly 0.0. */
}
}
return 0;
} /* cla_lin_berr__ */
/* Subroutine */ int sbdt03_(char *uplo, integer *n, integer *kd, real *d__,
real *e, real *u, integer *ldu, real *s, real *vt, integer *ldvt,
real *work, real *resid)
{
/* System generated locals */
integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2;
real r__1, r__2, r__3, r__4;
/* Local variables */
integer i__, j;
real eps;
real bnorm;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *);
extern doublereal sasum_(integer *, real *, integer *), slamch_(char *);
extern integer isamax_(integer *, real *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SBDT03 reconstructs a bidiagonal matrix B from its SVD: */
/* S = U' * B * V */
/* where U and V are orthogonal matrices and S is diagonal. */
/* The test ratio to test the singular value decomposition is */
/* RESID = norm( B - U * S * VT ) / ( n * norm(B) * EPS ) */
/* where VT = V' and EPS is the machine precision. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix B is upper or lower bidiagonal. */
/* = 'U': Upper bidiagonal */
/* = 'L': Lower bidiagonal */
/* N (input) INTEGER */
/* The order of the matrix B. */
/* KD (input) INTEGER */
/* The bandwidth of the bidiagonal matrix B. If KD = 1, the */
/* matrix B is bidiagonal, and if KD = 0, B is diagonal and E is */
/* not referenced. If KD is greater than 1, it is assumed to be */
/* 1, and if KD is less than 0, it is assumed to be 0. */
/* D (input) REAL array, dimension (N) */
/* The n diagonal elements of the bidiagonal matrix B. */
/* E (input) REAL array, dimension (N-1) */
/* The (n-1) superdiagonal elements of the bidiagonal matrix B */
/* if UPLO = 'U', or the (n-1) subdiagonal elements of B if */
/* UPLO = 'L'. */
/* U (input) REAL array, dimension (LDU,N) */
/* The n by n orthogonal matrix U in the reduction B = U'*A*P. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= max(1,N) */
/* S (input) REAL array, dimension (N) */
/* The singular values from the SVD of B, sorted in decreasing */
/* order. */
/* VT (input) REAL array, dimension (LDVT,N) */
/* The n by n orthogonal matrix V' in the reduction */
/* B = U * S * V'. */
/* LDVT (input) INTEGER */
/* The leading dimension of the array VT. */
/* WORK (workspace) REAL array, dimension (2*N) */
/* RESID (output) REAL */
/* The test ratio: norm(B - U * S * V') / ( n * norm(A) * EPS ) */
/* ====================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
--d__;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
--s;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
--work;
/* Function Body */
*resid = 0.f;
if (*n <= 0) {
return 0;
}
/* Compute B - U * S * V' one column at a time. */
bnorm = 0.f;
if (*kd >= 1) {
/* B is bidiagonal. */
if (lsame_(uplo, "U")) {
/* B is upper bidiagonal. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = s[i__] * vt[i__ + j * vt_dim1];
/* L10: */
}
sgemv_("No transpose", n, n, &c_b6, &u[u_offset], ldu, &work[*
n + 1], &c__1, &c_b8, &work[1], &c__1);
work[j] += d__[j];
if (j > 1) {
work[j - 1] += e[j - 1];
/* Computing MAX */
r__3 = bnorm, r__4 = (r__1 = d__[j], dabs(r__1)) + (r__2 =
e[j - 1], dabs(r__2));
bnorm = dmax(r__3,r__4);
} else {
/* Computing MAX */
r__2 = bnorm, r__3 = (r__1 = d__[j], dabs(r__1));
bnorm = dmax(r__2,r__3);
}
/* Computing MAX */
r__1 = *resid, r__2 = sasum_(n, &work[1], &c__1);
*resid = dmax(r__1,r__2);
/* L20: */
}
} else {
/* B is lower bidiagonal. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = s[i__] * vt[i__ + j * vt_dim1];
/* L30: */
}
sgemv_("No transpose", n, n, &c_b6, &u[u_offset], ldu, &work[*
n + 1], &c__1, &c_b8, &work[1], &c__1);
work[j] += d__[j];
if (j < *n) {
work[j + 1] += e[j];
/* Computing MAX */
r__3 = bnorm, r__4 = (r__1 = d__[j], dabs(r__1)) + (r__2 =
e[j], dabs(r__2));
bnorm = dmax(r__3,r__4);
} else {
/* Computing MAX */
r__2 = bnorm, r__3 = (r__1 = d__[j], dabs(r__1));
bnorm = dmax(r__2,r__3);
}
/* Computing MAX */
r__1 = *resid, r__2 = sasum_(n, &work[1], &c__1);
*resid = dmax(r__1,r__2);
/* L40: */
}
}
} else {
/* B is diagonal. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = s[i__] * vt[i__ + j * vt_dim1];
/* L50: */
}
sgemv_("No transpose", n, n, &c_b6, &u[u_offset], ldu, &work[*n +
1], &c__1, &c_b8, &work[1], &c__1);
work[j] += d__[j];
/* Computing MAX */
r__1 = *resid, r__2 = sasum_(n, &work[1], &c__1);
*resid = dmax(r__1,r__2);
/* L60: */
}
j = isamax_(n, &d__[1], &c__1);
bnorm = (r__1 = d__[j], dabs(r__1));
}
/* Compute norm(B - U * S * V') / ( n * norm(B) * EPS ) */
eps = slamch_("Precision");
if (bnorm <= 0.f) {
if (*resid != 0.f) {
*resid = 1.f / eps;
}
} else {
if (bnorm >= *resid) {
*resid = *resid / bnorm / ((real) (*n) * eps);
} else {
if (bnorm < 1.f) {
/* Computing MIN */
r__1 = *resid, r__2 = (real) (*n) * bnorm;
*resid = dmin(r__1,r__2) / bnorm / ((real) (*n) * eps);
} else {
/* Computing MIN */
r__1 = *resid / bnorm, r__2 = (real) (*n);
*resid = dmin(r__1,r__2) / ((real) (*n) * eps);
}
}
}
return 0;
/* End of SBDT03 */
} /* sbdt03_ */
/* the function below detects particles that have a number of neighbours
* outside the allowed tolerance range. For these, particles the smoothing
* length is adjusted accordingly. Note that the smoothing length is
*/
void sidm_ensure_neighbours(int mode)
{
#define MAXITER 30
int i, ntot, last=0;
float *r2list;
int *ngblist, count, candidates;
int iter=0;
double save;
/*
int IndFirstUpdateBackup, NumForceUpdateBackup;
IndFirstUpdateBackup= IndFirstUpdate;
NumForceUpdateBackup= NumForceUpdate;
for(i=IndFirstUpdate, count=0; count<NumForceUpdate;
i=P[i].ForceFlag, count++){
P[i].ForceFlagBackup= P[i].ForceFlag;
}
*/
for(i=IndFirstUpdate, count=0, candidates=0; count<NumForceUpdate;
i=P[i].ForceFlag, count++) {
if(P[i].Type>0) {
if(P[i].NgbVelDisp < (All.DesNumNgb-All.MaxNumNgbDeviation) ||
(P[i].NgbVelDisp > (All.DesNumNgb+All.MaxNumNgbDeviation)))
candidates++;
}
}
MPI_Reduce(&candidates, &ntot, 1, MPI_INT, MPI_SUM, 0, MPI_COMM_WORLD);
MPI_Bcast(&ntot, 1, MPI_INT, 0, MPI_COMM_WORLD);
if(ntot > 0) {
//#ifdef FINDNBRLOG
// if(ThisTask==0)
//{
//printf("\n%d particles have too few/too many neighbours in sidm calculation!\n", ntot);
// printf("Now fixing that...\n");
// }
//#endif
for(i=IndFirstUpdate, count=0; count<NumForceUpdate;
i=P[i].ForceFlag, count++)
P[i].Left= P[i].Right= 0;
do {
for(i=1+N_gas, NumForceUpdate= 0, NumSphUpdate=0; i<=NumPart; i++) {
if( P[i].NgbVelDisp < (All.DesNumNgb-All.MaxNumNgbDeviation) ||
P[i].NgbVelDisp > (All.DesNumNgb+All.MaxNumNgbDeviation)) {
if(P[i].Left>0 && P[i].Right>0)
if((P[i].Right-P[i].Left) < 1.0e-3 * P[i].Left)
continue;
if(NumForceUpdate==0)
IndFirstUpdate= i;
else
P[last].ForceFlag= i;
NumForceUpdate++;
last=i;
if(P[i].NgbVelDisp < (All.DesNumNgb-All.MaxNumNgbDeviation))
P[i].Left= dmax(P[i].HsmlVelDisp, P[i].Left);
else
if(P[i].Right!=0)
{
if(P[i].HsmlVelDisp<P[i].Right)
P[i].Right= P[i].HsmlVelDisp;
}
else
P[i].Right= P[i].HsmlVelDisp;
}
}
MPI_Allreduce(&NumForceUpdate, &ntot, 1, MPI_INT, MPI_SUM,
MPI_COMM_WORLD);
if(ntot > 0) {
//#ifdef FINDNBRLOG
// if(ThisTask==0)
//printf("ngb iteration %d. still %d particles\n", iter, ntot);
//#endif
for(i=IndFirstUpdate, count=0; count<NumForceUpdate;
i=P[i].ForceFlag, count++) {
if(iter >= 20) {
printf("i=%d ID=%d Hsml=%g Left=%g Right=%g Ngbs=%d Right-Left=%g\n pos=(%g|%g|%g)\n",
i, P[i].ID, P[i].HsmlVelDisp, P[i].Left, P[i].Right,
P[i].NgbVelDisp, P[i].Right-P[i].Left,
P[i].PosPred[0], P[i].PosPred[1], P[i].PosPred[2]);
}
if(iter == MAXITER) {
printf("ThisTask=%d Mi=(%g|%g|%g) Ma=(%g|%g|%g)\n", ThisTask,
DomainMin[P[i].Type][0], DomainMin[P[i].Type][1],
DomainMin[P[i].Type][2], DomainMax[P[i].Type][0],
DomainMax[P[i].Type][1], DomainMax[P[i].Type][2]);
printf("i=%d ID=%d coord=(%g|%g|%g)\n", i, P[i].ID,
P[i].PosPred[0], P[i].PosPred[1], P[i].PosPred[2]);
printf("ngb_treefind= %g\n", sqrt(ngb_treefind(P[i].PosPred ,
All.DesNumNgb, 0, P[i].Type, &ngblist, &r2list)));
}
if(P[i].Left==0 || P[i].Right==0) {
if(P[i].Right==0 && P[i].NgbVelDisp<15 &&
NtypeLocal[P[i].Type]>All.DesNumNgb) {
P[i].HsmlVelDisp= sqrt(ngb_treefind(P[i].PosPred, All.DesNumNgb,
0, P[i].Type, &ngblist, &r2list));
}
else {
P[i].HsmlVelDisp= P[i].HsmlVelDisp*( 0.5 + 0.5*pow(P[i].NgbVelDisp/((double)All.DesNumNgb), -1.0/3));
}
}
else {
P[i].HsmlVelDisp= 0.5*(P[i].Left + P[i].Right);
}
}
sidm();
iter++;
if(iter > MAXITER) {
fprintf(stdout, "failed to converge in function ensure_neighbours()\n");
endrun(1155);
}
}
} while(ntot > 0);
if(mode == 0) { /* restore timeline to active particles */
/*
IndFirstUpdate= IndFirstUpdateBackup;
NumForceUpdate= NumForceUpdateBackup;
for(i=IndFirstUpdateBackup, count=0; count<NumForceUpdateBackup;
i=P[i].ForceFlagBackup, count++){
P[i].ForceFlag= P[i].ForceFlagBackup;
}
*/
save= All.TimeStep;
find_next_time();
All.TimeStep= save;
}
else { /* make all particles active again */
for(i=1; i<=NumPart; i++)
P[i].ForceFlag=i+1;
P[NumPart].ForceFlag=1;
IndFirstUpdate=1;
NumForceUpdate=NumPart;
NumSphUpdate=N_gas;
}
}
#undef MAXITER
}
/* Subroutine */ int clatps_(char *uplo, char *trans, char *diag, char *
normin, integer *n, complex *ap, complex *x, real *scale, real *cnorm,
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
October 31, 1992
Purpose
=======
CLATPS solves one of the triangular systems
A * x = s*b, A**T * x = s*b, or A**H * x = s*b,
with scaling to prevent overflow, where A is an upper or lower
triangular matrix stored in packed form. Here A**T denotes the
transpose of A, A**H denotes the conjugate transpose of A, x and b
are n-element vectors, and s is a scaling factor, usually less than
or equal to 1, chosen so that the components of x will be less than
the overflow threshold. If the unscaled problem will not cause
overflow, the Level 2 BLAS routine CTPSV is called. If the matrix A
is singular (A(j,j) = 0 for some j), then s is set to 0 and a
non-trivial solution to A*x = 0 is returned.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the matrix A is upper or lower triangular.
= 'U': Upper triangular
= 'L': Lower triangular
TRANS (input) CHARACTER*1
Specifies the operation applied to A.
= 'N': Solve A * x = s*b (No transpose)
= 'T': Solve A**T * x = s*b (Transpose)
= 'C': Solve A**H * x = s*b (Conjugate transpose)
DIAG (input) CHARACTER*1
Specifies whether or not the matrix A is unit triangular.
= 'N': Non-unit triangular
= 'U': Unit triangular
NORMIN (input) CHARACTER*1
Specifies whether CNORM has been set or not.
= 'Y': CNORM contains the column norms on entry
= 'N': CNORM is not set on entry. On exit, the norms will
be computed and stored in CNORM.
N (input) INTEGER
The order of the matrix A. N >= 0.
AP (input) COMPLEX array, dimension (N*(N+1)/2)
The upper or lower triangular matrix A, packed columnwise in
a linear array. The j-th column of A is stored in the array
AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
X (input/output) COMPLEX array, dimension (N)
On entry, the right hand side b of the triangular system.
On exit, X is overwritten by the solution vector x.
SCALE (output) REAL
The scaling factor s for the triangular system
A * x = s*b, A**T * x = s*b, or A**H * x = s*b.
If SCALE = 0, the matrix A is singular or badly scaled, and
the vector x is an exact or approximate solution to A*x = 0.
CNORM (input or output) REAL array, dimension (N)
If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
contains the norm of the off-diagonal part of the j-th column
of A. If TRANS = 'N', CNORM(j) must be greater than or equal
to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
must be greater than or equal to the 1-norm.
If NORMIN = 'N', CNORM is an output argument and CNORM(j)
returns the 1-norm of the offdiagonal part of the j-th column
of A.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
Further Details
======= =======
A rough bound on x is computed; if that is less than overflow, CTPSV
is called, otherwise, specific code is used which checks for possible
overflow or divide-by-zero at every operation.
A columnwise scheme is used for solving A*x = b. The basic algorithm
if A is lower triangular is
x[1:n] := b[1:n]
for j = 1, ..., n
x(j) := x(j) / A(j,j)
x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
end
Define bounds on the components of x after j iterations of the loop:
M(j) = bound on x[1:j]
G(j) = bound on x[j+1:n]
Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
Then for iteration j+1 we have
M(j+1) <= G(j) / | A(j+1,j+1) |
G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
<= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
where CNORM(j+1) is greater than or equal to the infinity-norm of
column j+1 of A, not counting the diagonal. Hence
G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
1<=i<=j
and
|x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
1<=i< j
Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTPSV if the
reciprocal of the largest M(j), j=1,..,n, is larger than
max(underflow, 1/overflow).
The bound on x(j) is also used to determine when a step in the
columnwise method can be performed without fear of overflow. If
the computed bound is greater than a large constant, x is scaled to
prevent overflow, but if the bound overflows, x is set to 0, x(j) to
1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
Similarly, a row-wise scheme is used to solve A**T *x = b or
A**H *x = b. The basic algorithm for A upper triangular is
for j = 1, ..., n
x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
end
We simultaneously compute two bounds
G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
M(j) = bound on x(i), 1<=i<=j
The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
Then the bound on x(j) is
M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
<= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
1<=i<=j
and we can safely call CTPSV if 1/M(n) and 1/G(n) are both greater
than max(underflow, 1/overflow).
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static real c_b36 = .5f;
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
static integer jinc, jlen;
static real xbnd;
static integer imax;
static real tmax;
static complex tjjs;
static real xmax, grow;
static integer i__, j;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static real tscal;
static complex uscal;
static integer jlast;
extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
static complex csumj;
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static logical upper;
extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
complex *, complex *, integer *), slabad_(
real *, real *);
static integer ip;
static real xj;
extern integer icamax_(integer *, complex *, integer *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *);
static real bignum;
extern integer isamax_(integer *, real *, integer *);
extern doublereal scasum_(integer *, complex *, integer *);
static logical notran;
static integer jfirst;
static real smlnum;
static logical nounit;
static real rec, tjj;
--cnorm;
--x;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
/* Test the input parameters. */
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (! lsame_(normin, "Y") && ! lsame_(normin,
"N")) {
*info = -4;
} else if (*n < 0) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLATPS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum /= slamch_("Precision");
bignum = 1.f / smlnum;
*scale = 1.f;
if (lsame_(normin, "N")) {
/* Compute the 1-norm of each column, not including the diagonal. */
if (upper) {
/* A is upper triangular. */
ip = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
cnorm[j] = scasum_(&i__2, &ap[ip], &c__1);
ip += j;
/* L10: */
}
} else {
/* A is lower triangular. */
ip = 1;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
cnorm[j] = scasum_(&i__2, &ap[ip + 1], &c__1);
ip = ip + *n - j + 1;
/* L20: */
}
cnorm[*n] = 0.f;
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is
greater than BIGNUM/2. */
imax = isamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum * .5f) {
tscal = 1.f;
} else {
tscal = .5f / (smlnum * tmax);
sscal_(n, &tscal, &cnorm[1], &c__1);
}
/* Compute a bound on the computed solution vector to see if the
Level 2 BLAS routine CTPSV can be used. */
xmax = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j;
r__3 = xmax, r__4 = (r__1 = x[i__2].r / 2.f, dabs(r__1)) + (r__2 =
r_imag(&x[j]) / 2.f, dabs(r__2));
xmax = dmax(r__3,r__4);
/* L30: */
}
xbnd = xmax;
if (notran) {
/* Compute the growth in A * x = b. */
if (upper) {
jfirst = *n;
jlast = 1;
jinc = -1;
} else {
jfirst = 1;
jlast = *n;
jinc = 1;
}
if (tscal != 1.f) {
grow = 0.f;
goto L60;
}
if (nounit) {
/* A is non-unit triangular.
Compute GROW = 1/G(j) and XBND = 1/M(j).
Initially, G(0) = max{x(i), i=1,...,n}. */
grow = .5f / dmax(xbnd,smlnum);
xbnd = grow;
ip = jfirst * (jfirst + 1) / 2;
jlen = *n;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L60;
}
i__3 = ip;
tjjs.r = ap[i__3].r, tjjs.i = ap[i__3].i;
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj >= smlnum) {
/* M(j) = G(j-1) / abs(A(j,j))
Computing MIN */
r__1 = xbnd, r__2 = dmin(1.f,tjj) * grow;
xbnd = dmin(r__1,r__2);
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.f;
}
if (tjj + cnorm[j] >= smlnum) {
/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
grow *= tjj / (tjj + cnorm[j]);
} else {
/* G(j) could overflow, set GROW to 0. */
grow = 0.f;
}
ip += jinc * jlen;
--jlen;
/* L40: */
}
grow = xbnd;
} else {
/* A is unit triangular.
Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
Computing MIN */
r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
grow = dmin(r__1,r__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L60;
}
/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
grow *= 1.f / (cnorm[j] + 1.f);
/* L50: */
}
}
L60:
;
} else {
/* Compute the growth in A**T * x = b or A**H * x = b. */
if (upper) {
jfirst = 1;
jlast = *n;
jinc = 1;
} else {
jfirst = *n;
jlast = 1;
jinc = -1;
}
if (tscal != 1.f) {
grow = 0.f;
goto L90;
}
if (nounit) {
/* A is non-unit triangular.
Compute GROW = 1/G(j) and XBND = 1/M(j).
Initially, M(0) = max{x(i), i=1,...,n}. */
grow = .5f / dmax(xbnd,smlnum);
xbnd = grow;
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
xj = cnorm[j] + 1.f;
/* Computing MIN */
r__1 = grow, r__2 = xbnd / xj;
grow = dmin(r__1,r__2);
i__3 = ip;
tjjs.r = ap[i__3].r, tjjs.i = ap[i__3].i;
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj >= smlnum) {
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
if (xj > tjj) {
xbnd *= tjj / xj;
}
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.f;
}
++jlen;
ip += jinc * jlen;
/* L70: */
}
grow = dmin(grow,xbnd);
} else {
/* A is unit triangular.
Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
Computing MIN */
r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
grow = dmin(r__1,r__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
xj = cnorm[j] + 1.f;
grow /= xj;
/* L80: */
}
}
L90:
;
}
if (grow * tscal > smlnum) {
/* Use the Level 2 BLAS solve if the reciprocal of the bound on
elements of X is not too small. */
ctpsv_(uplo, trans, diag, n, &ap[1], &x[1], &c__1);
} else {
/* Use a Level 1 BLAS solve, scaling intermediate results. */
if (xmax > bignum * .5f) {
/* Scale X so that its components are less than or equal to
BIGNUM in absolute value. */
*scale = bignum * .5f / xmax;
csscal_(n, scale, &x[1], &c__1);
xmax = bignum;
} else {
xmax *= 2.f;
}
if (notran) {
/* Solve A * x = b */
ip = jfirst * (jfirst + 1) / 2;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
if (nounit) {
i__3 = ip;
q__1.r = tscal * ap[i__3].r, q__1.i = tscal * ap[i__3].i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L105;
}
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale x by 1/b(j). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
} else if (tjj > 0.f) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
to avoid overflow when dividing by A(j,j). */
rec = tjj * bignum / xj;
if (cnorm[j] > 1.f) {
/* Scale by 1/CNORM(j) to avoid overflow when
multiplying x(j) times column j. */
rec /= cnorm[j];
}
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
scale = 0, and compute a solution to A*x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L100: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
xj = 1.f;
*scale = 0.f;
xmax = 0.f;
}
L105:
/* Scale x if necessary to avoid overflow when adding a
multiple of column j of A. */
if (xj > 1.f) {
rec = 1.f / xj;
if (cnorm[j] > (bignum - xmax) * rec) {
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5f;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
} else if (xj * cnorm[j] > bignum - xmax) {
/* Scale x by 1/2. */
csscal_(n, &c_b36, &x[1], &c__1);
*scale *= .5f;
}
if (upper) {
if (j > 1) {
/* Compute the update
x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */
i__3 = j - 1;
i__4 = j;
q__2.r = -x[i__4].r, q__2.i = -x[i__4].i;
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
caxpy_(&i__3, &q__1, &ap[ip - j + 1], &c__1, &x[1], &
c__1);
i__3 = j - 1;
i__ = icamax_(&i__3, &x[1], &c__1);
i__3 = i__;
xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__]), dabs(r__2));
}
ip -= j;
} else {
if (j < *n) {
/* Compute the update
x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */
i__3 = *n - j;
i__4 = j;
q__2.r = -x[i__4].r, q__2.i = -x[i__4].i;
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
caxpy_(&i__3, &q__1, &ap[ip + 1], &c__1, &x[j + 1], &
c__1);
i__3 = *n - j;
i__ = j + icamax_(&i__3, &x[j + 1], &c__1);
i__3 = i__;
xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__]), dabs(r__2));
}
ip = ip + *n - j + 1;
}
/* L110: */
}
} else if (lsame_(trans, "T")) {
/* Solve A**T * x = b */
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k).
k<>j */
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
uscal.r = tscal, uscal.i = 0.f;
rec = 1.f / dmax(xmax,1.f);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5f;
if (nounit) {
i__3 = ip;
q__1.r = tscal * ap[i__3].r, q__1.i = tscal * ap[i__3]
.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > 1.f) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1.
Computing MIN */
r__1 = 1.f, r__2 = rec * tjj;
rec = dmin(r__1,r__2);
cladiv_(&q__1, &uscal, &tjjs);
uscal.r = q__1.r, uscal.i = q__1.i;
}
if (rec < 1.f) {
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.f, csumj.i = 0.f;
if (uscal.r == 1.f && uscal.i == 0.f) {
/* If the scaling needed for A in the dot product is 1,
call CDOTU to perform the dot product. */
if (upper) {
i__3 = j - 1;
cdotu_(&q__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], &
c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
} else if (j < *n) {
i__3 = *n - j;
cdotu_(&q__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], &
c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ip - j + i__;
q__3.r = ap[i__4].r * uscal.r - ap[i__4].i *
uscal.i, q__3.i = ap[i__4].r * uscal.i +
ap[i__4].i * uscal.r;
i__5 = i__;
q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i,
q__2.i = q__3.r * x[i__5].i + q__3.i * x[
i__5].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L120: */
}
} else if (j < *n) {
i__3 = *n - j;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ip + i__;
q__3.r = ap[i__4].r * uscal.r - ap[i__4].i *
uscal.i, q__3.i = ap[i__4].r * uscal.i +
ap[i__4].i * uscal.r;
i__5 = j + i__;
q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i,
q__2.i = q__3.r * x[i__5].i + q__3.i * x[
i__5].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L130: */
}
}
}
q__1.r = tscal, q__1.i = 0.f;
if (uscal.r == q__1.r && uscal.i == q__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j)
was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i -
csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
if (nounit) {
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
i__3 = ip;
q__1.r = tscal * ap[i__3].r, q__1.i = tscal * ap[i__3]
.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L145;
}
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else if (tjj > 0.f) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
scale = 0 and compute a solution to A**T *x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L140: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
*scale = 0.f;
xmax = 0.f;
}
L145:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot
product has already been divided by 1/A(j,j). */
i__3 = j;
cladiv_(&q__2, &x[j], &tjjs);
q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
}
/* Computing MAX */
i__3 = j;
r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[j]), dabs(r__2));
xmax = dmax(r__3,r__4);
++jlen;
ip += jinc * jlen;
/* L150: */
}
} else {
/* Solve A**H * x = b */
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k).
k<>j */
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
uscal.r = tscal, uscal.i = 0.f;
rec = 1.f / dmax(xmax,1.f);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5f;
if (nounit) {
r_cnjg(&q__2, &ap[ip]);
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > 1.f) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1.
Computing MIN */
r__1 = 1.f, r__2 = rec * tjj;
rec = dmin(r__1,r__2);
cladiv_(&q__1, &uscal, &tjjs);
uscal.r = q__1.r, uscal.i = q__1.i;
}
if (rec < 1.f) {
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.f, csumj.i = 0.f;
if (uscal.r == 1.f && uscal.i == 0.f) {
/* If the scaling needed for A in the dot product is 1,
call CDOTC to perform the dot product. */
if (upper) {
i__3 = j - 1;
cdotc_(&q__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], &
c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
} else if (j < *n) {
i__3 = *n - j;
cdotc_(&q__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], &
c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
r_cnjg(&q__4, &ap[ip - j + i__]);
q__3.r = q__4.r * uscal.r - q__4.i * uscal.i,
q__3.i = q__4.r * uscal.i + q__4.i *
uscal.r;
i__4 = i__;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
q__2.i = q__3.r * x[i__4].i + q__3.i * x[
i__4].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L160: */
}
} else if (j < *n) {
i__3 = *n - j;
for (i__ = 1; i__ <= i__3; ++i__) {
r_cnjg(&q__4, &ap[ip + i__]);
q__3.r = q__4.r * uscal.r - q__4.i * uscal.i,
q__3.i = q__4.r * uscal.i + q__4.i *
uscal.r;
i__4 = j + i__;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
q__2.i = q__3.r * x[i__4].i + q__3.i * x[
i__4].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L170: */
}
}
}
q__1.r = tscal, q__1.i = 0.f;
if (uscal.r == q__1.r && uscal.i == q__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j)
was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i -
csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
if (nounit) {
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
r_cnjg(&q__2, &ap[ip]);
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L185;
}
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else if (tjj > 0.f) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
scale = 0 and compute a solution to A**H *x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L180: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
*scale = 0.f;
xmax = 0.f;
}
L185:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot
product has already been divided by 1/A(j,j). */
i__3 = j;
cladiv_(&q__2, &x[j], &tjjs);
q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
}
/* Computing MAX */
i__3 = j;
r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[j]), dabs(r__2));
xmax = dmax(r__3,r__4);
++jlen;
ip += jinc * jlen;
/* L190: */
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.f) {
r__1 = 1.f / tscal;
sscal_(n, &r__1, &cnorm[1], &c__1);
}
return 0;
/* End of CLATPS */
} /* clatps_ */
/* Subroutine */ int sget07_(char *trans, integer *n, integer *nrhs, real *a,
integer *lda, real *b, integer *ldb, real *x, integer *ldx, real *
xact, integer *ldxact, real *ferr, real *berr, real *reslts)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
xact_offset, i__1, i__2, i__3;
real r__1, r__2, r__3;
/* Local variables */
static real diff, axbi;
static integer imax;
static real unfl, ovfl;
static integer i__, j, k;
extern logical lsame_(char *, char *);
static real xnorm;
extern doublereal slamch_(char *);
static real errbnd;
extern integer isamax_(integer *, real *, integer *);
static logical notran;
static real eps, tmp;
#define xact_ref(a_1,a_2) xact[(a_2)*xact_dim1 + a_1]
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
SGET07 tests the error bounds from iterative refinement for the
computed solution to a system of equations op(A)*X = B, where A is a
general n by n matrix and op(A) = A or A**T, depending on TRANS.
RESLTS(1) = test of the error bound
= norm(X - XACT) / ( norm(X) * FERR )
A large value is returned if this ratio is not less than one.
RESLTS(2) = residual from the iterative refinement routine
= the maximum of BERR / ( (n+1)*EPS + (*) ), where
(*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
Arguments
=========
TRANS (input) CHARACTER*1
Specifies the form of the system of equations.
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose = Transpose)
N (input) INTEGER
The number of rows of the matrices X and XACT. N >= 0.
NRHS (input) INTEGER
The number of columns of the matrices X and XACT. NRHS >= 0.
A (input) REAL array, dimension (LDA,N)
The original n by n matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input) REAL array, dimension (LDB,NRHS)
The right hand side vectors for the system of linear
equations.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input) REAL array, dimension (LDX,NRHS)
The computed solution vectors. Each vector is stored as a
column of the matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
XACT (input) REAL array, dimension (LDX,NRHS)
The exact solution vectors. Each vector is stored as a
column of the matrix XACT.
LDXACT (input) INTEGER
The leading dimension of the array XACT. LDXACT >= max(1,N).
FERR (input) REAL array, dimension (NRHS)
The estimated forward error bounds for each solution vector
X. If XTRUE is the true solution, FERR bounds the magnitude
of the largest entry in (X - XTRUE) divided by the magnitude
of the largest entry in X.
BERR (input) REAL array, dimension (NRHS)
The componentwise relative backward error of each solution
vector (i.e., the smallest relative change in any entry of A
or B that makes X an exact solution).
RESLTS (output) REAL array, dimension (2)
The maximum over the NRHS solution vectors of the ratios:
RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
=====================================================================
Quick exit if N = 0 or NRHS = 0.
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1 * 1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.f;
reslts[2] = 0.f;
return 0;
}
eps = slamch_("Epsilon");
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
notran = lsame_(trans, "N");
/* Test 1: Compute the maximum of
norm(X - XACT) / ( norm(X) * FERR )
over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = isamax_(n, &x_ref(1, j), &c__1);
/* Computing MAX */
r__2 = (r__1 = x_ref(imax, j), dabs(r__1));
xnorm = dmax(r__2,unfl);
diff = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = diff, r__3 = (r__1 = x_ref(i__, j) - xact_ref(i__, j),
dabs(r__1));
diff = dmax(r__2,r__3);
/* L10: */
}
if (xnorm > 1.f) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1.f / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
errbnd = dmax(r__1,r__2);
} else {
errbnd = 1.f / eps;
}
L30:
;
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where
(*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
i__1 = *nrhs;
for (k = 1; k <= i__1; ++k) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
tmp = (r__1 = b_ref(i__, k), dabs(r__1));
if (notran) {
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
tmp += (r__1 = a_ref(i__, j), dabs(r__1)) * (r__2 = x_ref(
j, k), dabs(r__2));
/* L40: */
}
} else {
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
tmp += (r__1 = a_ref(j, i__), dabs(r__1)) * (r__2 = x_ref(
j, k), dabs(r__2));
/* L50: */
}
}
if (i__ == 1) {
axbi = tmp;
} else {
axbi = dmin(axbi,tmp);
}
/* L60: */
}
/* Computing MAX */
r__1 = axbi, r__2 = (*n + 1) * unfl;
tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / dmax(r__1,r__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = dmax(reslts[2],tmp);
}
/* L70: */
}
return 0;
/* End of SGET07 */
} /* sget07_ */
/* Subroutine */ int sstebz_(char *range, char *order, integer *n, real *vl,
real *vu, integer *il, integer *iu, real *abstol, real *d, real *e,
integer *m, integer *nsplit, real *w, integer *iblock, integer *
isplit, real *work, integer *iwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SSTEBZ computes the eigenvalues of a symmetric tridiagonal
matrix T. The user may ask for all eigenvalues, all eigenvalues
in the half-open interval (VL, VU], or the IL-th through IU-th
eigenvalues.
To avoid overflow, the matrix must be scaled so that its
largest element is no greater than overflow**(1/2) *
underflow**(1/4) in absolute value, and for greatest
accuracy, it should not be much smaller than that.
See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
VISMatrix", Report CS41, Computer Science Dept., Stanford
University, July 21, 1966.
Arguments
=========
RANGE (input) CHARACTER
= 'A': ("All") all eigenvalues will be found.
= 'V': ("Value") all eigenvalues in the half-open interval
(VL, VU] will be found.
= 'I': ("Index") the IL-th through IU-th eigenvalues (of the
entire matrix) will be found.
ORDER (input) CHARACTER
= 'B': ("By Block") the eigenvalues will be grouped by
split-off block (see IBLOCK, ISPLIT) and
ordered from smallest to largest within
the block.
= 'E': ("Entire matrix")
the eigenvalues for the entire matrix
will be ordered from smallest to
largest.
N (input) INTEGER
The order of the tridiagonal matrix T. N >= 0.
VL (input) REAL
VU (input) REAL
If RANGE='V', the lower and upper bounds of the interval to
be searched for eigenvalues. Eigenvalues less than or equal
to VL, or greater than VU, will not be returned. VL < VU.
Not referenced if RANGE = 'A' or 'I'.
IL (input) INTEGER
IU (input) INTEGER
If RANGE='I', the indices (in ascending order) of the
smallest and largest eigenvalues to be returned.
1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
Not referenced if RANGE = 'A' or 'V'.
ABSTOL (input) REAL
The absolute tolerance for the eigenvalues. An eigenvalue
(or cluster) is considered to be located if it has been
determined to lie in an interval whose width is ABSTOL or
less. If ABSTOL is less than or equal to zero, then ULP*|T|
will be used, where |T| means the 1-norm of T.
Eigenvalues will be computed most accurately when ABSTOL is
set to twice the underflow threshold 2*SLAMCH('S'), not zero.
D (input) REAL array, dimension (N)
The n diagonal elements of the tridiagonal matrix T.
E (input) REAL array, dimension (N-1)
The (n-1) off-diagonal elements of the tridiagonal matrix T.
M (output) INTEGER
The actual number of eigenvalues found. 0 <= M <= N.
(See also the description of INFO=2,3.)
NSPLIT (output) INTEGER
The number of diagonal blocks in the matrix T.
1 <= NSPLIT <= N.
W (output) REAL array, dimension (N)
On exit, the first M elements of W will contain the
eigenvalues. (SSTEBZ may use the remaining N-M elements as
workspace.)
IBLOCK (output) INTEGER array, dimension (N)
At each row/column j where E(j) is zero or small, the
matrix T is considered to split into a block diagonal
matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which
block (from 1 to the number of blocks) the eigenvalue W(i)
belongs. (SSTEBZ may use the remaining N-M elements as
workspace.)
ISPLIT (output) INTEGER array, dimension (N)
The splitting points, at which T breaks up into submatrices.
The first submatrix consists of rows/columns 1 to ISPLIT(1),
the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
etc., and the NSPLIT-th consists of rows/columns
ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
(Only the first NSPLIT elements will actually be used, but
since the user cannot know a priori what value NSPLIT will
have, N words must be reserved for ISPLIT.)
WORK (workspace) REAL array, dimension (4*N)
IWORK (workspace) INTEGER array, dimension (3*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: some or all of the eigenvalues failed to converge or
were not computed:
=1 or 3: Bisection failed to converge for some
eigenvalues; these eigenvalues are flagged by a
negative block number. The effect is that the
eigenvalues may not be as accurate as the
absolute and relative tolerances. This is
generally caused by unexpectedly inaccurate
arithmetic.
=2 or 3: RANGE='I' only: Not all of the eigenvalues
IL:IU were found.
Effect: M < IU+1-IL
Cause: non-monotonic arithmetic, causing the
Sturm sequence to be non-monotonic.
Cure: recalculate, using RANGE='A', and pick
out eigenvalues IL:IU. In some cases,
increasing the PARAMETER "FUDGE" may
make things work.
= 4: RANGE='I', and the Gershgorin interval
initially used was too small. No eigenvalues
were computed.
Probable cause: your machine has sloppy
floating-point arithmetic.
Cure: Increase the PARAMETER "FUDGE",
recompile, and try again.
Internal Parameters
===================
RELFAC REAL, default = 2.0e0
The relative tolerance. An interval (a,b] lies within
"relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|),
where "ulp" is the machine precision (distance from 1 to
the next larger floating point number.)
FUDGE REAL, default = 2
A "fudge factor" to widen the Gershgorin intervals. Ideally,
a value of 1 should work, but on machines with sloppy
arithmetic, this needs to be larger. The default for
publicly released versions should be large enough to handle
the worst machine around. Note that this has no effect
on accuracy of the solution.
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__3 = 3;
static integer c__2 = 2;
static integer c__0 = 0;
/* System generated locals */
integer i__1, i__2, i__3;
real r__1, r__2, r__3, r__4, r__5;
/* Builtin functions */
double sqrt(doublereal), log(doublereal);
/* Local variables */
static integer iend, ioff, iout, itmp1, j, jdisc;
extern logical lsame_(char *, char *);
static integer iinfo;
static real atoli;
static integer iwoff;
static real bnorm;
static integer itmax;
static real wkill, rtoli, tnorm;
static integer ib, jb, ie, je, nb;
static real gl;
static integer im, in, ibegin;
static real gu;
static integer iw;
static real wl;
static integer irange, idiscl;
extern doublereal slamch_(char *);
static real safemn, wu;
static integer idumma[1];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *);
static integer idiscu;
extern /* Subroutine */ int slaebz_(integer *, integer *, integer *,
integer *, integer *, integer *, real *, real *, real *, real *,
real *, real *, integer *, real *, real *, integer *, integer *,
real *, integer *, integer *);
static integer iorder;
static logical ncnvrg;
static real pivmin;
static logical toofew;
static integer nwl;
static real ulp, wlu, wul;
static integer nwu;
static real tmp1, tmp2;
#define IDUMMA(I) idumma[(I)]
#define IWORK(I) iwork[(I)-1]
#define WORK(I) work[(I)-1]
#define ISPLIT(I) isplit[(I)-1]
#define IBLOCK(I) iblock[(I)-1]
#define W(I) w[(I)-1]
#define E(I) e[(I)-1]
#define D(I) d[(I)-1]
*info = 0;
/* Decode RANGE */
if (lsame_(range, "A")) {
irange = 1;
} else if (lsame_(range, "V")) {
irange = 2;
} else if (lsame_(range, "I")) {
irange = 3;
} else {
irange = 0;
}
/* Decode ORDER */
if (lsame_(order, "B")) {
iorder = 2;
} else if (lsame_(order, "E")) {
iorder = 1;
} else {
iorder = 0;
}
/* Check for Errors */
if (irange <= 0) {
*info = -1;
} else if (iorder <= 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (irange == 2 && *vl >= *vu) {
*info = -5;
} else if (irange == 3 && (*il < 1 || *il > max(1,*n))) {
*info = -6;
} else if (irange == 3 && (*iu < min(*n,*il) || *iu > *n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSTEBZ", &i__1);
return 0;
}
/* Initialize error flags */
*info = 0;
ncnvrg = FALSE_;
toofew = FALSE_;
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
/* Simplifications: */
if (irange == 3 && *il == 1 && *iu == *n) {
irange = 1;
}
/* Get machine constants
NB is the minimum vector length for vector bisection, or 0
if only scalar is to be done. */
safemn = slamch_("S");
ulp = slamch_("P");
rtoli = ulp * 2.f;
nb = ilaenv_(&c__1, "SSTEBZ", " ", n, &c_n1, &c_n1, &c_n1, 6L, 1L);
if (nb <= 1) {
nb = 0;
}
/* Special Case when N=1 */
if (*n == 1) {
*nsplit = 1;
ISPLIT(1) = 1;
if (irange == 2 && (*vl >= D(1) || *vu < D(1))) {
*m = 0;
} else {
W(1) = D(1);
IBLOCK(1) = 1;
*m = 1;
}
return 0;
}
/* Compute Splitting Points */
*nsplit = 1;
WORK(*n) = 0.f;
pivmin = 1.f;
i__1 = *n;
for (j = 2; j <= *n; ++j) {
/* Computing 2nd power */
r__1 = E(j - 1);
tmp1 = r__1 * r__1;
/* Computing 2nd power */
r__2 = ulp;
if ((r__1 = D(j) * D(j - 1), dabs(r__1)) * (r__2 * r__2) + safemn >
tmp1) {
ISPLIT(*nsplit) = j - 1;
++(*nsplit);
WORK(j - 1) = 0.f;
} else {
WORK(j - 1) = tmp1;
pivmin = dmax(pivmin,tmp1);
}
/* L10: */
}
ISPLIT(*nsplit) = *n;
pivmin *= safemn;
/* Compute Interval and ATOLI */
if (irange == 3) {
/* RANGE='I': Compute the interval containing eigenvalues
IL through IU.
Compute Gershgorin interval for entire (split) matrix
and use it as the initial interval */
gu = D(1);
gl = D(1);
tmp1 = 0.f;
i__1 = *n - 1;
for (j = 1; j <= *n-1; ++j) {
tmp2 = sqrt(WORK(j));
/* Computing MAX */
r__1 = gu, r__2 = D(j) + tmp1 + tmp2;
gu = dmax(r__1,r__2);
/* Computing MIN */
r__1 = gl, r__2 = D(j) - tmp1 - tmp2;
gl = dmin(r__1,r__2);
tmp1 = tmp2;
/* L20: */
}
/* Computing MAX */
r__1 = gu, r__2 = D(*n) + tmp1;
gu = dmax(r__1,r__2);
/* Computing MIN */
r__1 = gl, r__2 = D(*n) - tmp1;
gl = dmin(r__1,r__2);
/* Computing MAX */
r__1 = dabs(gl), r__2 = dabs(gu);
tnorm = dmax(r__1,r__2);
gl = gl - tnorm * 2.f * ulp * *n - pivmin * 4.f;
gu = gu + tnorm * 2.f * ulp * *n + pivmin * 2.f;
/* Compute Iteration parameters */
itmax = (integer) ((log(tnorm + pivmin) - log(pivmin)) / log(2.f)) +
2;
if (*abstol <= 0.f) {
atoli = ulp * tnorm;
} else {
atoli = *abstol;
}
WORK(*n + 1) = gl;
WORK(*n + 2) = gl;
WORK(*n + 3) = gu;
WORK(*n + 4) = gu;
WORK(*n + 5) = gl;
WORK(*n + 6) = gu;
IWORK(1) = -1;
IWORK(2) = -1;
IWORK(3) = *n + 1;
IWORK(4) = *n + 1;
IWORK(5) = *il - 1;
IWORK(6) = *iu;
slaebz_(&c__3, &itmax, n, &c__2, &c__2, &nb, &atoli, &rtoli, &pivmin,
&D(1), &E(1), &WORK(1), &IWORK(5), &WORK(*n + 1), &WORK(*n +
5), &iout, &IWORK(1), &W(1), &IBLOCK(1), &iinfo);
if (IWORK(6) == *iu) {
wl = WORK(*n + 1);
wlu = WORK(*n + 3);
nwl = IWORK(1);
wu = WORK(*n + 4);
wul = WORK(*n + 2);
nwu = IWORK(4);
} else {
wl = WORK(*n + 2);
wlu = WORK(*n + 4);
nwl = IWORK(2);
wu = WORK(*n + 3);
wul = WORK(*n + 1);
nwu = IWORK(3);
}
if (nwl < 0 || nwl >= *n || nwu < 1 || nwu > *n) {
*info = 4;
return 0;
}
} else {
/* RANGE='A' or 'V' -- Set ATOLI
Computing MAX */
r__3 = dabs(D(1)) + dabs(E(1)), r__4 = (r__1 = D(*n), dabs(r__1)) + (
r__2 = E(*n - 1), dabs(r__2));
tnorm = dmax(r__3,r__4);
i__1 = *n - 1;
for (j = 2; j <= *n-1; ++j) {
/* Computing MAX */
r__4 = tnorm, r__5 = (r__1 = D(j), dabs(r__1)) + (r__2 = E(j - 1),
dabs(r__2)) + (r__3 = E(j), dabs(r__3));
tnorm = dmax(r__4,r__5);
/* L30: */
}
if (*abstol <= 0.f) {
atoli = ulp * tnorm;
} else {
atoli = *abstol;
}
if (irange == 2) {
wl = *vl;
wu = *vu;
}
}
/* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU.
NWL accumulates the number of eigenvalues .le. WL,
NWU accumulates the number of eigenvalues .le. WU */
*m = 0;
iend = 0;
*info = 0;
nwl = 0;
nwu = 0;
i__1 = *nsplit;
for (jb = 1; jb <= *nsplit; ++jb) {
ioff = iend;
ibegin = ioff + 1;
iend = ISPLIT(jb);
in = iend - ioff;
if (in == 1) {
/* Special Case -- IN=1 */
if (irange == 1 || wl >= D(ibegin) - pivmin) {
++nwl;
}
if (irange == 1 || wu >= D(ibegin) - pivmin) {
++nwu;
}
if (irange == 1 || wl < D(ibegin) - pivmin && wu >= D(ibegin) -
pivmin) {
++(*m);
W(*m) = D(ibegin);
IBLOCK(*m) = jb;
}
} else {
/* General Case -- IN > 1
Compute Gershgorin Interval
and use it as the initial interval */
gu = D(ibegin);
gl = D(ibegin);
tmp1 = 0.f;
i__2 = iend - 1;
for (j = ibegin; j <= iend-1; ++j) {
tmp2 = (r__1 = E(j), dabs(r__1));
/* Computing MAX */
r__1 = gu, r__2 = D(j) + tmp1 + tmp2;
gu = dmax(r__1,r__2);
/* Computing MIN */
r__1 = gl, r__2 = D(j) - tmp1 - tmp2;
gl = dmin(r__1,r__2);
tmp1 = tmp2;
/* L40: */
}
/* Computing MAX */
r__1 = gu, r__2 = D(iend) + tmp1;
gu = dmax(r__1,r__2);
/* Computing MIN */
r__1 = gl, r__2 = D(iend) - tmp1;
gl = dmin(r__1,r__2);
/* Computing MAX */
r__1 = dabs(gl), r__2 = dabs(gu);
bnorm = dmax(r__1,r__2);
gl = gl - bnorm * 2.f * ulp * in - pivmin * 2.f;
gu = gu + bnorm * 2.f * ulp * in + pivmin * 2.f;
/* Compute ATOLI for the current submatrix */
if (*abstol <= 0.f) {
/* Computing MAX */
r__1 = dabs(gl), r__2 = dabs(gu);
atoli = ulp * dmax(r__1,r__2);
} else {
atoli = *abstol;
}
if (irange > 1) {
if (gu < wl) {
nwl += in;
nwu += in;
goto L70;
}
gl = dmax(gl,wl);
gu = dmin(gu,wu);
if (gl >= gu) {
goto L70;
}
}
/* Set Up Initial Interval */
WORK(*n + 1) = gl;
WORK(*n + in + 1) = gu;
slaebz_(&c__1, &c__0, &in, &in, &c__1, &nb, &atoli, &rtoli, &
pivmin, &D(ibegin), &E(ibegin), &WORK(ibegin), idumma, &
WORK(*n + 1), &WORK(*n + (in << 1) + 1), &im, &IWORK(1), &
W(*m + 1), &IBLOCK(*m + 1), &iinfo);
nwl += IWORK(1);
nwu += IWORK(in + 1);
iwoff = *m - IWORK(1);
/* Compute Eigenvalues */
itmax = (integer) ((log(gu - gl + pivmin) - log(pivmin)) / log(
2.f)) + 2;
slaebz_(&c__2, &itmax, &in, &in, &c__1, &nb, &atoli, &rtoli, &
pivmin, &D(ibegin), &E(ibegin), &WORK(ibegin), idumma, &
WORK(*n + 1), &WORK(*n + (in << 1) + 1), &iout, &IWORK(1),
&W(*m + 1), &IBLOCK(*m + 1), &iinfo);
/* Copy Eigenvalues Into W and IBLOCK
Use -JB for block number for unconverged eigenvalues.
*/
i__2 = iout;
for (j = 1; j <= iout; ++j) {
tmp1 = (WORK(j + *n) + WORK(j + in + *n)) * .5f;
/* Flag non-convergence. */
if (j > iout - iinfo) {
ncnvrg = TRUE_;
ib = -jb;
} else {
ib = jb;
}
i__3 = IWORK(j + in) + iwoff;
for (je = IWORK(j) + 1 + iwoff; je <= IWORK(j+in)+iwoff; ++je) {
W(je) = tmp1;
IBLOCK(je) = ib;
/* L50: */
}
/* L60: */
}
*m += im;
}
L70:
;
}
/* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
If NWL+1 < IL or NWU > IU, discard extra eigenvalues. */
if (irange == 3) {
im = 0;
idiscl = *il - 1 - nwl;
idiscu = nwu - *iu;
if (idiscl > 0 || idiscu > 0) {
i__1 = *m;
for (je = 1; je <= *m; ++je) {
if (W(je) <= wlu && idiscl > 0) {
--idiscl;
} else if (W(je) >= wul && idiscu > 0) {
--idiscu;
} else {
++im;
W(im) = W(je);
IBLOCK(im) = IBLOCK(je);
}
/* L80: */
}
*m = im;
}
if (idiscl > 0 || idiscu > 0) {
/* Code to deal with effects of bad arithmetic:
Some low eigenvalues to be discarded are not in (WL,W
LU],
or high eigenvalues to be discarded are not in (WUL,W
U]
so just kill off the smallest IDISCL/largest IDISCU
eigenvalues, by simply finding the smallest/largest
eigenvalue(s).
(If N(w) is monotone non-decreasing, this should neve
r
happen.) */
if (idiscl > 0) {
wkill = wu;
i__1 = idiscl;
for (jdisc = 1; jdisc <= idiscl; ++jdisc) {
iw = 0;
i__2 = *m;
for (je = 1; je <= *m; ++je) {
if (IBLOCK(je) != 0 && (W(je) < wkill || iw == 0)) {
iw = je;
wkill = W(je);
}
/* L90: */
}
IBLOCK(iw) = 0;
/* L100: */
}
}
if (idiscu > 0) {
wkill = wl;
i__1 = idiscu;
for (jdisc = 1; jdisc <= idiscu; ++jdisc) {
iw = 0;
i__2 = *m;
for (je = 1; je <= *m; ++je) {
if (IBLOCK(je) != 0 && (W(je) > wkill || iw == 0)) {
iw = je;
wkill = W(je);
}
/* L110: */
}
IBLOCK(iw) = 0;
/* L120: */
}
}
im = 0;
i__1 = *m;
for (je = 1; je <= *m; ++je) {
if (IBLOCK(je) != 0) {
++im;
W(im) = W(je);
IBLOCK(im) = IBLOCK(je);
}
/* L130: */
}
*m = im;
}
if (idiscl < 0 || idiscu < 0) {
toofew = TRUE_;
}
}
/* If ORDER='B', do nothing -- the eigenvalues are already sorted
by block.
If ORDER='E', sort the eigenvalues from smallest to largest */
if (iorder == 1 && *nsplit > 1) {
i__1 = *m - 1;
for (je = 1; je <= *m-1; ++je) {
ie = 0;
tmp1 = W(je);
i__2 = *m;
for (j = je + 1; j <= *m; ++j) {
if (W(j) < tmp1) {
ie = j;
tmp1 = W(j);
}
/* L140: */
}
if (ie != 0) {
itmp1 = IBLOCK(ie);
W(ie) = W(je);
IBLOCK(ie) = IBLOCK(je);
W(je) = tmp1;
IBLOCK(je) = itmp1;
}
/* L150: */
}
}
*info = 0;
if (ncnvrg) {
++(*info);
}
if (toofew) {
*info += 2;
}
return 0;
/* End of SSTEBZ */
} /* sstebz_ */
/* 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 sget10_(integer *m, integer *n, real *a, integer *lda,
real *b, integer *ldb, real *work, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
real r__1, r__2;
/* Local variables */
integer j;
real eps, unfl, anorm;
extern doublereal sasum_(integer *, real *, integer *);
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
real wnorm;
extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
real *, integer *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGET10 compares two matrices A and B and computes the ratio */
/* RESULT = norm( A - B ) / ( norm(A) * M * EPS ) */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrices A and B. */
/* N (input) INTEGER */
/* The number of columns of the matrices A and B. */
/* A (input) REAL array, dimension (LDA,N) */
/* The m by n matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* B (input) REAL array, dimension (LDB,N) */
/* The m by n matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,M). */
/* WORK (workspace) REAL array, dimension (M) */
/* RESULT (output) REAL */
/* RESULT = norm( A - B ) / ( norm(A) * M * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
/* Function Body */
if (*m <= 0 || *n <= 0) {
*result = 0.f;
return 0;
}
unfl = slamch_("Safe minimum");
eps = slamch_("Precision");
wnorm = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
scopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
saxpy_(m, &c_b7, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
/* Computing MAX */
r__1 = wnorm, r__2 = sasum_(n, &work[1], &c__1);
wnorm = dmax(r__1,r__2);
/* L10: */
}
/* Computing MAX */
r__1 = slange_("1", m, n, &a[a_offset], lda, &work[1]);
anorm = dmax(r__1,unfl);
if (anorm > wnorm) {
*result = wnorm / anorm / (*m * eps);
} else {
if (anorm < 1.f) {
/* Computing MIN */
r__1 = wnorm, r__2 = *m * anorm;
*result = dmin(r__1,r__2) / anorm / (*m * eps);
} else {
/* Computing MIN */
r__1 = wnorm / anorm, r__2 = (real) (*m);
*result = dmin(r__1,r__2) / (*m * eps);
}
}
return 0;
/* End of SGET10 */
} /* sget10_ */
/* Subroutine */ int slasq4_(integer *i0, integer *n0, real *z__, integer *pp,
integer *n0in, real *dmin__, real *dmin1, real *dmin2, real *dn,
real *dn1, real *dn2, real *tau, integer *ttype, real *g)
{
/* System generated locals */
integer i__1;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
real s, a2, b1, b2;
integer i4, nn, np;
real gam, gap1, gap2;
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
/* -- Berkeley -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLASQ4 computes an approximation TAU to the smallest eigenvalue */
/* using values of d from the previous transform. */
/* I0 (input) INTEGER */
/* First index. */
/* N0 (input) INTEGER */
/* Last index. */
/* Z (input) REAL array, dimension ( 4*N ) */
/* Z holds the qd array. */
/* PP (input) INTEGER */
/* PP=0 for ping, PP=1 for pong. */
/* NOIN (input) INTEGER */
/* The value of N0 at start of EIGTEST. */
/* DMIN (input) REAL */
/* Minimum value of d. */
/* DMIN1 (input) REAL */
/* Minimum value of d, excluding D( N0 ). */
/* DMIN2 (input) REAL */
/* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */
/* DN (input) REAL */
/* d(N) */
/* DN1 (input) REAL */
/* d(N-1) */
/* DN2 (input) REAL */
/* d(N-2) */
/* TAU (output) REAL */
/* This is the shift. */
/* TTYPE (output) INTEGER */
/* Shift type. */
/* G (input/output) REAL */
/* G is passed as an argument in order to save its value between */
/* calls to SLASQ4. */
/* Further Details */
/* =============== */
/* CNST1 = 9/16 */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* A negative DMIN forces the shift to take that absolute value */
/* TTYPE records the type of shift. */
/* Parameter adjustments */
--z__;
/* Function Body */
if (*dmin__ <= 0.f) {
*tau = -(*dmin__);
*ttype = -1;
return 0;
}
nn = (*n0 << 2) + *pp;
if (*n0in == *n0) {
/* No eigenvalues deflated. */
if (*dmin__ == *dn || *dmin__ == *dn1) {
b1 = sqrt(z__[nn - 3]) * sqrt(z__[nn - 5]);
b2 = sqrt(z__[nn - 7]) * sqrt(z__[nn - 9]);
a2 = z__[nn - 7] + z__[nn - 5];
/* Cases 2 and 3. */
if (*dmin__ == *dn && *dmin1 == *dn1) {
gap2 = *dmin2 - a2 - *dmin2 * .25f;
if (gap2 > 0.f && gap2 > b2) {
gap1 = a2 - *dn - b2 / gap2 * b2;
} else {
gap1 = a2 - *dn - (b1 + b2);
}
if (gap1 > 0.f && gap1 > b1) {
/* Computing MAX */
r__1 = *dn - b1 / gap1 * b1, r__2 = *dmin__ * .5f;
s = dmax(r__1,r__2);
*ttype = -2;
} else {
s = 0.f;
if (*dn > b1) {
s = *dn - b1;
}
if (a2 > b1 + b2) {
/* Computing MIN */
r__1 = s, r__2 = a2 - (b1 + b2);
s = dmin(r__1,r__2);
}
/* Computing MAX */
r__1 = s, r__2 = *dmin__ * .333f;
s = dmax(r__1,r__2);
*ttype = -3;
}
} else {
/* Case 4. */
*ttype = -4;
s = *dmin__ * .25f;
if (*dmin__ == *dn) {
gam = *dn;
a2 = 0.f;
if (z__[nn - 5] > z__[nn - 7]) {
return 0;
}
b2 = z__[nn - 5] / z__[nn - 7];
np = nn - 9;
} else {
np = nn - (*pp << 1);
b2 = z__[np - 2];
gam = *dn1;
if (z__[np - 4] > z__[np - 2]) {
return 0;
}
a2 = z__[np - 4] / z__[np - 2];
if (z__[nn - 9] > z__[nn - 11]) {
return 0;
}
b2 = z__[nn - 9] / z__[nn - 11];
np = nn - 13;
}
/* Approximate contribution to norm squared from I < NN-1. */
a2 += b2;
i__1 = (*i0 << 2) - 1 + *pp;
for (i4 = np; i4 >= i__1; i4 += -4) {
if (b2 == 0.f) {
goto L20;
}
b1 = b2;
if (z__[i4] > z__[i4 - 2]) {
return 0;
}
b2 *= z__[i4] / z__[i4 - 2];
a2 += b2;
if (dmax(b2,b1) * 100.f < a2 || .563f < a2) {
goto L20;
}
/* L10: */
}
L20:
a2 *= 1.05f;
/* Rayleigh quotient residual bound. */
if (a2 < .563f) {
s = gam * (1.f - sqrt(a2)) / (a2 + 1.f);
}
}
} else if (*dmin__ == *dn2) {
/* Case 5. */
*ttype = -5;
s = *dmin__ * .25f;
/* Compute contribution to norm squared from I > NN-2. */
np = nn - (*pp << 1);
b1 = z__[np - 2];
b2 = z__[np - 6];
gam = *dn2;
if (z__[np - 8] > b2 || z__[np - 4] > b1) {
return 0;
}
a2 = z__[np - 8] / b2 * (z__[np - 4] / b1 + 1.f);
/* Approximate contribution to norm squared from I < NN-2. */
if (*n0 - *i0 > 2) {
b2 = z__[nn - 13] / z__[nn - 15];
a2 += b2;
i__1 = (*i0 << 2) - 1 + *pp;
for (i4 = nn - 17; i4 >= i__1; i4 += -4) {
if (b2 == 0.f) {
goto L40;
}
b1 = b2;
if (z__[i4] > z__[i4 - 2]) {
return 0;
}
b2 *= z__[i4] / z__[i4 - 2];
a2 += b2;
if (dmax(b2,b1) * 100.f < a2 || .563f < a2) {
goto L40;
}
/* L30: */
}
L40:
a2 *= 1.05f;
}
if (a2 < .563f) {
s = gam * (1.f - sqrt(a2)) / (a2 + 1.f);
}
} else {
/* Case 6, no information to guide us. */
if (*ttype == -6) {
*g += (1.f - *g) * .333f;
} else if (*ttype == -18) {
*g = .083250000000000005f;
} else {
*g = .25f;
}
s = *g * *dmin__;
*ttype = -6;
}
} else if (*n0in == *n0 + 1) {
/* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. */
if (*dmin1 == *dn1 && *dmin2 == *dn2) {
/* Cases 7 and 8. */
*ttype = -7;
s = *dmin1 * .333f;
if (z__[nn - 5] > z__[nn - 7]) {
return 0;
}
b1 = z__[nn - 5] / z__[nn - 7];
b2 = b1;
if (b2 == 0.f) {
goto L60;
}
i__1 = (*i0 << 2) - 1 + *pp;
for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) {
a2 = b1;
if (z__[i4] > z__[i4 - 2]) {
return 0;
}
b1 *= z__[i4] / z__[i4 - 2];
b2 += b1;
if (dmax(b1,a2) * 100.f < b2) {
goto L60;
}
/* L50: */
}
L60:
b2 = sqrt(b2 * 1.05f);
/* Computing 2nd power */
r__1 = b2;
a2 = *dmin1 / (r__1 * r__1 + 1.f);
gap2 = *dmin2 * .5f - a2;
if (gap2 > 0.f && gap2 > b2 * a2) {
/* Computing MAX */
r__1 = s, r__2 = a2 * (1.f - a2 * 1.01f * (b2 / gap2) * b2);
s = dmax(r__1,r__2);
} else {
/* Computing MAX */
r__1 = s, r__2 = a2 * (1.f - b2 * 1.01f);
s = dmax(r__1,r__2);
*ttype = -8;
}
} else {
/* Case 9. */
s = *dmin1 * .25f;
if (*dmin1 == *dn1) {
s = *dmin1 * .5f;
}
*ttype = -9;
}
} else if (*n0in == *n0 + 2) {
/* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. */
/* Cases 10 and 11. */
if (*dmin2 == *dn2 && z__[nn - 5] * 2.f < z__[nn - 7]) {
*ttype = -10;
s = *dmin2 * .333f;
if (z__[nn - 5] > z__[nn - 7]) {
return 0;
}
b1 = z__[nn - 5] / z__[nn - 7];
b2 = b1;
if (b2 == 0.f) {
goto L80;
}
i__1 = (*i0 << 2) - 1 + *pp;
for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) {
if (z__[i4] > z__[i4 - 2]) {
return 0;
}
b1 *= z__[i4] / z__[i4 - 2];
b2 += b1;
if (b1 * 100.f < b2) {
goto L80;
}
/* L70: */
}
L80:
b2 = sqrt(b2 * 1.05f);
/* Computing 2nd power */
r__1 = b2;
a2 = *dmin2 / (r__1 * r__1 + 1.f);
gap2 = z__[nn - 7] + z__[nn - 9] - sqrt(z__[nn - 11]) * sqrt(z__[
nn - 9]) - a2;
if (gap2 > 0.f && gap2 > b2 * a2) {
/* Computing MAX */
r__1 = s, r__2 = a2 * (1.f - a2 * 1.01f * (b2 / gap2) * b2);
s = dmax(r__1,r__2);
} else {
/* Computing MAX */
r__1 = s, r__2 = a2 * (1.f - b2 * 1.01f);
s = dmax(r__1,r__2);
}
} else {
s = *dmin2 * .25f;
*ttype = -11;
}
} else if (*n0in > *n0 + 2) {
/* Case 12, more than two eigenvalues deflated. No information. */
s = 0.f;
*ttype = -12;
}
*tau = s;
return 0;
/* End of SLASQ4 */
} /* slasq4_ */
/* Subroutine */ int sdrgsx_(integer *nsize, integer *ncmax, real *thresh,
integer *nin, integer *nout, real *a, integer *lda, real *b, real *ai,
real *bi, real *z__, real *q, real *alphar, real *alphai, real *beta,
real *c__, integer *ldc, real *s, real *work, integer *lwork,
integer *iwork, integer *liwork, logical *bwork, integer *info)
{
/* Format strings */
static char fmt_9999[] = "(\002 SDRGSX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002)\002)";
static char fmt_9997[] = "(\002 SDRGSX: SGET53 returned INFO=\002,i1,"
"\002 for eigenvalue \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JT"
"YPE=\002,i6,\002)\002)";
static char fmt_9996[] = "(\002 SDRGSX: S not in Schur form at eigenvalu"
"e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002"
")\002)";
static char fmt_9995[] = "(/1x,a3,\002 -- Real Expert Generalized Schur "
"form\002,\002 problem driver\002)";
static char fmt_9993[] = "(\002 Matrix types: \002,/\002 1: A is a blo"
"ck diagonal matrix of Jordan blocks \002,\002and B is the identi"
"ty \002,/\002 matrix, \002,/\002 2: A and B are upper tri"
"angular matrices, \002,/\002 3: A and B are as type 2, but eac"
"h second diagonal \002,\002block in A_11 and \002,/\002 eac"
"h third diaongal block in A_22 are 2x2 blocks,\002,/\002 4: A "
"and B are block diagonal matrices, \002,/\002 5: (A,B) has pot"
"entially close or common \002,\002eigenvalues.\002,/)";
static char fmt_9992[] = "(/\002 Tests performed: (S is Schur, T is tri"
"angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002 a is al"
"pha, b is beta, and \002,a,\002 means \002,a,\002.)\002,/\002 1"
" = | A - Q S Z\002,a,\002 | / ( |A| n ulp ) 2 = | B - Q T "
"Z\002,a,\002 | / ( |B| n ulp )\002,/\002 3 = | I - QQ\002,a,"
"\002 | / ( n ulp ) 4 = | I - ZZ\002,a,\002 | / ( n u"
"lp )\002,/\002 5 = 1/ULP if A is not in \002,\002Schur form "
"S\002,/\002 6 = difference between (alpha,beta)\002,\002 and di"
"agonals of (S,T)\002,/\002 7 = 1/ULP if SDIM is not the correc"
"t number of \002,\002selected eigenvalues\002,/\002 8 = 1/ULP "
"if DIFEST/DIFTRU > 10*THRESH or \002,\002DIFTRU/DIFEST > 10*THRE"
"SH\002,/\002 9 = 1/ULP if DIFEST <> 0 or DIFTRU > ULP*norm(A,B"
") \002,\002when reordering fails\002,/\002 10 = 1/ULP if PLEST/"
"PLTRU > THRESH or \002,\002PLTRU/PLEST > THRESH\002,/\002 ( T"
"est 10 is only for input examples )\002,/)";
static char fmt_9991[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
",\002, a=\002,e10.4,\002, order(A_11)=\002,i2,\002, result \002,"
"i2,\002 is \002,0p,f8.2)";
static char fmt_9990[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
",\002, a=\002,e10.4,\002, order(A_11)=\002,i2,\002, result \002,"
"i2,\002 is \002,0p,e10.4)";
static char fmt_9998[] = "(\002 SDRGSX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, Input Example #\002,i2,\002"
")\002)";
static char fmt_9994[] = "(\002Input Example\002)";
static char fmt_9989[] = "(\002 Input example #\002,i2,\002, matrix orde"
"r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,0p,f8.2)";
static char fmt_9988[] = "(\002 Input example #\002,i2,\002, matrix orde"
"r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,1p,e10.3)";
/* System generated locals */
integer a_dim1, a_offset, ai_dim1, ai_offset, b_dim1, b_offset, bi_dim1,
bi_offset, c_dim1, c_offset, q_dim1, q_offset, z_dim1, z_offset,
i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Local variables */
static real temp1, temp2;
static integer i__, j;
static real abnrm;
static integer ifunc, iinfo, linfo;
extern /* Subroutine */ int sget51_(integer *, integer *, real *, integer
*, real *, integer *, real *, integer *, real *, integer *, real *
, real *), sget53_(real *, integer *, real *, integer *, real *,
real *, real *, real *, integer *);
static char sense[1];
static integer nerrs, i1, ntest;
static real pltru;
extern /* Subroutine */ int slakf2_(integer *, integer *, real *, integer
*, real *, real *, real *, real *, integer *), slatm5_(integer *,
integer *, integer *, real *, integer *, real *, integer *, real *
, integer *, real *, integer *, real *, integer *, real *,
integer *, real *, integer *, real *, integer *, real *, integer *
, integer *);
static logical ilabad;
static real thrsh2;
extern /* Subroutine */ int slabad_(real *, real *);
static integer mm, bdspac;
static real pl[2];
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int xerbla_(char *, integer *);
static real difest[2];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static real bignum;
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *);
static real weight;
extern /* Subroutine */ int sgesvd_(char *, char *, integer *, integer *,
real *, integer *, real *, real *, integer *, real *, integer *,
real *, integer *, integer *), slacpy_(char *,
integer *, integer *, real *, integer *, real *, integer *);
static real diftru;
extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
real *, real *, integer *), sggesx_(char *, char *, char *
, L_fp, char *, integer *, real *, integer *, real *, integer *,
integer *, real *, real *, real *, real *, integer *, real *,
integer *, real *, real *, real *, integer *, integer *, integer *
, logical *, integer *);
static integer minwrk, maxwrk;
static real smlnum;
static integer mn2, nptknt;
static real ulpinv, result[10];
static integer ntestt;
extern logical slctsx_();
static integer prtype, qba, qbb;
static real ulp;
/* Fortran I/O blocks */
static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9990, 0 };
static cilist io___42 = { 0, 0, 1, 0, 0 };
static cilist io___43 = { 0, 0, 1, 0, 0 };
static cilist io___44 = { 0, 0, 0, 0, 0 };
static cilist io___45 = { 0, 0, 0, 0, 0 };
static cilist io___46 = { 0, 0, 0, 0, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9989, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9988, 0 };
#define ai_ref(a_1,a_2) ai[(a_2)*ai_dim1 + a_1]
#define bi_ref(a_1,a_2) bi[(a_2)*bi_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1999
Purpose
=======
SDRGSX checks the nonsymmetric generalized eigenvalue (Schur form)
problem expert driver SGGESX.
SGGESX factors A and B as Q S Z' and Q T Z', where ' means
transpose, T is upper triangular, S is in generalized Schur form
(block upper triangular, with 1x1 and 2x2 blocks on the diagonal,
the 2x2 blocks corresponding to complex conjugate pairs of
generalized eigenvalues), and Q and Z are orthogonal. It also
computes the generalized eigenvalues (alpha(1),beta(1)), ...,
(alpha(n),beta(n)). Thus, w(j) = alpha(j)/beta(j) is a root of the
characteristic equation
det( A - w(j) B ) = 0
Optionally it also reorders the eigenvalues so that a selected
cluster of eigenvalues appears in the leading diagonal block of the
Schur forms; computes a reciprocal condition number for the average
of the selected eigenvalues; and computes a reciprocal condition
number for the right and left deflating subspaces corresponding to
the selected eigenvalues.
When SDRGSX is called with NSIZE > 0, five (5) types of built-in
matrix pairs are used to test the routine SGGESX.
When SDRGSX is called with NSIZE = 0, it reads in test matrix data
to test SGGESX.
For each matrix pair, the following tests will be performed and
compared with the threshhold THRESH except for the tests (7) and (9):
(1) | A - Q S Z' | / ( |A| n ulp )
(2) | B - Q T Z' | / ( |B| n ulp )
(3) | I - QQ' | / ( n ulp )
(4) | I - ZZ' | / ( n ulp )
(5) if A is in Schur form (i.e. quasi-triangular form)
(6) maximum over j of D(j) where:
if alpha(j) is real:
|alpha(j) - S(j,j)| |beta(j) - T(j,j)|
D(j) = ------------------------ + -----------------------
max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
if alpha(j) is complex:
| det( s S - w T ) |
D(j) = ---------------------------------------------------
ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )
and S and T are here the 2 x 2 diagonal blocks of S and T
corresponding to the j-th and j+1-th eigenvalues.
(7) if sorting worked and SDIM is the number of eigenvalues
which were selected.
(8) the estimated value DIF does not differ from the true values of
Difu and Difl more than a factor 10*THRESH. If the estimate DIF
equals zero the corresponding true values of Difu and Difl
should be less than EPS*norm(A, B). If the true value of Difu
and Difl equal zero, the estimate DIF should be less than
EPS*norm(A, B).
(9) If INFO = N+3 is returned by SGGESX, the reordering "failed"
and we check that DIF = PL = PR = 0 and that the true value of
Difu and Difl is < EPS*norm(A, B). We count the events when
INFO=N+3.
For read-in test matrices, the above tests are run except that the
exact value for DIF (and PL) is input data. Additionally, there is
one more test run for read-in test matrices:
(10) the estimated value PL does not differ from the true value of
PLTRU more than a factor THRESH. If the estimate PL equals
zero the corresponding true value of PLTRU should be less than
EPS*norm(A, B). If the true value of PLTRU equal zero, the
estimate PL should be less than EPS*norm(A, B).
Note that for the built-in tests, a total of 10*NSIZE*(NSIZE-1)
matrix pairs are generated and tested. NSIZE should be kept small.
SVD (routine SGESVD) is used for computing the true value of DIF_u
and DIF_l when testing the built-in test problems.
Built-in Test Matrices
======================
All built-in test matrices are the 2 by 2 block of triangular
matrices
A = [ A11 A12 ] and B = [ B11 B12 ]
[ A22 ] [ B22 ]
where for different type of A11 and A22 are given as the following.
A12 and B12 are chosen so that the generalized Sylvester equation
A11*R - L*A22 = -A12
B11*R - L*B22 = -B12
have prescribed solution R and L.
Type 1: A11 = J_m(1,-1) and A_22 = J_k(1-a,1).
B11 = I_m, B22 = I_k
where J_k(a,b) is the k-by-k Jordan block with ``a'' on
diagonal and ``b'' on superdiagonal.
Type 2: A11 = (a_ij) = ( 2(.5-sin(i)) ) and
B11 = (b_ij) = ( 2(.5-sin(ij)) ) for i=1,...,m, j=i,...,m
A22 = (a_ij) = ( 2(.5-sin(i+j)) ) and
B22 = (b_ij) = ( 2(.5-sin(ij)) ) for i=m+1,...,k, j=i,...,k
Type 3: A11, A22 and B11, B22 are chosen as for Type 2, but each
second diagonal block in A_11 and each third diagonal block
in A_22 are made as 2 by 2 blocks.
Type 4: A11 = ( 20(.5 - sin(ij)) ) and B22 = ( 2(.5 - sin(i+j)) )
for i=1,...,m, j=1,...,m and
A22 = ( 20(.5 - sin(i+j)) ) and B22 = ( 2(.5 - sin(ij)) )
for i=m+1,...,k, j=m+1,...,k
Type 5: (A,B) and have potentially close or common eigenvalues and
very large departure from block diagonality A_11 is chosen
as the m x m leading submatrix of A_1:
| 1 b |
| -b 1 |
| 1+d b |
| -b 1+d |
A_1 = | d 1 |
| -1 d |
| -d 1 |
| -1 -d |
| 1 |
and A_22 is chosen as the k x k leading submatrix of A_2:
| -1 b |
| -b -1 |
| 1-d b |
| -b 1-d |
A_2 = | d 1+b |
| -1-b d |
| -d 1+b |
| -1+b -d |
| 1-d |
and matrix B are chosen as identity matrices (see SLATM5).
Arguments
=========
NSIZE (input) INTEGER
The maximum size of the matrices to use. NSIZE >= 0.
If NSIZE = 0, no built-in tests matrices are used, but
read-in test matrices are used to test SGGESX.
NCMAX (input) INTEGER
Maximum allowable NMAX for generating Kroneker matrix
in call to SLAKF2
THRESH (input) REAL
A test will count as "failed" if the "error", computed as
described above, exceeds THRESH. Note that the error
is scaled to be O(1), so THRESH should be a reasonably
small multiple of 1, e.g., 10 or 100. In particular,
it should not depend on the precision (single vs. double)
or the size of the matrix. THRESH >= 0.
NIN (input) INTEGER
The FORTRAN unit number for reading in the data file of
problems to solve.
NOUT (input) INTEGER
The FORTRAN unit number for printing out error messages
(e.g., if a routine returns IINFO not equal to 0.)
A (workspace) REAL array, dimension (LDA, NSIZE)
Used to store the matrix whose eigenvalues are to be
computed. On exit, A contains the last matrix actually used.
LDA (input) INTEGER
The leading dimension of A, B, AI, BI, Z and Q,
LDA >= max( 1, NSIZE ). For the read-in test,
LDA >= max( 1, N ), N is the size of the test matrices.
B (workspace) REAL array, dimension (LDA, NSIZE)
Used to store the matrix whose eigenvalues are to be
computed. On exit, B contains the last matrix actually used.
AI (workspace) REAL array, dimension (LDA, NSIZE)
Copy of A, modified by SGGESX.
BI (workspace) REAL array, dimension (LDA, NSIZE)
Copy of B, modified by SGGESX.
Z (workspace) REAL array, dimension (LDA, NSIZE)
Z holds the left Schur vectors computed by SGGESX.
Q (workspace) REAL array, dimension (LDA, NSIZE)
Q holds the right Schur vectors computed by SGGESX.
ALPHAR (workspace) REAL array, dimension (NSIZE)
ALPHAI (workspace) REAL array, dimension (NSIZE)
BETA (workspace) REAL array, dimension (NSIZE)
On exit, (ALPHAR + ALPHAI*i)/BETA are the eigenvalues.
C (workspace) REAL array, dimension (LDC, LDC)
Store the matrix generated by subroutine SLAKF2, this is the
matrix formed by Kronecker products used for estimating
DIF.
LDC (input) INTEGER
The leading dimension of C. LDC >= max(1, LDA*LDA/2 ).
S (workspace) REAL array, dimension (LDC)
Singular values of C
WORK (workspace) REAL array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK.
LWORK >= MAX( 5*NSIZE*NSIZE/2 - 2, 10*(NSIZE+1) )
IWORK (workspace) INTEGER array, dimension (LIWORK)
LIWORK (input) INTEGER
The dimension of the array IWORK. LIWORK >= NSIZE + 6.
BWORK (workspace) LOGICAL array, dimension (LDA)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: A routine returned an error code.
=====================================================================
Check for errors
Parameter adjustments */
q_dim1 = *lda;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
z_dim1 = *lda;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
bi_dim1 = *lda;
bi_offset = 1 + bi_dim1 * 1;
bi -= bi_offset;
ai_dim1 = *lda;
ai_offset = 1 + ai_dim1 * 1;
ai -= ai_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--alphar;
--alphai;
--beta;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--s;
--work;
--iwork;
--bwork;
/* Function Body */
if (*nsize < 0) {
*info = -1;
} else if (*thresh < 0.f) {
*info = -2;
} else if (*nin <= 0) {
*info = -3;
} else if (*nout <= 0) {
*info = -4;
} else if (*lda < 1 || *lda < *nsize) {
*info = -6;
} else if (*ldc < 1 || *ldc < *nsize * *nsize / 2) {
*info = -17;
} else if (*liwork < *nsize + 6) {
*info = -21;
}
/* Compute workspace
(Note: Comments in the code beginning "Workspace:" describe the
minimal amount of workspace needed at that point in the code,
as well as the preferred amount for good performance.
NB refers to the optimal block size for the immediately
following subroutine, as returned by ILAENV.) */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
/* MINWRK = MAX( 10*( NSIZE+1 ), 5*NSIZE*NSIZE / 2-2 )
Computing MAX */
i__1 = (*nsize + 1) * 10, i__2 = *nsize * 5 * *nsize / 2;
minwrk = max(i__1,i__2);
/* workspace for sggesx */
maxwrk = (*nsize + 1) * 9 + *nsize * ilaenv_(&c__1, "SGEQRF", " ",
nsize, &c__1, nsize, &c__0, (ftnlen)6, (ftnlen)1);
/* Computing MAX */
i__1 = maxwrk, i__2 = (*nsize + 1) * 9 + *nsize * ilaenv_(&c__1,
"SORGQR", " ", nsize, &c__1, nsize, &c_n1, (ftnlen)6, (ftnlen)
1);
maxwrk = max(i__1,i__2);
/* workspace for sgesvd */
bdspac = *nsize * 5 * *nsize / 2;
/* Computing MAX */
i__3 = *nsize * *nsize / 2;
i__4 = *nsize * *nsize / 2;
i__1 = maxwrk, i__2 = *nsize * 3 * *nsize / 2 + *nsize * *nsize *
ilaenv_(&c__1, "SGEBRD", " ", &i__3, &i__4, &c_n1, &c_n1, (
ftnlen)6, (ftnlen)1);
maxwrk = max(i__1,i__2);
maxwrk = max(maxwrk,bdspac);
maxwrk = max(maxwrk,minwrk);
work[1] = (real) maxwrk;
}
if (*lwork < minwrk) {
*info = -19;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SDRGSX", &i__1);
return 0;
}
/* Important constants */
ulp = slamch_("P");
ulpinv = 1.f / ulp;
smlnum = slamch_("S") / ulp;
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
thrsh2 = *thresh * 10.f;
ntestt = 0;
nerrs = 0;
/* Go to the tests for read-in matrix pairs */
ifunc = 0;
if (*nsize == 0) {
goto L70;
}
/* Test the built-in matrix pairs.
Loop over different functions (IFUNC) of SGGESX, types (PRTYPE)
of test matrices, different size (M+N) */
prtype = 0;
qba = 3;
qbb = 4;
weight = sqrt(ulp);
for (ifunc = 0; ifunc <= 3; ++ifunc) {
for (prtype = 1; prtype <= 5; ++prtype) {
i__1 = *nsize - 1;
for (mn_1.m = 1; mn_1.m <= i__1; ++mn_1.m) {
i__2 = *nsize - mn_1.m;
for (mn_1.n = 1; mn_1.n <= i__2; ++mn_1.n) {
weight = 1.f / weight;
mn_1.mplusn = mn_1.m + mn_1.n;
/* Generate test matrices */
mn_1.fs = TRUE_;
mn_1.k = 0;
slaset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b26, &
c_b26, &ai[ai_offset], lda);
slaset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b26, &
c_b26, &bi[bi_offset], lda);
slatm5_(&prtype, &mn_1.m, &mn_1.n, &ai[ai_offset], lda, &
ai_ref(mn_1.m + 1, mn_1.m + 1), lda, &ai_ref(1,
mn_1.m + 1), lda, &bi[bi_offset], lda, &bi_ref(
mn_1.m + 1, mn_1.m + 1), lda, &bi_ref(1, mn_1.m +
1), lda, &q[q_offset], lda, &z__[z_offset], lda, &
weight, &qba, &qbb);
/* Compute the Schur factorization and swapping the
m-by-m (1,1)-blocks with n-by-n (2,2)-blocks.
Swapping is accomplished via the function SLCTSX
which is supplied below. */
if (ifunc == 0) {
*(unsigned char *)sense = 'N';
} else if (ifunc == 1) {
*(unsigned char *)sense = 'E';
} else if (ifunc == 2) {
*(unsigned char *)sense = 'V';
} else if (ifunc == 3) {
*(unsigned char *)sense = 'B';
}
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
, lda, &a[a_offset], lda);
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
, lda, &b[b_offset], lda);
sggesx_("V", "V", "S", (L_fp)slctsx_, sense, &mn_1.mplusn,
&ai[ai_offset], lda, &bi[bi_offset], lda, &mm, &
alphar[1], &alphai[1], &beta[1], &q[q_offset],
lda, &z__[z_offset], lda, pl, difest, &work[1],
lwork, &iwork[1], liwork, &bwork[1], &linfo);
if (linfo != 0 && linfo != mn_1.mplusn + 2) {
result[0] = ulpinv;
io___22.ciunit = *nout;
s_wsfe(&io___22);
do_fio(&c__1, "SGGESX", (ftnlen)6);
do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(integer)
);
e_wsfe();
*info = linfo;
goto L30;
}
/* Compute the norm(A, B) */
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
, lda, &work[1], &mn_1.mplusn);
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
, lda, &work[mn_1.mplusn * mn_1.mplusn + 1], &
mn_1.mplusn);
i__3 = mn_1.mplusn << 1;
abnrm = slange_("Fro", &mn_1.mplusn, &i__3, &work[1], &
mn_1.mplusn, &work[1]);
/* Do tests (1) to (4) */
sget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[
ai_offset], lda, &q[q_offset], lda, &z__[z_offset]
, lda, &work[1], result);
sget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[
bi_offset], lda, &q[q_offset], lda, &z__[z_offset]
, lda, &work[1], &result[1]);
sget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
bi_offset], lda, &q[q_offset], lda, &q[q_offset],
lda, &work[1], &result[2]);
sget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
bi_offset], lda, &z__[z_offset], lda, &z__[
z_offset], lda, &work[1], &result[3]);
ntest = 4;
/* Do tests (5) and (6): check Schur form of A and
compare eigenvalues with diagonals. */
temp1 = 0.f;
result[4] = 0.f;
result[5] = 0.f;
i__3 = mn_1.mplusn;
for (j = 1; j <= i__3; ++j) {
ilabad = FALSE_;
if (alphai[j] == 0.f) {
/* Computing MAX */
r__7 = smlnum, r__8 = (r__2 = alphar[j], dabs(
r__2)), r__7 = max(r__7,r__8), r__8 = (
r__3 = ai_ref(j, j), dabs(r__3));
/* Computing MAX */
r__9 = smlnum, r__10 = (r__5 = beta[j], dabs(r__5)
), r__9 = max(r__9,r__10), r__10 = (r__6 =
bi_ref(j, j), dabs(r__6));
temp2 = ((r__1 = alphar[j] - ai_ref(j, j), dabs(
r__1)) / dmax(r__7,r__8) + (r__4 = beta[j]
- bi_ref(j, j), dabs(r__4)) / dmax(r__9,
r__10)) / ulp;
if (j < mn_1.mplusn) {
if (ai_ref(j + 1, j) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (j > 1) {
if (ai_ref(j, j - 1) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
} else {
if (alphai[j] > 0.f) {
i1 = j;
} else {
i1 = j - 1;
}
if (i1 <= 0 || i1 >= mn_1.mplusn) {
ilabad = TRUE_;
} else if (i1 < mn_1.mplusn - 1) {
if (ai_ref(i1 + 2, i1 + 1) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
} else if (i1 > 1) {
if (ai_ref(i1, i1 - 1) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (! ilabad) {
sget53_(&ai_ref(i1, i1), lda, &bi_ref(i1, i1),
lda, &beta[j], &alphar[j], &alphai[j]
, &temp2, &iinfo);
if (iinfo >= 3) {
io___31.ciunit = *nout;
s_wsfe(&io___31);
do_fio(&c__1, (char *)&iinfo, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)
sizeof(integer));
e_wsfe();
*info = abs(iinfo);
}
} else {
temp2 = ulpinv;
}
}
temp1 = dmax(temp1,temp2);
if (ilabad) {
io___32.ciunit = *nout;
s_wsfe(&io___32);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
integer));
e_wsfe();
}
/* L10: */
}
result[5] = temp1;
ntest += 2;
/* Test (7) (if sorting worked) */
result[6] = 0.f;
if (linfo == mn_1.mplusn + 3) {
result[6] = ulpinv;
} else if (mm != mn_1.n) {
result[6] = ulpinv;
}
++ntest;
/* Test (8): compare the estimated value DIF and its
value. first, compute the exact DIF. */
result[7] = 0.f;
mn2 = mm * (mn_1.mplusn - mm) << 1;
if (ifunc >= 2 && mn2 <= *ncmax * *ncmax) {
/* Note: for either following two causes, there are
almost same number of test cases fail the test. */
i__3 = mn_1.mplusn - mm;
slakf2_(&mm, &i__3, &ai[ai_offset], lda, &ai_ref(mm +
1, mm + 1), &bi[bi_offset], &bi_ref(mm + 1,
mm + 1), &c__[c_offset], ldc);
i__3 = *lwork - 2;
sgesvd_("N", "N", &mn2, &mn2, &c__[c_offset], ldc, &s[
1], &work[1], &c__1, &work[2], &c__1, &work[3]
, &i__3, info);
diftru = s[mn2];
if (difest[1] == 0.f) {
if (diftru > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru == 0.f) {
if (difest[1] > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru > thrsh2 * difest[1] || diftru *
thrsh2 < difest[1]) {
/* Computing MAX */
r__1 = diftru / difest[1], r__2 = difest[1] /
diftru;
result[7] = dmax(r__1,r__2);
}
++ntest;
}
/* Test (9) */
result[8] = 0.f;
if (linfo == mn_1.mplusn + 2) {
if (diftru > abnrm * ulp) {
result[8] = ulpinv;
}
if (ifunc > 1 && difest[1] != 0.f) {
result[8] = ulpinv;
}
if (ifunc == 1 && pl[0] != 0.f) {
result[8] = ulpinv;
}
++ntest;
}
ntestt += ntest;
/* Print out tests which fail. */
for (j = 1; j <= 9; ++j) {
if (result[j - 1] >= *thresh) {
/* If this is the first test to fail,
print a header to the data file. */
if (nerrs == 0) {
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, "SGX", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___36.ciunit = *nout;
s_wsfe(&io___36);
e_wsfe();
/* Tests performed */
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, "orthogonal", (ftnlen)10);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (i__ = 1; i__ <= 4; ++i__) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[j - 1] < 1e4f) {
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
real));
do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
sizeof(real));
e_wsfe();
} else {
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
real));
do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
sizeof(real));
e_wsfe();
}
}
/* L20: */
}
L30:
;
}
/* L40: */
}
/* L50: */
}
/* L60: */
}
goto L150;
L70:
/* Read in data from file to check accuracy of condition estimation
Read input data until N=0 */
nptknt = 0;
L80:
io___42.ciunit = *nin;
i__1 = s_rsle(&io___42);
if (i__1 != 0) {
goto L140;
}
i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer))
;
if (i__1 != 0) {
goto L140;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L140;
}
if (mn_1.mplusn == 0) {
goto L140;
}
io___43.ciunit = *nin;
i__1 = s_rsle(&io___43);
if (i__1 != 0) {
goto L140;
}
i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.n, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L140;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L140;
}
i__1 = mn_1.mplusn;
for (i__ = 1; i__ <= i__1; ++i__) {
io___44.ciunit = *nin;
s_rsle(&io___44);
i__2 = mn_1.mplusn;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__4, &c__1, (char *)&ai_ref(i__, j), (ftnlen)sizeof(real)
);
}
e_rsle();
/* L90: */
}
i__1 = mn_1.mplusn;
for (i__ = 1; i__ <= i__1; ++i__) {
io___45.ciunit = *nin;
s_rsle(&io___45);
i__2 = mn_1.mplusn;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__4, &c__1, (char *)&bi_ref(i__, j), (ftnlen)sizeof(real)
);
}
e_rsle();
/* L100: */
}
io___46.ciunit = *nin;
s_rsle(&io___46);
do_lio(&c__4, &c__1, (char *)&pltru, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&diftru, (ftnlen)sizeof(real));
e_rsle();
++nptknt;
mn_1.fs = TRUE_;
mn_1.k = 0;
mn_1.m = mn_1.mplusn - mn_1.n;
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &a[
a_offset], lda);
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &b[
b_offset], lda);
/* Compute the Schur factorization while swaping the
m-by-m (1,1)-blocks with n-by-n (2,2)-blocks. */
sggesx_("V", "V", "S", (L_fp)slctsx_, "B", &mn_1.mplusn, &ai[ai_offset],
lda, &bi[bi_offset], lda, &mm, &alphar[1], &alphai[1], &beta[1], &
q[q_offset], lda, &z__[z_offset], lda, pl, difest, &work[1],
lwork, &iwork[1], liwork, &bwork[1], &linfo);
if (linfo != 0 && linfo != mn_1.mplusn + 2) {
result[0] = ulpinv;
io___48.ciunit = *nout;
s_wsfe(&io___48);
do_fio(&c__1, "SGGESX", (ftnlen)6);
do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
goto L130;
}
/* Compute the norm(A, B)
(should this be norm of (A,B) or (AI,BI)?) */
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &work[1],
&mn_1.mplusn);
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &work[
mn_1.mplusn * mn_1.mplusn + 1], &mn_1.mplusn);
i__1 = mn_1.mplusn << 1;
abnrm = slange_("Fro", &mn_1.mplusn, &i__1, &work[1], &mn_1.mplusn, &work[
1]);
/* Do tests (1) to (4) */
sget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[ai_offset], lda, &q[
q_offset], lda, &z__[z_offset], lda, &work[1], result);
sget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
q_offset], lda, &z__[z_offset], lda, &work[1], &result[1]);
sget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
q_offset], lda, &q[q_offset], lda, &work[1], &result[2]);
sget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &z__[
z_offset], lda, &z__[z_offset], lda, &work[1], &result[3]);
/* Do tests (5) and (6): check Schur form of A and compare
eigenvalues with diagonals. */
ntest = 6;
temp1 = 0.f;
result[4] = 0.f;
result[5] = 0.f;
i__1 = mn_1.mplusn;
for (j = 1; j <= i__1; ++j) {
ilabad = FALSE_;
if (alphai[j] == 0.f) {
/* Computing MAX */
r__7 = smlnum, r__8 = (r__2 = alphar[j], dabs(r__2)), r__7 = max(
r__7,r__8), r__8 = (r__3 = ai_ref(j, j), dabs(r__3));
/* Computing MAX */
r__9 = smlnum, r__10 = (r__5 = beta[j], dabs(r__5)), r__9 = max(
r__9,r__10), r__10 = (r__6 = bi_ref(j, j), dabs(r__6));
temp2 = ((r__1 = alphar[j] - ai_ref(j, j), dabs(r__1)) / dmax(
r__7,r__8) + (r__4 = beta[j] - bi_ref(j, j), dabs(r__4)) /
dmax(r__9,r__10)) / ulp;
if (j < mn_1.mplusn) {
if (ai_ref(j + 1, j) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (j > 1) {
if (ai_ref(j, j - 1) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
} else {
if (alphai[j] > 0.f) {
i1 = j;
} else {
i1 = j - 1;
}
if (i1 <= 0 || i1 >= mn_1.mplusn) {
ilabad = TRUE_;
} else if (i1 < mn_1.mplusn - 1) {
if (ai_ref(i1 + 2, i1 + 1) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
} else if (i1 > 1) {
if (ai_ref(i1, i1 - 1) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (! ilabad) {
sget53_(&ai_ref(i1, i1), lda, &bi_ref(i1, i1), lda, &beta[j],
&alphar[j], &alphai[j], &temp2, &iinfo);
if (iinfo >= 3) {
io___49.ciunit = *nout;
s_wsfe(&io___49);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
}
} else {
temp2 = ulpinv;
}
}
temp1 = dmax(temp1,temp2);
if (ilabad) {
io___50.ciunit = *nout;
s_wsfe(&io___50);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
}
/* L110: */
}
result[5] = temp1;
/* Test (7) (if sorting worked) <--------- need to be checked. */
ntest = 7;
result[6] = 0.f;
if (linfo == mn_1.mplusn + 3) {
result[6] = ulpinv;
}
/* Test (8): compare the estimated value of DIF and its true value. */
ntest = 8;
result[7] = 0.f;
if (difest[1] == 0.f) {
if (diftru > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru == 0.f) {
if (difest[1] > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru > thrsh2 * difest[1] || diftru * thrsh2 < difest[1]) {
/* Computing MAX */
r__1 = diftru / difest[1], r__2 = difest[1] / diftru;
result[7] = dmax(r__1,r__2);
}
/* Test (9) */
ntest = 9;
result[8] = 0.f;
if (linfo == mn_1.mplusn + 2) {
if (diftru > abnrm * ulp) {
result[8] = ulpinv;
}
if (ifunc > 1 && difest[1] != 0.f) {
result[8] = ulpinv;
}
if (ifunc == 1 && pl[0] != 0.f) {
result[8] = ulpinv;
}
}
/* Test (10): compare the estimated value of PL and it true value. */
ntest = 10;
result[9] = 0.f;
if (pl[0] == 0.f) {
if (pltru > abnrm * ulp) {
result[9] = ulpinv;
}
} else if (pltru == 0.f) {
if (pl[0] > abnrm * ulp) {
result[9] = ulpinv;
}
} else if (pltru > *thresh * pl[0] || pltru * *thresh < pl[0]) {
result[9] = ulpinv;
}
ntestt += ntest;
/* Print out tests which fail. */
i__1 = ntest;
for (j = 1; j <= i__1; ++j) {
if (result[j - 1] >= *thresh) {
/* If this is the first test to fail,
print a header to the data file. */
if (nerrs == 0) {
io___51.ciunit = *nout;
s_wsfe(&io___51);
do_fio(&c__1, "SGX", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___52.ciunit = *nout;
s_wsfe(&io___52);
e_wsfe();
/* Tests performed */
io___53.ciunit = *nout;
s_wsfe(&io___53);
do_fio(&c__1, "orthogonal", (ftnlen)10);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (i__ = 1; i__ <= 4; ++i__) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[j - 1] < 1e4f) {
io___54.ciunit = *nout;
s_wsfe(&io___54);
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(real));
e_wsfe();
} else {
io___55.ciunit = *nout;
s_wsfe(&io___55);
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(real));
e_wsfe();
}
}
/* L120: */
}
L130:
goto L80;
L140:
L150:
/* Summary */
alasvm_("SGX", nout, &nerrs, &ntestt, &c__0);
work[1] = (real) maxwrk;
return 0;
/* End of SDRGSX */
} /* sdrgsx_ */
/* DECK CPSI */
/* Complex */ void cpsi_(complex * ret_val, complex *zin)
{
/* Initialized data */
static real bern[13] = { .083333333333333333f,-.0083333333333333333f,
.0039682539682539683f,-.0041666666666666667f,
.0075757575757575758f,-.021092796092796093f,.083333333333333333f,
-.44325980392156863f,3.0539543302701197f,-26.456212121212121f,
281.46014492753623f,-3454.8853937728938f,54827.583333333333f };
static real pi = 3.141592653589793f;
static logical first = TRUE_;
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
doublereal d__1, d__2;
complex q__1, q__2, q__3, q__4, q__5, q__6;
/* Local variables */
static integer i__, n;
static real x, y;
static complex z__;
static integer ndx;
static real rbig;
extern /* Complex */ void ccot_(complex *, complex *);
static complex corr;
static real rmin;
static complex z2inv;
static real cabsz, bound, dxrel;
static integer nterm;
extern doublereal r1mach_(integer *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE CPSI */
/* ***PURPOSE Compute the Psi (or Digamma) function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C7C */
/* ***TYPE COMPLEX (PSI-S, DPSI-D, CPSI-C) */
/* ***KEYWORDS DIGAMMA FUNCTION, FNLIB, PSI FUNCTION, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* PSI(X) calculates the psi (or digamma) function of X. PSI(X) */
/* is the logarithmic derivative of the gamma function of X. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED CCOT, R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 780501 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890531 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900727 Added EXTERNAL statement. (WRB) */
/* ***END PROLOGUE CPSI */
/* ***FIRST EXECUTABLE STATEMENT CPSI */
if (first) {
nterm = log(r1mach_(&c__3)) * -.3f;
/* MAYBE BOUND = N*(0.1*EPS)**(-1/(2*N-1)) / (PI*EXP(1)) */
d__1 = (doublereal) (r1mach_(&c__3) * .1f);
d__2 = (doublereal) (-1.f / ((nterm << 1) - 1));
bound = nterm * .1171f * pow_dd(&d__1, &d__2);
dxrel = sqrt(r1mach_(&c__4));
/* Computing MAX */
r__1 = log(r1mach_(&c__1)), r__2 = -log(r1mach_(&c__2));
rmin = exp(dmax(r__1,r__2) + .011f);
rbig = 1.f / r1mach_(&c__3);
}
first = FALSE_;
z__.r = zin->r, z__.i = zin->i;
x = z__.r;
y = r_imag(&z__);
if (y < 0.f) {
r_cnjg(&q__1, &z__);
z__.r = q__1.r, z__.i = q__1.i;
}
corr.r = 0.f, corr.i = 0.f;
cabsz = c_abs(&z__);
if (x >= 0.f && cabsz > bound) {
goto L50;
}
if (x < 0.f && dabs(y) > bound) {
goto L50;
}
if (cabsz < bound) {
goto L20;
}
/* USE THE REFLECTION FORMULA FOR REAL(Z) NEGATIVE, ABS(Z) LARGE, AND */
/* ABS(AIMAG(Y)) SMALL. */
r__1 = -pi;
q__3.r = pi * z__.r, q__3.i = pi * z__.i;
ccot_(&q__2, &q__3);
q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
corr.r = q__1.r, corr.i = q__1.i;
q__1.r = 1.f - z__.r, q__1.i = -z__.i;
z__.r = q__1.r, z__.i = q__1.i;
goto L50;
/* USE THE RECURSION RELATION FOR ABS(Z) SMALL. */
L20:
if (cabsz < rmin) {
xermsg_("SLATEC", "CPSI", "CPSI CALLED WITH Z SO NEAR 0 THAT CPSI OV"
"ERFLOWS", &c__2, &c__2, (ftnlen)6, (ftnlen)4, (ftnlen)48);
}
if (x >= -.5f || dabs(y) > dxrel) {
goto L30;
}
r__2 = x - .5f;
r__1 = r_int(&r__2);
q__2.r = z__.r - r__1, q__2.i = z__.i;
q__1.r = q__2.r / x, q__1.i = q__2.i / x;
if (c_abs(&q__1) < dxrel) {
xermsg_("SLATEC", "CPSI", "ANSWER LT HALF PRECISION BECAUSE Z TOO NE"
"AR NEGATIVE INTEGER", &c__1, &c__1, (ftnlen)6, (ftnlen)4, (
ftnlen)60);
}
if (y == 0.f && x == r_int(&x)) {
xermsg_("SLATEC", "CPSI", "Z IS A NEGATIVE INTEGER", &c__3, &c__2, (
ftnlen)6, (ftnlen)4, (ftnlen)23);
}
L30:
/* Computing 2nd power */
r__1 = bound;
/* Computing 2nd power */
r__2 = y;
n = sqrt(r__1 * r__1 - r__2 * r__2) - x + 1.f;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
c_div(&q__2, &c_b28, &z__);
q__1.r = corr.r - q__2.r, q__1.i = corr.i - q__2.i;
corr.r = q__1.r, corr.i = q__1.i;
q__1.r = z__.r + 1.f, q__1.i = z__.i;
z__.r = q__1.r, z__.i = q__1.i;
/* L40: */
}
/* NOW EVALUATE THE ASYMPTOTIC SERIES FOR SUITABLY LARGE Z. */
L50:
if (cabsz > rbig) {
c_log(&q__2, &z__);
q__1.r = q__2.r + corr.r, q__1.i = q__2.i + corr.i;
ret_val->r = q__1.r, ret_val->i = q__1.i;
}
if (cabsz > rbig) {
goto L70;
}
ret_val->r = 0.f, ret_val->i = 0.f;
pow_ci(&q__2, &z__, &c__2);
c_div(&q__1, &c_b28, &q__2);
z2inv.r = q__1.r, z2inv.i = q__1.i;
i__1 = nterm;
for (i__ = 1; i__ <= i__1; ++i__) {
ndx = nterm + 1 - i__;
i__2 = ndx - 1;
q__2.r = z2inv.r * ret_val->r - z2inv.i * ret_val->i, q__2.i =
z2inv.r * ret_val->i + z2inv.i * ret_val->r;
q__1.r = bern[i__2] + q__2.r, q__1.i = q__2.i;
ret_val->r = q__1.r, ret_val->i = q__1.i;
/* L60: */
}
c_log(&q__4, &z__);
c_div(&q__5, &c_b34, &z__);
q__3.r = q__4.r - q__5.r, q__3.i = q__4.i - q__5.i;
q__6.r = ret_val->r * z2inv.r - ret_val->i * z2inv.i, q__6.i =
ret_val->r * z2inv.i + ret_val->i * z2inv.r;
q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i;
q__1.r = q__2.r + corr.r, q__1.i = q__2.i + corr.i;
ret_val->r = q__1.r, ret_val->i = q__1.i;
L70:
if (y < 0.f) {
r_cnjg(&q__1, ret_val);
ret_val->r = q__1.r, ret_val->i = q__1.i;
}
return ;
} /* cpsi_ */
/* 1992-1993: TC93 version */
/* Subroutine */ int dmdsm_(real *l, real *b, integer *ndir, real *dmpsr,
real *dist, char *limit, real *sm, real *smtau, real *smtheta, real *
smiso, ftnlen limit_len)
{
/* Initialized data */
static real r0 = 8.5f;
static real rrmax = 50.f;
static real zmax = 25.f;
static real dmax__ = 50.f;
static logical first = TRUE_;
/* System generated locals */
real r__1, r__2, r__3;
doublereal d__1;
/* Builtin functions */
double sin(doublereal), cos(doublereal), sqrt(doublereal), pow_dd(
doublereal *, doublereal *);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
static real lhb_path__, lhb_dist__, lsb_path__, ldr_path__, dstep_pc__;
static integer whicharm;
static real lsb_dist__, ldr_dist__;
static integer hitclump;
static real d__;
static integer i__;
static real r__, x, y, z__, cb, dd, cl, dm, ne, sb, sl, rr;
extern /* Subroutine */ int density_2001__(real *, real *, real *, real *,
real *, real *, real *, real *, real *, real *, real *, real *,
real *, real *, real *, real *, real *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *);
static real dm1, dm2, ne1, ne2, loopi_path__, sm1, sm2, loopi_dist__, fgc,
dma, nea, fcn, sma, fvn, dsm1, dsm2, dmgc, negc, dmcn, necn,
dsma, smgc;
static integer wlhb;
static real smcn, dmvn, sm_sum1_last__;
static integer wlsb, wldr;
static real nevn, sm_sum2_last__, sm_sum3_last__, sm_sum4_last__, smvn,
f1val, f2val, faval, dsmgc, dsmcn, flism, dstep, dtest;
static integer wvoid, wlism, wtemp, nstep;
static real dsmvn, dmlism, nelism, dmstep, smlism;
static integer ncount, wloopi, wtotal;
static real sm_sum1__, sm_sum2__, sm_sum3__, sm_sum4__;
static integer hitvoid;
static real sm_term__, dsmlism;
/* Computes pulsar distance and scattering measure */
/* from model of Galactic electron distribution. */
/* Input: real l galactic longitude in radians */
/* real b galactic latitude in radians */
/* integer ndir >= 0 calculates dist from dmpsr */
/* < 0 for dmpsr from dist */
/* Input or output: */
/* real dmpsr (dispersion measure in pc/cm^3) */
/* real dist (distance in kpc) */
/* Output: */
/* char*1 limit (set to '>' if only a lower distance limit can be */
/* given; otherwise set to ' ') */
/* sm (scattering measure, uniform weighting) (kpc/m^{20/3}) */
/* smtau (scattering measure, weighting for pulse broadening) */
/* smtheta (scattering measure, weighting for angular broadening */
/* of galactic sources) */
/* smiso (scattering measure appropriate for calculating the */
/* isoplanatic angle at the source's location' */
/* parameter(alpha = 11./3.) */
/* parameter(pi = 3.14159) */
/* parameter(c_sm = (alpha - 3.) / 2. * (2.*pi)**(4.-alpha) ) */
/* constant in sm definition */
/* units conversion for sm */
/* parameters of large-scale components (inner+outer+arm components): */
/* factors for controlling individual spiral arms: */
/* narm: multiplies electron density (in addition to the`fac'' */
/* quantities) */
/* warm: arm width factors that multiply nominal arm width */
/* harm: arm scale height factors */
/* farm: factors that multiply n_e^2 when calculating SM */
/* Large scale components: */
/* Galactic center: */
/* LISM: */
/* clumps: */
/* voids: */
/* subroutines needed: */
/* density_2001 (and those that it calls) in density.NE2001.f */
/* scattering routines in scattering98.f */
/* other variables */
/* data rrmax/30.0/ ! Max radius for reliable ne */
/* data zmax/1.76/ ! Max |z| */
/* data zmax/5.00/ ! Max |z| */
/* Max radius for reliable ne */
/* Max |z| */
/* logical first */
/* maximum distance calculated */
/* other variables */
/* real x, y, z, r, rr */
/* real sl, cl, sb, cb */
/* real d, dstep, dtest, dstep_pc, dd */
/* real dm, dmstep */
/* real sm_sum1, sm_sum2, sm_sum3, sm_sum4, sm_term */
/* real sm_sum1_last, sm_sum2_last, sm_sum3_last, sm_sum4_last */
/* integer nstep */
/* integer ncount */
/* integer i */
/* real dm1, dm2, dma, dmgc, dmlism, dmcN, dmvN */
/* real sm1, sm2, sma, smgc, smlism, smcN, smvN */
/* real dsm1, dsm2, dsma, dsmgc, dsmlism, dsmcN, dsmvN */
/* integer wtotal */
/* real ne */
/* open(24,file='fort.24', status='unknown') */
/* open(25,file='fort.25', status='unknown') */
/* write(25,*) l*180./acos(-1.), b*180./acos(-1.), ' = l, b' */
/* write(25,1000) */
/* L1000: */
if (first) {
/* initial call to density routine to set variable values */
/* through read-in of parameter file: */
x = 0.f;
y = r0;
z__ = 0.f;
density_2001__(&x, &y, &z__, &ne1, &ne2, &nea, &negc, &nelism, &necn,
&nevn, &f1val, &f2val, &faval, &fgc, &flism, &fcn, &fvn, &
whicharm, &wlism, &wldr, &wlhb, &wlsb, &wloopi, &hitclump, &
hitvoid, &wvoid);
/* write(6,*) 'ne1,ne2,negc,nelism,necN,nevN = ', */
/* . ne1,ne2,negc,nelism,necN,nevN */
first = FALSE_;
}
sl = sin(*l);
cl = cos(*l);
sb = sin(*b);
cb = cos(*b);
*(unsigned char *)limit = ' ';
/* dstep=0.02 ! Step size in kpc */
/* dstep = min(h1, h2) / 10. ! step size in terms of scale heights */
dstep = .01f;
if (*ndir < 0) {
dtest = *dist;
}
if (*ndir >= 0) {
dtest = *dmpsr / (galparams_1.n1h1 / galparams_1.h1);
}
/* approximate test distanc */
nstep = dtest / dstep;
/* approximate number of steps */
if (nstep < 10) {
dstep = dtest / 10;
}
/* Sum until dm is reached (ndir >= 0) or dist is reached (ndir < 0). */
/* Guard against too few terms by counting number of terms (ncount) so that */
/* routine will work for n_e models with large n_e near the Sun. */
/* make # steps >= 10 */
L5:
dstep_pc__ = dstep * 1e3f;
dm = 0.f;
sm_sum1__ = 0.f;
/* sum of C_n^2 */
sm_sum2__ = 0.f;
/* sum of C_n^2 * s */
sm_sum3__ = 0.f;
/* sum of C_n^2 * s^2 */
sm_sum4__ = 0.f;
/* sum of C_n^2 * s^{5./3.} */
for (i__ = 1; i__ <= 6; ++i__) {
armpathlengths_1.armpaths[i__ - 1] = 0.f;
armpathlengths_1.armdistances[i__ - 1] = 0.f;
}
dm1 = 0.f;
dm2 = 0.f;
dma = 0.f;
dmgc = 0.f;
dmlism = 0.f;
dmcn = 0.f;
dmvn = 0.f;
sm1 = 0.f;
sm2 = 0.f;
sma = 0.f;
smgc = 0.f;
smlism = 0.f;
smcn = 0.f;
smvn = 0.f;
ldr_path__ = 0.f;
lhb_path__ = 0.f;
lsb_path__ = 0.f;
loopi_path__ = 0.f;
ldr_dist__ = 0.f;
lhb_dist__ = 0.f;
lsb_dist__ = 0.f;
loopi_dist__ = 0.f;
ncount = 0;
d__ = dstep * -.5f;
for (i__ = 1; i__ <= 99999; ++i__) {
++ncount;
d__ += dstep;
/* Distance from Sun in kpc */
r__ = d__ * cb;
x = r__ * sl;
y = r0 - r__ * cl;
z__ = d__ * sb;
/* Computing 2nd power */
r__1 = x;
/* Computing 2nd power */
r__2 = y;
rr = sqrt(r__1 * r__1 + r__2 * r__2);
/* Galactocentric radius */
if (*ndir >= 0 && (d__ > dmax__ || dabs(z__) > zmax || rr > rrmax)) {
goto L20;
}
if (*ndir < 3) {
density_2001__(&x, &y, &z__, &ne1, &ne2, &nea, &negc, &nelism, &
necn, &nevn, &f1val, &f2val, &faval, &fgc, &flism, &fcn, &
fvn, &whicharm, &wlism, &wldr, &wlhb, &wlsb, &wloopi, &
hitclump, &hitvoid, &wvoid);
}
if (*ndir >= 3) {
r__1 = x + dxyz_1.dx0;
r__2 = y + dxyz_1.dy0;
r__3 = z__ + dxyz_1.dz0;
density_2001__(&r__1, &r__2, &r__3, &ne1, &ne2, &nea, &negc, &
nelism, &necn, &nevn, &f1val, &f2val, &faval, &fgc, &
flism, &fcn, &fvn, &whicharm, &wlism, &wldr, &wlhb, &wlsb,
&wloopi, &hitclump, &hitvoid, &wvoid);
}
/* wlism = 1 causes the lism component to override smooth Galactic components */
/* wvoid = 1 overrides everything except clumps */
ne = (1.f - modelflags_1.wglism * wlism) * (modelflags_1.wg1 * ne1 +
modelflags_1.wg2 * ne2 + modelflags_1.wga * nea +
modelflags_1.wggc * negc) + modelflags_1.wglism * wlism *
nelism;
ne = (1 - modelflags_1.wgvn * wvoid) * ne + modelflags_1.wgvn * wvoid
* nevn + modelflags_1.wgcn * necn;
dmstep = dstep_pc__ * ne;
dm += dmstep;
/* Add DM for this step */
wtotal = (1 - modelflags_1.wgvn * wvoid) * (1 - modelflags_1.wglism *
wlism);
dm1 += wtotal * modelflags_1.wg1 * ne1;
dm2 += wtotal * modelflags_1.wg2 * ne2;
dma += wtotal * modelflags_1.wga * nea;
dmgc += wtotal * modelflags_1.wggc * negc;
dmlism += (1.f - modelflags_1.wgvn * wvoid) * modelflags_1.wglism *
wlism * nelism;
dmcn += modelflags_1.wgcn * necn;
dmvn += modelflags_1.wgvn * wvoid * nevn;
/* write(24,"('n:',7f10.6,1x))") */
/* . ne1,ne2,nea,negc,nelism,necN,nevN */
/* write(24,"(i2,1x,7(f10.5,1x))") */
/* . wtotal,dm1,dm2,dma,dmgc,dmlism,dmcN,dmvN */
/* sm_term = */
/* . (1.-wglism*wlism)* */
/* . (wg1 * F1 * ne1**2 + */
/* . wg2 * F2 * ne2**2 + */
/* . wga * Fa * nea**2 + */
/* . wggc * Fgc * negc**2) + */
/* . wglism*wlism * Flism * nelism**2 */
/* sm_clumps = FcN * necN**2 */
/* sm_voids = FvN * nevN**2 */
/* sm_term = (1-wgvN*wvoid) * sm_term */
/* . + wgvN * wvoid * sm_voids */
/* . + wgcN * sm_clumps */
/* Computing 2nd power */
r__1 = ne1;
dsm1 = wtotal * modelflags_1.wg1 * (r__1 * r__1) * galparams_1.f1;
/* Computing 2nd power */
r__1 = ne2;
dsm2 = wtotal * modelflags_1.wg2 * (r__1 * r__1) * galparams_1.f2;
/* Computing 2nd power */
r__1 = nea;
dsma = wtotal * modelflags_1.wga * (r__1 * r__1) * galparams_1.fa;
/* Computing 2nd power */
r__1 = negc;
dsmgc = wtotal * modelflags_1.wggc * (r__1 * r__1) * fgc;
/* Computing 2nd power */
r__1 = nelism;
dsmlism = (1.f - modelflags_1.wgvn * wvoid) * modelflags_1.wglism *
wlism * (r__1 * r__1) * flism;
/* Computing 2nd power */
r__1 = necn;
dsmcn = modelflags_1.wgcn * (r__1 * r__1) * fcn;
/* Computing 2nd power */
r__1 = nevn;
dsmvn = modelflags_1.wgvn * wvoid * (r__1 * r__1) * fvn;
sm_term__ = dsm1 + dsm2 + dsma + dsmgc + dsmlism + dsmcn + dsmvn;
sm1 += dsm1;
sm2 += dsm2;
sma += dsma;
smgc += dsmgc;
smlism += dsmlism;
smcn += dsmcn;
smvn += dsmvn;
sm_sum1__ += sm_term__;
sm_sum2__ += sm_term__ * d__;
/* Computing 2nd power */
r__1 = d__;
sm_sum3__ += sm_term__ * (r__1 * r__1);
d__1 = (doublereal) d__;
sm_sum4__ += sm_term__ * pow_dd(&d__1, &c_b8);
/* pathlengths through LISM components: */
/* take into account the weighting hierarchy, LHB:LOOPI:LSB:LDR */
if (wlism == 1) {
if (wlhb == 1) {
lhb_path__ += dstep;
lhb_dist__ += d__;
}
if (wloopi == 1) {
wtemp = 1 - wlhb;
loopi_path__ += wtemp * dstep;
loopi_dist__ += wtemp * d__;
}
if (wlsb == 1) {
wtemp = (1 - wlhb) * (1 - wloopi);
lsb_path__ += wtemp * dstep;
lsb_dist__ += wtemp * d__;
}
if (wldr == 1) {
wtemp = (1 - wlhb) * (1 - wloopi) * (1 - wlsb);
ldr_path__ += wtemp * dstep;
ldr_dist__ += wtemp * d__;
}
}
/* pathlengths: whicharm = 0,5 (currently). */
/* 1,4 for the equivalent of the TC93 arms */
/* 5 for the local arm */
/* 0 means interarm paths */
armpathlengths_1.armpaths[whicharm] += dstep;
armpathlengths_1.armdistances[whicharm] += d__;
/* write(99,"(2(f8.3,1x), 7f10.6)") */
/* . d, dm, sm_term, sm_sum1, sm_sum2, sm_sum3, */
/* . sm_sum1_last, sm_sum2_last, sm_sum3_last */
if (*ndir >= 0 && dm >= *dmpsr) {
goto L30;
}
/* Reached pulsar's DM? */
if (*ndir < 0 && d__ >= *dist) {
goto L40;
}
/* Reached pulsar's dist? */
sm_sum1_last__ = sm_sum1__;
sm_sum2_last__ = sm_sum2__;
sm_sum3_last__ = sm_sum3__;
sm_sum4_last__ = sm_sum4__;
/* write(25, */
/* . "(4(f7.3,1x),f8.4,1x,e10.3,1x,i1,1x,i4,1x,i2)") */
/* . d,x,y,z,ne,sm_term,whicharm,hitclump,hitvoid */
/* L10: */
}
s_stop("loop limit", (ftnlen)10);
L20:
*(unsigned char *)limit = '>';
/* Only lower limit is possible */
*dist = d__ - dstep * .5f;
goto L999;
L30:
*dist = d__ + dstep * .5f - dstep * (dm - *dmpsr) / dmstep;
/* Interpolate last step */
if (ncount < 10) {
dstep /= 10.f;
goto L5;
}
goto L999;
L40:
*dmpsr = dm - dmstep * (d__ + dstep * .5f - *dist) / dstep;
if (ncount < 10) {
dstep /= 10.f;
goto L5;
}
L999:
/* normalize the mean distances: */
if (ldr_path__ > 0.f) {
ldr_dist__ /= ldr_path__ / dstep;
}
if (lhb_path__ > 0.f) {
lhb_dist__ /= lhb_path__ / dstep;
}
if (lsb_path__ > 0.f) {
lsb_dist__ /= lsb_path__ / dstep;
}
if (loopi_path__ > 0.f) {
loopi_dist__ /= loopi_path__ / dstep;
}
dd = d__ + dstep * .5f - *dist;
/* subtract dd from armpath for latest arm (or iterarm) at end of LOS */
armpathlengths_1.armpaths[whicharm - 1] -= dd;
for (i__ = 1; i__ <= 6; ++i__) {
/* Computing MAX */
r__1 = 1.f, r__2 = armpathlengths_1.armpaths[i__ - 1] / dstep;
armpathlengths_1.armdistances[i__ - 1] /= dmax(r__1,r__2);
/* mean distan */
}
dm1 *= dstep_pc__;
dm2 *= dstep_pc__;
dma *= dstep_pc__;
dmgc *= dstep_pc__;
dmlism *= dstep_pc__;
dmcn *= dstep_pc__;
dmvn *= dstep_pc__;
/* dsm = sm_term * (d+0.5*dstep - dist) */
/* dsm = sm_term * dd */
/* sm_sum2 = sm_sum2 - dsm * d */
/* sm_sum3 = sm_sum3 - dsm * d**2 */
/* sm_sum4 = sm_sum4 - dsm * d**1.67 */
/* sm_sum1 = sm_sum1 - dsm */
/* write(99,*) 'dmdsm: sm_term, sm_sum1, sm_sum1_last = ', */
/* . sm_term, sm_sum1, sm_sum1_last */
/* write(6,*) 'dmdsm: dsum1, sm_term = ', */
/* . sm_sum1-sm_sum1_last, sm_term */
sm_sum1__ -= dd * (sm_sum1__ - sm_sum1_last__) / dstep;
sm_sum2__ -= dd * (sm_sum2__ - sm_sum2_last__) / dstep;
sm_sum3__ -= dd * (sm_sum3__ - sm_sum3_last__) / dstep;
sm_sum4__ -= dd * (sm_sum4__ - sm_sum4_last__) / dstep;
/* sm_sum2 = sm_sum2 - dsm * dist */
/* sm_sum3 = sm_sum3 - dsm * dist**2 */
/* sm_sum4 = sm_sum4 - dsm * dist**1.67 */
*sm = dstep * 1.8389599999999999f * sm_sum1__;
/* Computing 2nd power */
r__1 = *dist;
*smtau = dstep * 11.033759999999999f * (sm_sum2__ / *dist - sm_sum3__ / (
r__1 * r__1));
/* Computing 2nd power */
r__1 = *dist;
*smtheta = dstep * 5.5168799999999996f * (sm_sum1__ + sm_sum3__ / (r__1 *
r__1) - sm_sum2__ * 2.f / *dist);
*smiso = dstep * 1.8389599999999999f * sm_sum4__;
sm1 = sm1 * 1.8389599999999999f * dstep;
sm2 = sm2 * 1.8389599999999999f * dstep;
sma = sma * 1.8389599999999999f * dstep;
smgc = smgc * 1.8389599999999999f * dstep;
smlism = smlism * 1.8389599999999999f * dstep;
smcn = smcn * 1.8389599999999999f * dstep;
smvn = smvn * 1.8389599999999999f * dstep;
/* write(24,*) dm1, dm2, dma, dmgc, dmlism, dmcN, dmvN, dm */
/* write(24,"(a,a)") 'LISM path lengths (kpc)', */
/* . ' with weighting hierarchy LHB:LOOPI:LSB:LDR' */
/* write(24,"(t15, a)") ' LHB LoopI LSB LDR' */
/* write(24, "(t3, a, t15, 4(f6.3, 3x))") 'Length', */
/* . lhb_path, loopI_path, lsb_path, ldr_path */
/* write(24, "(t3, a, t15, 4(f6.3, 3x))") 'Mean Dist.', */
/* . lhb_dist, loopI_dist, lsb_dist, ldr_dist */
/* write(24,"(a)") 'Fractional contributions to DM:' */
/* write(24,"(a,a)") */
/* . ' outer inner arms gc lism', */
/* . ' clumps voids DM' */
/* write(24,"(7(f7.3,1x), f10.3)") */
/* . dm1/dm, dm2/dm, dma/dm, dmgc/dm, */
/* . dmlism/dm, dmcN/dm, dmvN/dm, dm */
/* write(24,"(a)") 'Fractional contributions to SM:' */
/* write(24,"(a,a)") */
/* . ' outer inner arms gc lism', */
/* . ' clumps voids SM' */
/* write(24,"(7(f7.3,1x), e10.3)") */
/* . sm1/sm, sm2/sm, sma/sm, smgc/sm, */
/* . smlism/sm, smcN/sm, smvN/sm, sm */
/* write(24,"(a)") 'Path lengths through spiral arms:' */
/* write(24,"(t1,a,t10, a, t30, a)") */
/* . 'Arm','Mean Distance','Path Length (arm=0 => interarm)' */
/* do i=1,narmsmax1 */
/* write(24,"(i2,t10,f8.3,t30,f8.3)") */
/* . i-1, armdistances(i), armpaths(i) */
/* enddo */
/* close(24) */
/* close(25) */
return 0;
} /* dmdsm_ */
/* Subroutine */ int cppequ_(char *uplo, integer *n, complex *ap, real *s,
real *scond, real *amax, integer *info)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
/* Local variables */
integer i__, jj;
real smin;
logical upper;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CPPEQU computes row and column scalings intended to equilibrate a */
/* Hermitian positive definite matrix A in packed storage and reduce */
/* its condition number (with respect to the two-norm). S contains the */
/* scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix */
/* B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal. */
/* This choice of S puts the condition number of B within a factor N of */
/* the smallest possible condition number over all possible diagonal */
/* scalings. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The upper or lower triangle of the Hermitian matrix A, packed */
/* columnwise in a linear array. The j-th column of A is stored */
/* in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* S (output) REAL array, dimension (N) */
/* If INFO = 0, S contains the scale factors for A. */
/* SCOND (output) REAL */
/* If INFO = 0, S contains the ratio of the smallest S(i) to */
/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
/* large nor too small, it is not worth scaling by S. */
/* AMAX (output) REAL */
/* Absolute value of largest matrix element. If AMAX is very */
/* close to overflow or very close to underflow, the matrix */
/* should be scaled. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
--s;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPPEQU", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*scond = 1.f;
*amax = 0.f;
return 0;
}
/* Initialize SMIN and AMAX. */
s[1] = ap[1].r;
smin = s[1];
*amax = s[1];
if (upper) {
/* UPLO = 'U': Upper triangle of A is stored. */
/* Find the minimum and maximum diagonal elements. */
jj = 1;
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
jj += i__;
i__2 = jj;
s[i__] = ap[i__2].r;
/* Computing MIN */
r__1 = smin, r__2 = s[i__];
smin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = *amax, r__2 = s[i__];
*amax = dmax(r__1,r__2);
}
} else {
/* UPLO = 'L': Lower triangle of A is stored. */
/* Find the minimum and maximum diagonal elements. */
jj = 1;
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
jj = jj + *n - i__ + 2;
i__2 = jj;
s[i__] = ap[i__2].r;
/* Computing MIN */
r__1 = smin, r__2 = s[i__];
smin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = *amax, r__2 = s[i__];
*amax = dmax(r__1,r__2);
}
}
if (smin <= 0.f) {
/* Find the first non-positive diagonal element and return. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s[i__] <= 0.f) {
*info = i__;
return 0;
}
}
} else {
/* Set the scale factors to the reciprocals */
/* of the diagonal elements. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
s[i__] = 1.f / sqrt(s[i__]);
}
/* Compute SCOND = min(S(I)) / max(S(I)) */
*scond = sqrt(smin) / sqrt(*amax);
}
return 0;
/* End of CPPEQU */
} /* cppequ_ */
/* Subroutine */ int cpot05_(char *uplo, integer *n, integer *nrhs, complex *
a, integer *lda, complex *b, integer *ldb, complex *x, integer *ldx,
complex *xact, integer *ldxact, real *ferr, real *berr, real *reslts)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
xact_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
integer i__, j, k;
real eps, tmp, diff, axbi;
integer imax;
real unfl, ovfl;
extern logical lsame_(char *, char *);
logical upper;
real xnorm;
extern integer icamax_(integer *, complex *, integer *);
extern doublereal slamch_(char *);
real errbnd;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPOT05 tests the error bounds from iterative refinement for the */
/* computed solution to a system of equations A*X = B, where A is a */
/* Hermitian n by n matrix. */
/* RESLTS(1) = test of the error bound */
/* = norm(X - XACT) / ( norm(X) * FERR ) */
/* A large value is returned if this ratio is not less than one. */
/* RESLTS(2) = residual from the iterative refinement routine */
/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows of the matrices X, B, and XACT, and the */
/* order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of columns of the matrices X, B, and XACT. */
/* NRHS >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The Hermitian matrix A. If UPLO = 'U', the leading n by n */
/* upper triangular part of A contains the upper triangular part */
/* of the matrix A, and the strictly lower triangular part of A */
/* is not referenced. If UPLO = 'L', the leading n by n lower */
/* triangular part of A contains the lower triangular part of */
/* the matrix A, and the strictly upper triangular part of A is */
/* not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input) COMPLEX array, dimension (LDB,NRHS) */
/* The right hand side vectors for the system of linear */
/* equations. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (input) COMPLEX array, dimension (LDX,NRHS) */
/* The computed solution vectors. Each vector is stored as a */
/* column of the matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* XACT (input) COMPLEX array, dimension (LDX,NRHS) */
/* The exact solution vectors. Each vector is stored as a */
/* column of the matrix XACT. */
/* LDXACT (input) INTEGER */
/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
/* FERR (input) REAL array, dimension (NRHS) */
/* The estimated forward error bounds for each solution vector */
/* X. If XTRUE is the true solution, FERR bounds the magnitude */
/* of the largest entry in (X - XTRUE) divided by the magnitude */
/* of the largest entry in X. */
/* BERR (input) REAL array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector (i.e., the smallest relative change in any entry of A */
/* or B that makes X an exact solution). */
/* RESLTS (output) REAL array, dimension (2) */
/* The maximum over the NRHS solution vectors of the ratios: */
/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 or NRHS = 0. */
/* 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;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.f;
reslts[2] = 0.f;
return 0;
}
eps = slamch_("Epsilon");
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
upper = lsame_(uplo, "U");
/* Test 1: Compute the maximum of */
/* norm(X - XACT) / ( norm(X) * FERR ) */
/* over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = icamax_(n, &x[j * x_dim1 + 1], &c__1);
/* Computing MAX */
i__2 = imax + j * x_dim1;
r__3 = (r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x[imax + j *
x_dim1]), dabs(r__2));
xnorm = dmax(r__3,unfl);
diff = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * x_dim1;
i__4 = i__ + j * xact_dim1;
q__2.r = x[i__3].r - xact[i__4].r, q__2.i = x[i__3].i - xact[i__4]
.i;
q__1.r = q__2.r, q__1.i = q__2.i;
/* Computing MAX */
r__3 = diff, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
q__1), dabs(r__2));
diff = dmax(r__3,r__4);
/* L10: */
}
if (xnorm > 1.f) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1.f / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
errbnd = dmax(r__1,r__2);
} else {
errbnd = 1.f / eps;
}
L30:
;
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
i__1 = *nrhs;
for (k = 1; k <= i__1; ++k) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + k * b_dim1;
tmp = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[i__ + k *
b_dim1]), dabs(r__2));
if (upper) {
i__3 = i__ - 1;
for (j = 1; j <= i__3; ++j) {
i__4 = j + i__ * a_dim1;
i__5 = j + k * x_dim1;
tmp += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
a[j + i__ * a_dim1]), dabs(r__2))) * ((r__3 = x[
i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[j + k *
x_dim1]), dabs(r__4)));
/* L40: */
}
i__3 = i__ + i__ * a_dim1;
i__4 = i__ + k * x_dim1;
tmp += (r__1 = a[i__3].r, dabs(r__1)) * ((r__2 = x[i__4].r,
dabs(r__2)) + (r__3 = r_imag(&x[i__ + k * x_dim1]),
dabs(r__3)));
i__3 = *n;
for (j = i__ + 1; j <= i__3; ++j) {
i__4 = i__ + j * a_dim1;
i__5 = j + k * x_dim1;
tmp += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
a[i__ + j * a_dim1]), dabs(r__2))) * ((r__3 = x[
i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[j + k *
x_dim1]), dabs(r__4)));
/* L50: */
}
} else {
i__3 = i__ - 1;
for (j = 1; j <= i__3; ++j) {
i__4 = i__ + j * a_dim1;
i__5 = j + k * x_dim1;
tmp += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
a[i__ + j * a_dim1]), dabs(r__2))) * ((r__3 = x[
i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[j + k *
x_dim1]), dabs(r__4)));
/* L60: */
}
i__3 = i__ + i__ * a_dim1;
i__4 = i__ + k * x_dim1;
tmp += (r__1 = a[i__3].r, dabs(r__1)) * ((r__2 = x[i__4].r,
dabs(r__2)) + (r__3 = r_imag(&x[i__ + k * x_dim1]),
dabs(r__3)));
i__3 = *n;
for (j = i__ + 1; j <= i__3; ++j) {
i__4 = j + i__ * a_dim1;
i__5 = j + k * x_dim1;
tmp += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
a[j + i__ * a_dim1]), dabs(r__2))) * ((r__3 = x[
i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[j + k *
x_dim1]), dabs(r__4)));
/* L70: */
}
}
if (i__ == 1) {
axbi = tmp;
} else {
axbi = dmin(axbi,tmp);
}
/* L80: */
}
/* Computing MAX */
r__1 = axbi, r__2 = (*n + 1) * unfl;
tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / dmax(r__1,r__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = dmax(reslts[2],tmp);
}
/* L90: */
}
return 0;
/* End of CPOT05 */
} /* cpot05_ */
/* Subroutine */ int clartg_(complex *f, complex *g, real *cs, complex *sn,
complex *r__)
{
/* System generated locals */
integer i__1;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10;
complex q__1, q__2, q__3;
/* Builtin functions */
double log(doublereal), pow_ri(real *, integer *), r_imag(complex *),
sqrt(doublereal);
void r_cnjg(complex *, complex *);
/* Local variables */
real d__;
integer i__;
real f2, g2;
complex ff;
real di, dr;
complex fs, gs;
real f2s, g2s, eps, scale;
integer count;
real safmn2, safmx2;
extern doublereal slapy2_(real *, real *), slamch_(char *);
real safmin;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLARTG generates a plane rotation so that */
/* [ CS SN ] [ F ] [ R ] */
/* [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1. */
/* [ -SN CS ] [ G ] [ 0 ] */
/* This is a faster version of the BLAS1 routine CROTG, except for */
/* the following differences: */
/* F and G are unchanged on return. */
/* If G=0, then CS=1 and SN=0. */
/* If F=0, then CS=0 and SN is chosen so that R is real. */
/* Arguments */
/* ========= */
/* F (input) COMPLEX */
/* The first component of vector to be rotated. */
/* G (input) COMPLEX */
/* The second component of vector to be rotated. */
/* CS (output) REAL */
/* The cosine of the rotation. */
/* SN (output) COMPLEX */
/* The sine of the rotation. */
/* R (output) COMPLEX */
/* The nonzero component of the rotated vector. */
/* Further Details */
/* ======= ======= */
/* 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel */
/* This version has a few statements commented out for thread safety */
/* (machine parameters are computed on each entry). 10 feb 03, SJH. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* LOGICAL FIRST */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Save statement .. */
/* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 */
/* .. */
/* .. Data statements .. */
/* DATA FIRST / .TRUE. / */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* IF( FIRST ) THEN */
safmin = slamch_("S");
eps = slamch_("E");
r__1 = slamch_("B");
i__1 = (integer) (log(safmin / eps) / log(slamch_("B")) / 2.f);
safmn2 = pow_ri(&r__1, &i__1);
safmx2 = 1.f / safmn2;
/* FIRST = .FALSE. */
/* END IF */
/* Computing MAX */
/* Computing MAX */
r__7 = (r__1 = f->r, dabs(r__1)), r__8 = (r__2 = r_imag(f), dabs(r__2));
/* Computing MAX */
r__9 = (r__3 = g->r, dabs(r__3)), r__10 = (r__4 = r_imag(g), dabs(r__4));
r__5 = dmax(r__7,r__8), r__6 = dmax(r__9,r__10);
scale = dmax(r__5,r__6);
fs.r = f->r, fs.i = f->i;
gs.r = g->r, gs.i = g->i;
count = 0;
if (scale >= safmx2) {
L10:
++count;
q__1.r = safmn2 * fs.r, q__1.i = safmn2 * fs.i;
fs.r = q__1.r, fs.i = q__1.i;
q__1.r = safmn2 * gs.r, q__1.i = safmn2 * gs.i;
gs.r = q__1.r, gs.i = q__1.i;
scale *= safmn2;
if (scale >= safmx2) {
goto L10;
}
} else if (scale <= safmn2) {
if (g->r == 0.f && g->i == 0.f) {
*cs = 1.f;
sn->r = 0.f, sn->i = 0.f;
r__->r = f->r, r__->i = f->i;
return 0;
}
L20:
--count;
q__1.r = safmx2 * fs.r, q__1.i = safmx2 * fs.i;
fs.r = q__1.r, fs.i = q__1.i;
q__1.r = safmx2 * gs.r, q__1.i = safmx2 * gs.i;
gs.r = q__1.r, gs.i = q__1.i;
scale *= safmx2;
if (scale <= safmn2) {
goto L20;
}
}
/* Computing 2nd power */
r__1 = fs.r;
/* Computing 2nd power */
r__2 = r_imag(&fs);
f2 = r__1 * r__1 + r__2 * r__2;
/* Computing 2nd power */
r__1 = gs.r;
/* Computing 2nd power */
r__2 = r_imag(&gs);
g2 = r__1 * r__1 + r__2 * r__2;
if (f2 <= dmax(g2,1.f) * safmin) {
/* This is a rare case: F is very small. */
if (f->r == 0.f && f->i == 0.f) {
*cs = 0.f;
r__2 = g->r;
r__3 = r_imag(g);
r__1 = slapy2_(&r__2, &r__3);
r__->r = r__1, r__->i = 0.f;
/* Do complex/real division explicitly with two real divisions */
r__1 = gs.r;
r__2 = r_imag(&gs);
d__ = slapy2_(&r__1, &r__2);
r__1 = gs.r / d__;
r__2 = -r_imag(&gs) / d__;
q__1.r = r__1, q__1.i = r__2;
sn->r = q__1.r, sn->i = q__1.i;
return 0;
}
r__1 = fs.r;
r__2 = r_imag(&fs);
f2s = slapy2_(&r__1, &r__2);
/* G2 and G2S are accurate */
/* G2 is at least SAFMIN, and G2S is at least SAFMN2 */
g2s = sqrt(g2);
/* Error in CS from underflow in F2S is at most */
/* UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS */
/* If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN, */
/* and so CS .lt. sqrt(SAFMIN) */
/* If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN */
/* and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS) */
/* Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S */
*cs = f2s / g2s;
/* Make sure abs(FF) = 1 */
/* Do complex/real division explicitly with 2 real divisions */
/* Computing MAX */
r__3 = (r__1 = f->r, dabs(r__1)), r__4 = (r__2 = r_imag(f), dabs(r__2)
);
if (dmax(r__3,r__4) > 1.f) {
r__1 = f->r;
r__2 = r_imag(f);
d__ = slapy2_(&r__1, &r__2);
r__1 = f->r / d__;
r__2 = r_imag(f) / d__;
q__1.r = r__1, q__1.i = r__2;
ff.r = q__1.r, ff.i = q__1.i;
} else {
dr = safmx2 * f->r;
di = safmx2 * r_imag(f);
d__ = slapy2_(&dr, &di);
r__1 = dr / d__;
r__2 = di / d__;
q__1.r = r__1, q__1.i = r__2;
ff.r = q__1.r, ff.i = q__1.i;
}
r__1 = gs.r / g2s;
r__2 = -r_imag(&gs) / g2s;
q__2.r = r__1, q__2.i = r__2;
q__1.r = ff.r * q__2.r - ff.i * q__2.i, q__1.i = ff.r * q__2.i + ff.i
* q__2.r;
sn->r = q__1.r, sn->i = q__1.i;
q__2.r = *cs * f->r, q__2.i = *cs * f->i;
q__3.r = sn->r * g->r - sn->i * g->i, q__3.i = sn->r * g->i + sn->i *
g->r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
r__->r = q__1.r, r__->i = q__1.i;
} else {
/* This is the most common case. */
/* Neither F2 nor F2/G2 are less than SAFMIN */
/* F2S cannot overflow, and it is accurate */
f2s = sqrt(g2 / f2 + 1.f);
/* Do the F2S(real)*FS(complex) multiply with two real multiplies */
r__1 = f2s * fs.r;
r__2 = f2s * r_imag(&fs);
q__1.r = r__1, q__1.i = r__2;
r__->r = q__1.r, r__->i = q__1.i;
*cs = 1.f / f2s;
d__ = f2 + g2;
/* Do complex/real division explicitly with two real divisions */
r__1 = r__->r / d__;
r__2 = r_imag(r__) / d__;
q__1.r = r__1, q__1.i = r__2;
sn->r = q__1.r, sn->i = q__1.i;
r_cnjg(&q__2, &gs);
q__1.r = sn->r * q__2.r - sn->i * q__2.i, q__1.i = sn->r * q__2.i +
sn->i * q__2.r;
sn->r = q__1.r, sn->i = q__1.i;
if (count != 0) {
if (count > 0) {
i__1 = count;
for (i__ = 1; i__ <= i__1; ++i__) {
q__1.r = safmx2 * r__->r, q__1.i = safmx2 * r__->i;
r__->r = q__1.r, r__->i = q__1.i;
/* L30: */
}
} else {
i__1 = -count;
for (i__ = 1; i__ <= i__1; ++i__) {
q__1.r = safmn2 * r__->r, q__1.i = safmn2 * r__->i;
r__->r = q__1.r, r__->i = q__1.i;
/* L40: */
}
}
}
}
return 0;
/* End of CLARTG */
} /* clartg_ */
/* Subroutine */ int sgebal_(char *job, integer *n, real *a, integer *lda,
integer *ilo, integer *ihi, real *scale, integer *info, ftnlen
job_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real r__1, r__2;
/* Local variables */
static real c__, f, g;
static integer i__, j, k, l, m;
static real r__, s, ca, ra;
static integer ica, ira, iexc;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
sswap_(integer *, real *, integer *, real *, integer *);
static real sfmin1, sfmin2, sfmax1, sfmax2;
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern integer isamax_(integer *, real *, integer *);
static logical noconv;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGEBAL balances a general real matrix A. This involves, first, */
/* permuting A by a similarity transformation to isolate eigenvalues */
/* in the first 1 to ILO-1 and last IHI+1 to N elements on the */
/* diagonal; and second, applying a diagonal similarity transformation */
/* to rows and columns ILO to IHI to make the rows and columns as */
/* close in norm as possible. Both steps are optional. */
/* Balancing may reduce the 1-norm of the matrix, and improve the */
/* accuracy of the computed eigenvalues and/or eigenvectors. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies the operations to be performed on A: */
/* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 */
/* for i = 1,...,N; */
/* = 'P': permute only; */
/* = 'S': scale only; */
/* = 'B': both permute and scale. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the input matrix A. */
/* On exit, A is overwritten by the balanced matrix. */
/* If JOB = 'N', A is not referenced. */
/* See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are set to integers such that on exit */
/* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. */
/* If JOB = 'N' or 'S', ILO = 1 and IHI = N. */
/* SCALE (output) REAL array, dimension (N) */
/* Details of the permutations and scaling factors applied to */
/* A. If P(j) is the index of the row and column interchanged */
/* with row and column j and D(j) is the scaling factor */
/* applied to row and column j, then */
/* SCALE(j) = P(j) for j = 1,...,ILO-1 */
/* = D(j) for j = ILO,...,IHI */
/* = P(j) for j = IHI+1,...,N. */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The permutations consist of row and column interchanges which put */
/* the matrix in the form */
/* ( T1 X Y ) */
/* P A P = ( 0 B Z ) */
/* ( 0 0 T2 ) */
/* where T1 and T2 are upper triangular matrices whose eigenvalues lie */
/* along the diagonal. The column indices ILO and IHI mark the starting */
/* and ending columns of the submatrix B. Balancing consists of applying */
/* a diagonal similarity transformation inv(D) * B * D to make the */
/* 1-norms of each row of B and its corresponding column nearly equal. */
/* The output matrix is */
/* ( T1 X*D Y ) */
/* ( 0 inv(D)*B*D inv(D)*Z ). */
/* ( 0 0 T2 ) */
/* Information about the permutations P and the diagonal matrix D is */
/* returned in the vector SCALE. */
/* This subroutine is based on the EISPACK routine BALANC. */
/* Modified by Tzu-Yi Chen, Computer Science Division, University of */
/* California at Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--scale;
/* Function Body */
*info = 0;
if (! lsame_(job, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(job, "P", (
ftnlen)1, (ftnlen)1) && ! lsame_(job, "S", (ftnlen)1, (ftnlen)1)
&& ! lsame_(job, "B", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGEBAL", &i__1, (ftnlen)6);
return 0;
}
k = 1;
l = *n;
if (*n == 0) {
goto L210;
}
if (lsame_(job, "N", (ftnlen)1, (ftnlen)1)) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scale[i__] = 1.f;
/* L10: */
}
goto L210;
}
if (lsame_(job, "S", (ftnlen)1, (ftnlen)1)) {
goto L120;
}
/* Permutation to isolate eigenvalues if possible */
goto L50;
/* Row and column exchange. */
L20:
scale[m] = (real) j;
if (j == m) {
goto L30;
}
sswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
i__1 = *n - k + 1;
sswap_(&i__1, &a[j + k * a_dim1], lda, &a[m + k * a_dim1], lda);
L30:
switch (iexc) {
case 1: goto L40;
case 2: goto L80;
}
/* Search for rows isolating an eigenvalue and push them down. */
L40:
if (l == 1) {
goto L210;
}
--l;
L50:
for (j = l; j >= 1; --j) {
i__1 = l;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ == j) {
goto L60;
}
if (a[j + i__ * a_dim1] != 0.f) {
goto L70;
}
L60:
;
}
m = l;
iexc = 1;
goto L20;
L70:
;
}
goto L90;
/* Search for columns isolating an eigenvalue and push them left. */
L80:
++k;
L90:
i__1 = l;
for (j = k; j <= i__1; ++j) {
i__2 = l;
for (i__ = k; i__ <= i__2; ++i__) {
if (i__ == j) {
goto L100;
}
if (a[i__ + j * a_dim1] != 0.f) {
goto L110;
}
L100:
;
}
m = k;
iexc = 2;
goto L20;
L110:
;
}
L120:
i__1 = l;
for (i__ = k; i__ <= i__1; ++i__) {
scale[i__] = 1.f;
/* L130: */
}
if (lsame_(job, "P", (ftnlen)1, (ftnlen)1)) {
goto L210;
}
/* Balance the submatrix in rows K to L. */
/* Iterative loop for norm reduction */
sfmin1 = slamch_("S", (ftnlen)1) / slamch_("P", (ftnlen)1);
sfmax1 = 1.f / sfmin1;
sfmin2 = sfmin1 * 8.f;
sfmax2 = 1.f / sfmin2;
L140:
noconv = FALSE_;
i__1 = l;
for (i__ = k; i__ <= i__1; ++i__) {
c__ = 0.f;
r__ = 0.f;
i__2 = l;
for (j = k; j <= i__2; ++j) {
if (j == i__) {
goto L150;
}
c__ += (r__1 = a[j + i__ * a_dim1], dabs(r__1));
r__ += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
L150:
;
}
ica = isamax_(&l, &a[i__ * a_dim1 + 1], &c__1);
ca = (r__1 = a[ica + i__ * a_dim1], dabs(r__1));
i__2 = *n - k + 1;
ira = isamax_(&i__2, &a[i__ + k * a_dim1], lda);
ra = (r__1 = a[i__ + (ira + k - 1) * a_dim1], dabs(r__1));
/* Guard against zero C or R due to underflow. */
if (c__ == 0.f || r__ == 0.f) {
goto L200;
}
g = r__ / 8.f;
f = 1.f;
s = c__ + r__;
L160:
/* Computing MAX */
r__1 = max(f,c__);
/* Computing MIN */
r__2 = min(r__,g);
if (c__ >= g || dmax(r__1,ca) >= sfmax2 || dmin(r__2,ra) <= sfmin2) {
goto L170;
}
f *= 8.f;
c__ *= 8.f;
ca *= 8.f;
r__ /= 8.f;
g /= 8.f;
ra /= 8.f;
goto L160;
L170:
g = c__ / 8.f;
L180:
/* Computing MIN */
r__1 = min(f,c__), r__1 = min(r__1,g);
if (g < r__ || dmax(r__,ra) >= sfmax2 || dmin(r__1,ca) <= sfmin2) {
goto L190;
}
f /= 8.f;
c__ /= 8.f;
g /= 8.f;
ca /= 8.f;
r__ *= 8.f;
ra *= 8.f;
goto L180;
/* Now balance. */
L190:
if (c__ + r__ >= s * .95f) {
goto L200;
}
if (f < 1.f && scale[i__] < 1.f) {
if (f * scale[i__] <= sfmin1) {
goto L200;
}
}
if (f > 1.f && scale[i__] > 1.f) {
if (scale[i__] >= sfmax1 / f) {
goto L200;
}
}
g = 1.f / f;
scale[i__] *= f;
noconv = TRUE_;
i__2 = *n - k + 1;
sscal_(&i__2, &g, &a[i__ + k * a_dim1], lda);
sscal_(&l, &f, &a[i__ * a_dim1 + 1], &c__1);
L200:
;
}
if (noconv) {
goto L140;
}
L210:
*ilo = k;
*ihi = l;
return 0;
/* End of SGEBAL */
} /* sgebal_ */
/* Subroutine */ int cptt02_(char *uplo, integer *n, integer *nrhs, real *d__,
complex *e, complex *x, integer *ldx, complex *b, integer *ldb, real
*resid)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1;
real r__1, r__2;
/* Local variables */
integer j;
real eps, anorm, bnorm, xnorm;
extern doublereal slamch_(char *), clanht_(char *, integer *,
real *, complex *);
extern /* Subroutine */ int claptm_(char *, integer *, integer *, real *,
real *, complex *, complex *, integer *, real *, complex *,
integer *);
extern doublereal scasum_(integer *, complex *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPTT02 computes the residual for the solution to a symmetric */
/* tridiagonal system of equations: */
/* RESID = norm(B - A*X) / (norm(A) * norm(X) * EPS), */
/* where EPS is the machine epsilon. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the superdiagonal or the subdiagonal of the */
/* tridiagonal matrix A is stored. */
/* = 'U': E is the superdiagonal of A */
/* = 'L': E is the subdiagonal of A */
/* N (input) INTEGTER */
/* The order of the matrix A. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* D (input) REAL array, dimension (N) */
/* The n diagonal elements of the tridiagonal matrix A. */
/* E (input) COMPLEX array, dimension (N-1) */
/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
/* X (input) COMPLEX array, dimension (LDX,NRHS) */
/* The n by nrhs matrix of solution vectors X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
/* On entry, the n by nrhs matrix of right hand side vectors B. */
/* On exit, B is overwritten with the difference B - A*X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* RESID (output) REAL */
/* norm(B - A*X) / (norm(A) * norm(X) * EPS) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
--d__;
--e;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
if (*n <= 0) {
*resid = 0.f;
return 0;
}
/* Compute the 1-norm of the tridiagonal matrix A. */
anorm = clanht_("1", n, &d__[1], &e[1]);
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Compute B - A*X. */
claptm_(uplo, n, nrhs, &c_b4, &d__[1], &e[1], &x[x_offset], ldx, &c_b5, &
b[b_offset], ldb);
/* Compute the maximum over the number of right hand sides of */
/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
*resid = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
bnorm = scasum_(n, &b[j * b_dim1 + 1], &c__1);
xnorm = scasum_(n, &x[j * x_dim1 + 1], &c__1);
if (xnorm <= 0.f) {
*resid = 1.f / eps;
} else {
/* Computing MAX */
r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
*resid = dmax(r__1,r__2);
}
/* L10: */
}
return 0;
/* End of CPTT02 */
} /* cptt02_ */
/* Subroutine */ int cppsvx_(char *fact, char *uplo, integer *n, integer *
nrhs, complex *ap, complex *afp, char *equed, real *s, complex *b,
integer *ldb, complex *x, integer *ldx, real *rcond, real *ferr, real
*berr, complex *work, real *rwork, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2;
complex q__1;
/* Local variables */
integer i__, j;
real amax, smin, smax;
real scond, anorm;
logical equil, rcequ;
logical nofact;
real bignum;
integer infequ;
real smlnum;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CPPSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to */
/* compute the solution to a complex system of linear equations */
/* A * X = B, */
/* where A is an N-by-N Hermitian positive definite matrix stored in */
/* packed format and X and B are N-by-NRHS matrices. */
/* Error bounds on the solution and a condition estimate are also */
/* provided. */
/* Description */
/* =========== */
/* The following steps are performed: */
/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
/* the system: */
/* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */
/* Whether or not the system will be equilibrated depends on the */
/* scaling of the matrix A, but if equilibration is used, A is */
/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */
/* factor the matrix A (after equilibration if FACT = 'E') as */
/* A = U'* U , if UPLO = 'U', or */
/* A = L * L', if UPLO = 'L', */
/* where U is an upper triangular matrix, L is a lower triangular */
/* matrix, and ' indicates conjugate transpose. */
/* 3. If the leading i-by-i principal minor is not positive definite, */
/* then the routine returns with INFO = i. Otherwise, the factored */
/* form of A is used to estimate the condition number of the matrix */
/* A. If the reciprocal of the condition number is less than machine */
/* precision, INFO = N+1 is returned as a warning, but the routine */
/* still goes on to solve for X and compute error bounds as */
/* described below. */
/* 4. The system of equations is solved for X using the factored form */
/* of A. */
/* 5. Iterative refinement is applied to improve the computed solution */
/* matrix and calculate error bounds and backward error estimates */
/* for it. */
/* 6. If equilibration was used, the matrix X is premultiplied by */
/* diag(S) so that it solves the original system before */
/* equilibration. */
/* Arguments */
/* ========= */
/* FACT (input) CHARACTER*1 */
/* Specifies whether or not the factored form of the matrix A is */
/* supplied on entry, and if not, whether the matrix A should be */
/* equilibrated before it is factored. */
/* = 'F': On entry, AFP contains the factored form of A. */
/* If EQUED = 'Y', the matrix A has been equilibrated */
/* with scaling factors given by S. AP and AFP will not */
/* be modified. */
/* = 'N': The matrix A will be copied to AFP and factored. */
/* = 'E': The matrix A will be equilibrated if necessary, then */
/* copied to AFP and factored. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the Hermitian matrix */
/* A, packed columnwise in a linear array, except if FACT = 'F' */
/* and EQUED = 'Y', then A must contain the equilibrated matrix */
/* diag(S)*A*diag(S). The j-th column of A is stored in the */
/* array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* See below for further details. A is not modified if */
/* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
/* diag(S)*A*diag(S). */
/* AFP (input or output) COMPLEX array, dimension (N*(N+1)/2) */
/* If FACT = 'F', then AFP is an input argument and on entry */
/* contains the triangular factor U or L from the Cholesky */
/* factorization A = U**H*U or A = L*L**H, in the same storage */
/* format as A. If EQUED .ne. 'N', then AFP is the factored */
/* form of the equilibrated matrix A. */
/* If FACT = 'N', then AFP is an output argument and on exit */
/* returns the triangular factor U or L from the Cholesky */
/* factorization A = U**H*U or A = L*L**H of the original */
/* matrix A. */
/* If FACT = 'E', then AFP is an output argument and on exit */
/* returns the triangular factor U or L from the Cholesky */
/* factorization A = U**H*U or A = L*L**H of the equilibrated */
/* matrix A (see the description of AP for the form of the */
/* equilibrated matrix). */
/* EQUED (input or output) CHARACTER*1 */
/* Specifies the form of equilibration that was done. */
/* = 'N': No equilibration (always true if FACT = 'N'). */
/* = 'Y': Equilibration was done, i.e., A has been replaced by */
/* diag(S) * A * diag(S). */
/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
/* output argument. */
/* S (input or output) REAL array, dimension (N) */
/* The scale factors for A; not accessed if EQUED = 'N'. S is */
/* an input argument if FACT = 'F'; otherwise, S is an output */
/* argument. If FACT = 'F' and EQUED = 'Y', each element of S */
/* must be positive. */
/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
/* On entry, the N-by-NRHS right hand side matrix B. */
/* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */
/* B is overwritten by diag(S) * B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (output) COMPLEX array, dimension (LDX,NRHS) */
/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */
/* the original system of equations. Note that if EQUED = 'Y', */
/* A and B are modified on exit, and the solution to the */
/* equilibrated system is inv(diag(S))*X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* RCOND (output) REAL */
/* The estimate of the reciprocal condition number of the matrix */
/* A after equilibration (if done). If RCOND is less than the */
/* machine precision (in particular, if RCOND = 0), the matrix */
/* is singular to working precision. This condition is */
/* indicated by a return code of INFO > 0. */
/* FERR (output) REAL array, dimension (NRHS) */
/* The estimated forward error bound for each solution vector */
/* X(j) (the j-th column of the solution matrix X). */
/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
/* is an estimated upper bound for the magnitude of the largest */
/* element in (X(j) - XTRUE) divided by the magnitude of the */
/* largest element in X(j). The estimate is as reliable as */
/* the estimate for RCOND, and is almost always a slight */
/* overestimate of the true error. */
/* BERR (output) REAL array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector X(j) (i.e., the smallest relative change in */
/* any element of A or B that makes X(j) an exact solution). */
/* WORK (workspace) COMPLEX array, dimension (2*N) */
/* RWORK (workspace) REAL array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, and i is */
/* <= N: the leading minor of order i of A is */
/* not positive definite, so the factorization */
/* could not be completed, and the solution has not */
/* been computed. RCOND = 0 is returned. */
/* = N+1: U is nonsingular, but RCOND is less than machine */
/* precision, meaning that the matrix is singular */
/* to working precision. Nevertheless, the */
/* solution and error bounds are computed because */
/* there are a number of situations where the */
/* computed solution can be more accurate than the */
/* value of RCOND would suggest. */
/* Further Details */
/* =============== */
/* The packed storage scheme is illustrated by the following example */
/* when N = 4, UPLO = 'U': */
/* Two-dimensional storage of the Hermitian matrix A: */
/* a11 a12 a13 a14 */
/* a22 a23 a24 */
/* a33 a34 (aij = conjg(aji)) */
/* a44 */
/* Packed storage of the upper triangle of A: */
/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
/* ===================================================================== */
/* Parameter adjustments */
--ap;
--afp;
--s;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (nofact || equil) {
*(unsigned char *)equed = 'N';
rcequ = FALSE_;
} else {
rcequ = lsame_(equed, "Y");
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
}
/* Test the input parameters. */
if (! nofact && ! equil && ! lsame_(fact, "F")) {
*info = -1;
} else if (! lsame_(uplo, "U") && ! lsame_(uplo,
"L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (lsame_(fact, "F") && ! (rcequ || lsame_(
equed, "N"))) {
*info = -7;
} else {
if (rcequ) {
smin = bignum;
smax = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
r__1 = smin, r__2 = s[j];
smin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = smax, r__2 = s[j];
smax = dmax(r__1,r__2);
}
if (smin <= 0.f) {
*info = -8;
} else if (*n > 0) {
scond = dmax(smin,smlnum) / dmin(smax,bignum);
} else {
scond = 1.f;
}
}
if (*info == 0) {
if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldx < max(1,*n)) {
*info = -12;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPPSVX", &i__1);
return 0;
}
if (equil) {
/* Compute row and column scalings to equilibrate the matrix A. */
cppequ_(uplo, n, &ap[1], &s[1], &scond, &amax, &infequ);
if (infequ == 0) {
/* Equilibrate the matrix. */
claqhp_(uplo, n, &ap[1], &s[1], &scond, &amax, equed);
rcequ = lsame_(equed, "Y");
}
}
/* Scale the right-hand side. */
if (rcequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
i__4 = i__;
i__5 = i__ + j * b_dim1;
q__1.r = s[i__4] * b[i__5].r, q__1.i = s[i__4] * b[i__5].i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
}
}
}
if (nofact || equil) {
/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
i__1 = *n * (*n + 1) / 2;
ccopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1);
cpptrf_(uplo, n, &afp[1], info);
/* Return if INFO is non-zero. */
if (*info > 0) {
*rcond = 0.f;
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = clanhp_("I", uplo, n, &ap[1], &rwork[1]);
/* Compute the reciprocal of the condition number of A. */
cppcon_(uplo, n, &afp[1], &anorm, rcond, &work[1], &rwork[1], info);
/* Compute the solution matrix X. */
clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
cpptrs_(uplo, n, nrhs, &afp[1], &x[x_offset], ldx, info);
/* Use iterative refinement to improve the computed solution and */
/* compute error bounds and backward error estimates for it. */
cpprfs_(uplo, n, nrhs, &ap[1], &afp[1], &b[b_offset], ldb, &x[x_offset],
ldx, &ferr[1], &berr[1], &work[1], &rwork[1], info);
/* Transform the solution matrix X to a solution of the original */
/* system. */
if (rcequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * x_dim1;
i__4 = i__;
i__5 = i__ + j * x_dim1;
q__1.r = s[i__4] * x[i__5].r, q__1.i = s[i__4] * x[i__5].i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
}
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] /= scond;
}
}
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < slamch_("Epsilon")) {
*info = *n + 1;
}
return 0;
/* End of CPPSVX */
} /* cppsvx_ */