/* 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 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 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 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 cgbcon_(char *norm, integer *n, integer *kl, integer *ku, complex *ab, integer *ldab, integer *ipiv, real *anorm, real *rcond, complex *work, real *rwork, integer *info) { /* System generated locals */ integer ab_dim1, ab_offset, i__1, i__2, i__3; real r__1, r__2; complex q__1, q__2; /* Builtin functions */ double r_imag(complex *); /* Local variables */ integer j; complex t; integer kd, lm, jp, ix, kase, kase1; real scale; extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer *, complex *, integer *); extern logical lsame_(char *, char *); integer isave[3]; extern /* Subroutine */ int caxpy_(integer *, complex *, complex *, integer *, complex *, integer *); logical lnoti; extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real *, integer *, integer *); extern integer icamax_(integer *, complex *, integer *); extern doublereal slamch_(char *); extern /* Subroutine */ int clatbs_(char *, char *, char *, char *, integer *, integer *, complex *, integer *, complex *, real *, real *, integer *), xerbla_(char * , integer *); real ainvnm; extern /* Subroutine */ int csrscl_(integer *, real *, complex *, integer *); logical onenrm; char normin[1]; real smlnum; /* -- LAPACK routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CGBCON estimates the reciprocal of the condition number of a complex */ /* general band matrix A, in either the 1-norm or the infinity-norm, */ /* using the LU factorization computed by CGBTRF. */ /* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ /* condition number is computed as */ /* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies whether the 1-norm condition number or the */ /* infinity-norm condition number is required: */ /* = '1' or 'O': 1-norm; */ /* = 'I': Infinity-norm. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* KL (input) INTEGER */ /* The number of subdiagonals within the band of A. KL >= 0. */ /* KU (input) INTEGER */ /* The number of superdiagonals within the band of A. KU >= 0. */ /* AB (input) COMPLEX array, dimension (LDAB,N) */ /* Details of the LU factorization of the band matrix A, as */ /* computed by CGBTRF. U is stored as an upper triangular band */ /* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */ /* the multipliers used during the factorization are stored in */ /* rows KL+KU+2 to 2*KL+KU+1. */ /* LDAB (input) INTEGER */ /* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */ /* IPIV (input) INTEGER array, dimension (N) */ /* The pivot indices; for 1 <= i <= N, row i of the matrix was */ /* interchanged with row IPIV(i). */ /* ANORM (input) REAL */ /* If NORM = '1' or 'O', the 1-norm of the original matrix A. */ /* If NORM = 'I', the infinity-norm of the original matrix A. */ /* RCOND (output) REAL */ /* The reciprocal of the condition number of the matrix A, */ /* computed as RCOND = 1/(norm(A) * norm(inv(A))). */ /* 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 */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Statement Functions .. */ /* .. */ /* .. Statement Function definitions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1; ab -= ab_offset; --ipiv; --work; --rwork; /* Function Body */ *info = 0; onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); if (! onenrm && ! lsame_(norm, "I")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*kl < 0) { *info = -3; } else if (*ku < 0) { *info = -4; } else if (*ldab < (*kl << 1) + *ku + 1) { *info = -6; } else if (*anorm < 0.f) { *info = -8; } if (*info != 0) { i__1 = -(*info); xerbla_("CGBCON", &i__1); return 0; } /* Quick return if possible */ *rcond = 0.f; if (*n == 0) { *rcond = 1.f; return 0; } else if (*anorm == 0.f) { return 0; } smlnum = slamch_("Safe minimum"); /* Estimate the norm of inv(A). */ ainvnm = 0.f; *(unsigned char *)normin = 'N'; if (onenrm) { kase1 = 1; } else { kase1 = 2; } kd = *kl + *ku + 1; lnoti = *kl > 0; kase = 0; L10: clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); if (kase != 0) { if (kase == kase1) { /* Multiply by inv(L). */ if (lnoti) { i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__2 = *kl, i__3 = *n - j; lm = min(i__2,i__3); jp = ipiv[j]; i__2 = jp; t.r = work[i__2].r, t.i = work[i__2].i; if (jp != j) { i__2 = jp; i__3 = j; work[i__2].r = work[i__3].r, work[i__2].i = work[i__3] .i; i__2 = j; work[i__2].r = t.r, work[i__2].i = t.i; } q__1.r = -t.r, q__1.i = -t.i; caxpy_(&lm, &q__1, &ab[kd + 1 + j * ab_dim1], &c__1, & work[j + 1], &c__1); /* L20: */ } } /* Multiply by inv(U). */ i__1 = *kl + *ku; clatbs_("Upper", "No transpose", "Non-unit", normin, n, &i__1, & ab[ab_offset], ldab, &work[1], &scale, &rwork[1], info); } else { /* Multiply by inv(U'). */ i__1 = *kl + *ku; clatbs_("Upper", "Conjugate transpose", "Non-unit", normin, n, & i__1, &ab[ab_offset], ldab, &work[1], &scale, &rwork[1], info); /* Multiply by inv(L'). */ if (lnoti) { for (j = *n - 1; j >= 1; --j) { /* Computing MIN */ i__1 = *kl, i__2 = *n - j; lm = min(i__1,i__2); i__1 = j; i__2 = j; cdotc_(&q__2, &lm, &ab[kd + 1 + j * ab_dim1], &c__1, & work[j + 1], &c__1); q__1.r = work[i__2].r - q__2.r, q__1.i = work[i__2].i - q__2.i; work[i__1].r = q__1.r, work[i__1].i = q__1.i; jp = ipiv[j]; if (jp != j) { i__1 = jp; t.r = work[i__1].r, t.i = work[i__1].i; i__1 = jp; i__2 = j; work[i__1].r = work[i__2].r, work[i__1].i = work[i__2] .i; i__1 = j; work[i__1].r = t.r, work[i__1].i = t.i; } /* L30: */ } } } /* Divide X by 1/SCALE if doing so will not cause overflow. */ *(unsigned char *)normin = 'Y'; if (scale != 1.f) { ix = icamax_(n, &work[1], &c__1); i__1 = ix; if (scale < ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(& work[ix]), dabs(r__2))) * smlnum || scale == 0.f) { goto L40; } csrscl_(n, &scale, &work[1], &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.f) { *rcond = 1.f / ainvnm / *anorm; } L40: return 0; /* End of CGBCON */ } /* cgbcon_ */
/* 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 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_ */
real sasum_(integer *n, real *sx, integer *incx) { /* System generated locals */ integer i__1, i__2; real ret_val, r__1, r__2, r__3, r__4, r__5, r__6; /* Local variables */ integer i, m, nincx; real stemp; integer mp1; /* takes the sum of the absolute values. uses unrolled loops for increment equal to one. jack dongarra, linpack, 3/11/78. modified 3/93 to return if incx .le. 0. modified 12/3/93, array(1) declarations changed to array(*) Parameter adjustments Function Body */ #define SX(I) sx[(I)-1] ret_val = 0.f; stemp = 0.f; if (*n <= 0 || *incx <= 0) { return ret_val; } if (*incx == 1) { goto L20; } /* code for increment not equal to 1 */ nincx = *n * *incx; i__1 = nincx; i__2 = *incx; for (i = 1; *incx < 0 ? i >= nincx : i <= nincx; i += *incx) { stemp += (r__1 = SX(i), dabs(r__1)); /* L10: */ } ret_val = stemp; return ret_val; /* code for increment equal to 1 clean-up loop */ L20: m = *n % 6; if (m == 0) { goto L40; } i__2 = m; for (i = 1; i <= m; ++i) { stemp += (r__1 = SX(i), dabs(r__1)); /* L30: */ } if (*n < 6) { goto L60; } L40: mp1 = m + 1; i__2 = *n; for (i = mp1; i <= *n; i += 6) { stemp = stemp + (r__1 = SX(i), dabs(r__1)) + (r__2 = SX(i + 1), dabs( r__2)) + (r__3 = SX(i + 2), dabs(r__3)) + (r__4 = SX(i + 3), dabs(r__4)) + (r__5 = SX(i + 4), dabs(r__5)) + (r__6 = SX(i + 5), dabs(r__6)); /* L50: */ } L60: ret_val = stemp; return ret_val; } /* sasum_ */
/* 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_ */
/* DECK CHIDI */ /* Subroutine */ int chidi_(complex *a, integer *lda, integer *n, integer * kpvt, real *det, integer *inert, complex *work, integer *job) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; real r__1; complex q__1, q__2, q__3; /* Local variables */ static real d__; static integer j, k; static real t, ak; static integer jb, ks, km1; static real ten, akp1; static complex temp, akkp1; extern /* Complex */ void cdotc_(complex *, integer *, complex *, integer *, complex *, integer *); static logical nodet; extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *), cswap_(integer *, complex *, integer *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *); static integer kstep; static logical noert, noinv; /* ***BEGIN PROLOGUE CHIDI */ /* ***PURPOSE Compute the determinant, inertia and inverse of a complex */ /* Hermitian matrix using the factors obtained from CHIFA. */ /* ***LIBRARY SLATEC (LINPACK) */ /* ***CATEGORY D2D1A, D3D1A */ /* ***TYPE COMPLEX (SSIDI-S, DSISI-D, CHIDI-C, CSIDI-C) */ /* ***KEYWORDS DETERMINANT, HERMITIAN, INVERSE, LINEAR ALGEBRA, LINPACK, */ /* MATRIX */ /* ***AUTHOR Bunch, J., (UCSD) */ /* ***DESCRIPTION */ /* CHIDI computes the determinant, inertia and inverse */ /* of a complex Hermitian matrix using the factors from CHIFA. */ /* On Entry */ /* A COMPLEX(LDA,N) */ /* the output from CHIFA. */ /* LDA INTEGER */ /* the leading dimension of the array A. */ /* N INTEGER */ /* the order of the matrix A. */ /* KVPT INTEGER(N) */ /* the pivot vector from CHIFA. */ /* WORK COMPLEX(N) */ /* work vector. Contents destroyed. */ /* JOB INTEGER */ /* JOB has the decimal expansion ABC where */ /* if C .NE. 0, the inverse is computed, */ /* if B .NE. 0, the determinant is computed, */ /* if A .NE. 0, the inertia is computed. */ /* For example, JOB = 111 gives all three. */ /* On Return */ /* Variables not requested by JOB are not used. */ /* A contains the upper triangle of the inverse of */ /* the original matrix. The strict lower triangle */ /* is never referenced. */ /* DET REAL(2) */ /* determinant of original matrix. */ /* Determinant = DET(1) * 10.0**DET(2) */ /* with 1.0 .LE. ABS(DET(1)) .LT. 10.0 */ /* or DET(1) = 0.0. */ /* INERT INTEGER(3) */ /* the inertia of the original matrix. */ /* INERT(1) = number of positive eigenvalues. */ /* INERT(2) = number of negative eigenvalues. */ /* INERT(3) = number of zero eigenvalues. */ /* Error Condition */ /* A division by zero may occur if the inverse is requested */ /* and CHICO has set RCOND .EQ. 0.0 */ /* or CHIFA has set INFO .NE. 0 . */ /* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */ /* Stewart, LINPACK Users' Guide, SIAM, 1979. */ /* ***ROUTINES CALLED CAXPY, CCOPY, CDOTC, CSWAP */ /* ***REVISION HISTORY (YYMMDD) */ /* 780814 DATE WRITTEN */ /* 890531 Changed all specific intrinsics to generic. (WRB) */ /* 890831 Modified array declarations. (WRB) */ /* 891107 Modified routine equivalence list. (WRB) */ /* 891107 REVISION DATE from Version 3.2 */ /* 891214 Prologue converted to Version 4.0 format. (BAB) */ /* 900326 Removed duplicate information from DESCRIPTION section. */ /* (WRB) */ /* 920501 Reformatted the REFERENCES section. (WRB) */ /* ***END PROLOGUE CHIDI */ /* ***FIRST EXECUTABLE STATEMENT CHIDI */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --kpvt; --det; --inert; --work; /* Function Body */ noinv = *job % 10 == 0; nodet = *job % 100 / 10 == 0; noert = *job % 1000 / 100 == 0; if (nodet && noert) { goto L140; } if (noert) { goto L10; } inert[1] = 0; inert[2] = 0; inert[3] = 0; L10: if (nodet) { goto L20; } det[1] = 1.f; det[2] = 0.f; ten = 10.f; L20: t = 0.f; i__1 = *n; for (k = 1; k <= i__1; ++k) { i__2 = k + k * a_dim1; d__ = a[i__2].r; /* CHECK IF 1 BY 1 */ if (kpvt[k] > 0) { goto L50; } /* 2 BY 2 BLOCK */ /* USE DET (D S) = (D/T * C - T) * T , T = ABS(S) */ /* (S C) */ /* TO AVOID UNDERFLOW/OVERFLOW TROUBLES. */ /* TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. */ if (t != 0.f) { goto L30; } t = c_abs(&a[k + (k + 1) * a_dim1]); i__2 = k + 1 + (k + 1) * a_dim1; d__ = d__ / t * a[i__2].r - t; goto L40; L30: d__ = t; t = 0.f; L40: L50: if (noert) { goto L60; } if (d__ > 0.f) { ++inert[1]; } if (d__ < 0.f) { ++inert[2]; } if (d__ == 0.f) { ++inert[3]; } L60: if (nodet) { goto L120; } det[1] = d__ * det[1]; if (det[1] == 0.f) { goto L110; } L70: if (dabs(det[1]) >= 1.f) { goto L80; } det[1] = ten * det[1]; det[2] += -1.f; goto L70; L80: L90: if (dabs(det[1]) < ten) { goto L100; } det[1] /= ten; det[2] += 1.f; goto L90; L100: L110: L120: /* L130: */ ; } L140: /* COMPUTE INVERSE(A) */ if (noinv) { goto L270; } k = 1; L150: if (k > *n) { goto L260; } km1 = k - 1; if (kpvt[k] < 0) { goto L180; } /* 1 BY 1 */ i__1 = k + k * a_dim1; i__2 = k + k * a_dim1; r__1 = 1.f / a[i__2].r; q__1.r = r__1, q__1.i = 0.f; a[i__1].r = q__1.r, a[i__1].i = q__1.i; if (km1 < 1) { goto L170; } ccopy_(&km1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1); i__1 = km1; for (j = 1; j <= i__1; ++j) { i__2 = j + k * a_dim1; cdotc_(&q__1, &j, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1); a[i__2].r = q__1.r, a[i__2].i = q__1.i; i__2 = j - 1; caxpy_(&i__2, &work[j], &a[j * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); /* L160: */ } i__1 = k + k * a_dim1; i__2 = k + k * a_dim1; cdotc_(&q__3, &km1, &work[1], &c__1, &a[k * a_dim1 + 1], &c__1); r__1 = q__3.r; q__2.r = r__1, q__2.i = 0.f; q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i; a[i__1].r = q__1.r, a[i__1].i = q__1.i; L170: kstep = 1; goto L220; L180: /* 2 BY 2 */ t = c_abs(&a[k + (k + 1) * a_dim1]); i__1 = k + k * a_dim1; ak = a[i__1].r / t; i__1 = k + 1 + (k + 1) * a_dim1; akp1 = a[i__1].r / t; i__1 = k + (k + 1) * a_dim1; q__1.r = a[i__1].r / t, q__1.i = a[i__1].i / t; akkp1.r = q__1.r, akkp1.i = q__1.i; d__ = t * (ak * akp1 - 1.f); i__1 = k + k * a_dim1; r__1 = akp1 / d__; q__1.r = r__1, q__1.i = 0.f; a[i__1].r = q__1.r, a[i__1].i = q__1.i; i__1 = k + 1 + (k + 1) * a_dim1; r__1 = ak / d__; q__1.r = r__1, q__1.i = 0.f; a[i__1].r = q__1.r, a[i__1].i = q__1.i; i__1 = k + (k + 1) * a_dim1; q__2.r = -akkp1.r, q__2.i = -akkp1.i; q__1.r = q__2.r / d__, q__1.i = q__2.i / d__; a[i__1].r = q__1.r, a[i__1].i = q__1.i; if (km1 < 1) { goto L210; } ccopy_(&km1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], &c__1); i__1 = km1; for (j = 1; j <= i__1; ++j) { i__2 = j + (k + 1) * a_dim1; cdotc_(&q__1, &j, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1); a[i__2].r = q__1.r, a[i__2].i = q__1.i; i__2 = j - 1; caxpy_(&i__2, &work[j], &a[j * a_dim1 + 1], &c__1, &a[(k + 1) * a_dim1 + 1], &c__1); /* L190: */ } i__1 = k + 1 + (k + 1) * a_dim1; i__2 = k + 1 + (k + 1) * a_dim1; cdotc_(&q__3, &km1, &work[1], &c__1, &a[(k + 1) * a_dim1 + 1], &c__1); r__1 = q__3.r; q__2.r = r__1, q__2.i = 0.f; q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i; a[i__1].r = q__1.r, a[i__1].i = q__1.i; i__1 = k + (k + 1) * a_dim1; i__2 = k + (k + 1) * a_dim1; cdotc_(&q__2, &km1, &a[k * a_dim1 + 1], &c__1, &a[(k + 1) * a_dim1 + 1], & c__1); q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i; a[i__1].r = q__1.r, a[i__1].i = q__1.i; ccopy_(&km1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1); i__1 = km1; for (j = 1; j <= i__1; ++j) { i__2 = j + k * a_dim1; cdotc_(&q__1, &j, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1); a[i__2].r = q__1.r, a[i__2].i = q__1.i; i__2 = j - 1; caxpy_(&i__2, &work[j], &a[j * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); /* L200: */ } i__1 = k + k * a_dim1; i__2 = k + k * a_dim1; cdotc_(&q__3, &km1, &work[1], &c__1, &a[k * a_dim1 + 1], &c__1); r__1 = q__3.r; q__2.r = r__1, q__2.i = 0.f; q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i; a[i__1].r = q__1.r, a[i__1].i = q__1.i; L210: kstep = 2; L220: /* SWAP */ ks = (i__1 = kpvt[k], abs(i__1)); if (ks == k) { goto L250; } cswap_(&ks, &a[ks * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); i__1 = k; for (jb = ks; jb <= i__1; ++jb) { j = k + ks - jb; r_cnjg(&q__1, &a[j + k * a_dim1]); temp.r = q__1.r, temp.i = q__1.i; i__2 = j + k * a_dim1; r_cnjg(&q__1, &a[ks + j * a_dim1]); a[i__2].r = q__1.r, a[i__2].i = q__1.i; i__2 = ks + j * a_dim1; a[i__2].r = temp.r, a[i__2].i = temp.i; /* L230: */ } if (kstep == 1) { goto L240; } i__1 = ks + (k + 1) * a_dim1; temp.r = a[i__1].r, temp.i = a[i__1].i; i__1 = ks + (k + 1) * a_dim1; i__2 = k + (k + 1) * a_dim1; a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; i__1 = k + (k + 1) * a_dim1; a[i__1].r = temp.r, a[i__1].i = temp.i; L240: L250: k += kstep; goto L150; L260: L270: return 0; } /* chidi_ */
/* Subroutine */ int ssterf_(integer *n, real *d__, real *e, integer *info) { /* -- 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 Purpose ======= SSTERF computes all eigenvalues of a symmetric tridiagonal matrix using the Pal-Walker-Kahan variant of the QL or QR algorithm. Arguments ========= N (input) INTEGER The order of the matrix. N >= 0. D (input/output) REAL array, dimension (N) On entry, the n diagonal elements of the tridiagonal matrix. On exit, if INFO = 0, the eigenvalues in ascending order. E (input/output) REAL array, dimension (N-1) On entry, the (n-1) subdiagonal elements of the tridiagonal matrix. On exit, E has been destroyed. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value > 0: the algorithm failed to find all of the eigenvalues in a total of 30*N iterations; if INFO = i, then i elements of E have not converged to zero. ===================================================================== Test the input parameters. Parameter adjustments */ /* Table of constant values */ static integer c__0 = 0; static integer c__1 = 1; static real c_b32 = 1.f; /* System generated locals */ integer i__1; real r__1, r__2, r__3; /* Builtin functions */ double sqrt(doublereal), r_sign(real *, real *); /* Local variables */ static real oldc; static integer lend, jtot; extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *) ; static real c__; static integer i__, l, m; static real p, gamma, r__, s, alpha, sigma, anorm; static integer l1; static real bb; extern doublereal slapy2_(real *, real *); static integer iscale; static real oldgam; extern doublereal slamch_(char *); static real safmin; extern /* Subroutine */ int xerbla_(char *, integer *); static real safmax; extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, real *, integer *, integer *, real *, integer *, integer *); static integer lendsv; static real ssfmin; static integer nmaxit; static real ssfmax; extern doublereal slanst_(char *, integer *, real *, real *); extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *); static real rt1, rt2, eps, rte; static integer lsv; static real eps2; --e; --d__; /* Function Body */ *info = 0; /* Quick return if possible */ if (*n < 0) { *info = -1; i__1 = -(*info); xerbla_("SSTERF", &i__1); return 0; } if (*n <= 1) { return 0; } /* Determine the unit roundoff for this environment. */ eps = slamch_("E"); /* Computing 2nd power */ r__1 = eps; eps2 = r__1 * r__1; safmin = slamch_("S"); safmax = 1.f / safmin; ssfmax = sqrt(safmax) / 3.f; ssfmin = sqrt(safmin) / eps2; /* Compute the eigenvalues of the tridiagonal matrix. */ nmaxit = *n * 30; sigma = 0.f; jtot = 0; /* Determine where the matrix splits and choose QL or QR iteration for each block, according to whether top or bottom diagonal element is smaller. */ l1 = 1; L10: if (l1 > *n) { goto L170; } if (l1 > 1) { e[l1 - 1] = 0.f; } i__1 = *n - 1; for (m = l1; m <= i__1; ++m) { if ((r__3 = e[m], dabs(r__3)) <= sqrt((r__1 = d__[m], dabs(r__1))) * sqrt((r__2 = d__[m + 1], dabs(r__2))) * eps) { e[m] = 0.f; goto L30; } /* L20: */ } m = *n; L30: l = l1; lsv = l; lend = m; lendsv = lend; l1 = m + 1; if (lend == l) { goto L10; } /* Scale submatrix in rows and columns L to LEND */ i__1 = lend - l + 1; anorm = slanst_("I", &i__1, &d__[l], &e[l]); iscale = 0; if (anorm > ssfmax) { iscale = 1; i__1 = lend - l + 1; slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, info); i__1 = lend - l; slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, info); } else if (anorm < ssfmin) { iscale = 2; i__1 = lend - l + 1; slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, info); i__1 = lend - l; slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, info); } i__1 = lend - 1; for (i__ = l; i__ <= i__1; ++i__) { /* Computing 2nd power */ r__1 = e[i__]; e[i__] = r__1 * r__1; /* L40: */ } /* Choose between QL and QR iteration */ if ((r__1 = d__[lend], dabs(r__1)) < (r__2 = d__[l], dabs(r__2))) { lend = lsv; l = lendsv; } if (lend >= l) { /* QL Iteration Look for small subdiagonal element. */ L50: if (l != lend) { i__1 = lend - 1; for (m = l; m <= i__1; ++m) { if ((r__2 = e[m], dabs(r__2)) <= eps2 * (r__1 = d__[m] * d__[ m + 1], dabs(r__1))) { goto L70; } /* L60: */ } } m = lend; L70: if (m < lend) { e[m] = 0.f; } p = d__[l]; if (m == l) { goto L90; } /* If remaining matrix is 2 by 2, use SLAE2 to compute its eigenvalues. */ if (m == l + 1) { rte = sqrt(e[l]); slae2_(&d__[l], &rte, &d__[l + 1], &rt1, &rt2); d__[l] = rt1; d__[l + 1] = rt2; e[l] = 0.f; l += 2; if (l <= lend) { goto L50; } goto L150; } if (jtot == nmaxit) { goto L150; } ++jtot; /* Form shift. */ rte = sqrt(e[l]); sigma = (d__[l + 1] - p) / (rte * 2.f); r__ = slapy2_(&sigma, &c_b32); sigma = p - rte / (sigma + r_sign(&r__, &sigma)); c__ = 1.f; s = 0.f; gamma = d__[m] - sigma; p = gamma * gamma; /* Inner loop */ i__1 = l; for (i__ = m - 1; i__ >= i__1; --i__) { bb = e[i__]; r__ = p + bb; if (i__ != m - 1) { e[i__ + 1] = s * r__; } oldc = c__; c__ = p / r__; s = bb / r__; oldgam = gamma; alpha = d__[i__]; gamma = c__ * (alpha - sigma) - s * oldgam; d__[i__ + 1] = oldgam + (alpha - gamma); if (c__ != 0.f) { p = gamma * gamma / c__; } else { p = oldc * bb; } /* L80: */ } e[l] = s * p; d__[l] = sigma + gamma; goto L50; /* Eigenvalue found. */ L90: d__[l] = p; ++l; if (l <= lend) { goto L50; } goto L150; } else { /* QR Iteration Look for small superdiagonal element. */ L100: i__1 = lend + 1; for (m = l; m >= i__1; --m) { if ((r__2 = e[m - 1], dabs(r__2)) <= eps2 * (r__1 = d__[m] * d__[ m - 1], dabs(r__1))) { goto L120; } /* L110: */ } m = lend; L120: if (m > lend) { e[m - 1] = 0.f; } p = d__[l]; if (m == l) { goto L140; } /* If remaining matrix is 2 by 2, use SLAE2 to compute its eigenvalues. */ if (m == l - 1) { rte = sqrt(e[l - 1]); slae2_(&d__[l], &rte, &d__[l - 1], &rt1, &rt2); d__[l] = rt1; d__[l - 1] = rt2; e[l - 1] = 0.f; l += -2; if (l >= lend) { goto L100; } goto L150; } if (jtot == nmaxit) { goto L150; } ++jtot; /* Form shift. */ rte = sqrt(e[l - 1]); sigma = (d__[l - 1] - p) / (rte * 2.f); r__ = slapy2_(&sigma, &c_b32); sigma = p - rte / (sigma + r_sign(&r__, &sigma)); c__ = 1.f; s = 0.f; gamma = d__[m] - sigma; p = gamma * gamma; /* Inner loop */ i__1 = l - 1; for (i__ = m; i__ <= i__1; ++i__) { bb = e[i__]; r__ = p + bb; if (i__ != m) { e[i__ - 1] = s * r__; } oldc = c__; c__ = p / r__; s = bb / r__; oldgam = gamma; alpha = d__[i__ + 1]; gamma = c__ * (alpha - sigma) - s * oldgam; d__[i__] = oldgam + (alpha - gamma); if (c__ != 0.f) { p = gamma * gamma / c__; } else { p = oldc * bb; } /* L130: */ } e[l - 1] = s * p; d__[l] = sigma + gamma; goto L100; /* Eigenvalue found. */ L140: d__[l] = p; --l; if (l >= lend) { goto L100; } goto L150; } /* Undo scaling if necessary */ L150: if (iscale == 1) { i__1 = lendsv - lsv + 1; slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], n, info); } if (iscale == 2) { i__1 = lendsv - lsv + 1; slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], n, info); } /* Check for no convergence to an eigenvalue after a total of N*MAXIT iterations. */ if (jtot < nmaxit) { goto L10; } i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { if (e[i__] != 0.f) { ++(*info); } /* L160: */ } goto L180; /* Sort eigenvalues in increasing order. */ L170: slasrt_("I", n, &d__[1], info); L180: return 0; /* End of SSTERF */ } /* ssterf_ */
/* Subroutine */ int cgecon_(char *norm, integer *n, complex *a, integer *lda, real *anorm, real *rcond, complex *work, real *rwork, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1; real r__1, r__2; /* Builtin functions */ double r_imag(complex *); /* Local variables */ real sl; integer ix; real su; integer kase, kase1; real scale; extern logical lsame_(char *, char *); integer isave[3]; extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real *, integer *, integer *); extern integer icamax_(integer *, complex *, integer *); extern doublereal slamch_(char *); extern /* Subroutine */ int xerbla_(char *, integer *); real ainvnm; extern /* Subroutine */ int clatrs_(char *, char *, char *, char *, integer *, complex *, integer *, complex *, real *, real *, integer *), csrscl_(integer *, real *, complex *, integer *); logical onenrm; char normin[1]; real smlnum; /* -- LAPACK routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CGECON estimates the reciprocal of the condition number of a general */ /* complex matrix A, in either the 1-norm or the infinity-norm, using */ /* the LU factorization computed by CGETRF. */ /* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ /* condition number is computed as */ /* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies whether the 1-norm condition number or the */ /* infinity-norm condition number is required: */ /* = '1' or 'O': 1-norm; */ /* = 'I': Infinity-norm. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* A (input) COMPLEX array, dimension (LDA,N) */ /* The factors L and U from the factorization A = P*L*U */ /* as computed by CGETRF. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* ANORM (input) REAL */ /* If NORM = '1' or 'O', the 1-norm of the original matrix A. */ /* If NORM = 'I', the infinity-norm of the original matrix A. */ /* RCOND (output) REAL */ /* The reciprocal of the condition number of the matrix A, */ /* computed as RCOND = 1/(norm(A) * norm(inv(A))). */ /* WORK (workspace) COMPLEX array, dimension (2*N) */ /* RWORK (workspace) REAL array, dimension (2*N) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Statement Functions .. */ /* .. */ /* .. Statement Function definitions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --work; --rwork; /* Function Body */ *info = 0; onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); if (! onenrm && ! lsame_(norm, "I")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*n)) { *info = -4; } else if (*anorm < 0.f) { *info = -5; } if (*info != 0) { i__1 = -(*info); xerbla_("CGECON", &i__1); return 0; } /* Quick return if possible */ *rcond = 0.f; if (*n == 0) { *rcond = 1.f; return 0; } else if (*anorm == 0.f) { return 0; } smlnum = slamch_("Safe minimum"); /* Estimate the norm of inv(A). */ ainvnm = 0.f; *(unsigned char *)normin = 'N'; if (onenrm) { kase1 = 1; } else { kase1 = 2; } kase = 0; L10: clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); if (kase != 0) { if (kase == kase1) { /* Multiply by inv(L). */ clatrs_("Lower", "No transpose", "Unit", normin, n, &a[a_offset], lda, &work[1], &sl, &rwork[1], info); /* Multiply by inv(U). */ clatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[ a_offset], lda, &work[1], &su, &rwork[*n + 1], info); } else { /* Multiply by inv(U'). */ clatrs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &a[ a_offset], lda, &work[1], &su, &rwork[*n + 1], info); /* Multiply by inv(L'). */ clatrs_("Lower", "Conjugate transpose", "Unit", normin, n, &a[ a_offset], lda, &work[1], &sl, &rwork[1], info); } /* Divide X by 1/(SL*SU) if doing so will not cause overflow. */ scale = sl * su; *(unsigned char *)normin = 'Y'; if (scale != 1.f) { ix = icamax_(n, &work[1], &c__1); i__1 = ix; if (scale < ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(& work[ix]), dabs(r__2))) * smlnum || scale == 0.f) { goto L20; } csrscl_(n, &scale, &work[1], &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.f) { *rcond = 1.f / ainvnm / *anorm; } L20: return 0; /* End of CGECON */ } /* cgecon_ */
/* Subroutine */ int slassq_(integer *n, real *x, integer *incx, real *scale, real *sumsq) { /* System generated locals */ integer i__1, i__2; real r__1; /* Local variables */ integer ix; real absxi; /* -- LAPACK auxiliary routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* SLASSQ returns the values scl and smsq such that */ /* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is */ /* assumed to be non-negative and scl returns the value */ /* scl = max( scale, abs( x( i ) ) ). */ /* scale and sumsq must be supplied in SCALE and SUMSQ and */ /* scl and smsq are overwritten on SCALE and SUMSQ respectively. */ /* The routine makes only one pass through the vector x. */ /* Arguments */ /* ========= */ /* N (input) INTEGER */ /* The number of elements to be used from the vector X. */ /* X (input) REAL array, dimension (N) */ /* The vector for which a scaled sum of squares is computed. */ /* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. */ /* INCX (input) INTEGER */ /* The increment between successive values of the vector X. */ /* INCX > 0. */ /* SCALE (input/output) REAL */ /* On entry, the value scale in the equation above. */ /* On exit, SCALE is overwritten with scl , the scaling factor */ /* for the sum of squares. */ /* SUMSQ (input/output) REAL */ /* On entry, the value sumsq in the equation above. */ /* On exit, SUMSQ is overwritten with smsq , the basic sum of */ /* squares from which scl has been factored out. */ /* ===================================================================== */ /* Parameter adjustments */ --x; /* Function Body */ if (*n > 0) { i__1 = (*n - 1) * *incx + 1; i__2 = *incx; for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { if (x[ix] != 0.f) { absxi = (r__1 = x[ix], dabs(r__1)); if (*scale < absxi) { /* Computing 2nd power */ r__1 = *scale / absxi; *sumsq = *sumsq * (r__1 * r__1) + 1; *scale = absxi; } else { /* Computing 2nd power */ r__1 = absxi / *scale; *sumsq += r__1 * r__1; } } } } return 0; /* End of SLASSQ */ } /* slassq_ */
/* 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 qc25c_(E_fp f, real *a, real *b, real *c__, real *result, real *abserr, integer *krul, integer *neval) { /* Initialized data */ static real x[11] = { (float).9914448613738104,(float).9659258262890683,( float).9238795325112868,(float).8660254037844386,(float) .7933533402912352,(float).7071067811865475,(float) .6087614290087206,(float).5,(float).3826834323650898,(float) .2588190451025208,(float).1305261922200516 }; /* System generated locals */ real r__1; /* Builtin functions */ double log(doublereal); /* Local variables */ real fval[25], res12, res24; extern /* Subroutine */ int qk15w_(E_fp, E_fp, real *, real *, real *, real *, integer *, real *, real *, real *, real *, real *, real *) ; integer isym; real amom0, amom1, amom2, cheb12[13], cheb24[25]; integer i__, k; extern /* Subroutine */ int qcheb_(real *, real *, real *, real *); real u, hlgth, centr; extern doublereal qwgtc_(real *x, real *c__, real *p2, real *p3, real *p4, integer *kp); real p2, p3, p4, cc; integer kp; real resabs, resasc, ak22; /* ***begin prologue qc25c */ /* ***date written 810101 (yymmdd) */ /* ***revision date 830518 (yymmdd) */ /* ***category no. h2a2a2,j4 */ /* ***keywords 25-point clenshaw-curtis integration */ /* ***author piessens,robert,appl. math. & progr. div. - k.u.leuven */ /* de doncker,elise,appl. math. & progr. div. - k.u.leuven */ /* ***purpose to compute i = integral of f*w over (a,b) with */ /* error estimate, where w(x) = 1/(x-c) */ /* ***description */ /* integration rules for the computation of cauchy */ /* principal value integrals */ /* standard fortran subroutine */ /* real version */ /* parameters */ /* f - real */ /* function subprogram defining the integrand function */ /* f(x). the actual name for f needs to be declared */ /* e x t e r n a l in the driver program. */ /* a - real */ /* left end point of the integration interval */ /* b - real */ /* right end point of the integration interval, b.gt.a */ /* c - real */ /* parameter in the weight function */ /* result - real */ /* approximation to the integral */ /* result is computed by using a generalized */ /* clenshaw-curtis method if c lies within ten percent */ /* of the integration interval. in the other case the */ /* 15-point kronrod rule obtained by optimal addition */ /* of abscissae to the 7-point gauss rule, is applied. */ /* abserr - real */ /* estimate of the modulus of the absolute error, */ /* which should equal or exceed abs(i-result) */ /* krul - integer */ /* key which is decreased by 1 if the 15-point */ /* gauss-kronrod scheme has been used */ /* neval - integer */ /* number of integrand evaluations */ /* ***references (none) */ /* ***routines called qcheb,qk15w,qwgtc */ /* ***end prologue qc25c */ /* the vector x contains the values cos(k*pi/24), */ /* k = 1, ..., 11, to be used for the chebyshev series */ /* expansion of f */ /* list of major variables */ /* ---------------------- */ /* fval - value of the function f at the points */ /* cos(k*pi/24), k = 0, ..., 24 */ /* cheb12 - chebyshev series expansion coefficients, */ /* for the function f, of degree 12 */ /* cheb24 - chebyshev series expansion coefficients, */ /* for the function f, of degree 24 */ /* res12 - approximation to the integral corresponding */ /* to the use of cheb12 */ /* res24 - approximation to the integral corresponding */ /* to the use of cheb24 */ /* qwgtc - external function subprogram defining */ /* the weight function */ /* hlgth - half-length of the interval */ /* centr - mid point of the interval */ /* check the position of c. */ /* ***first executable statement qc25c */ cc = ((float)2. * *c__ - *b - *a) / (*b - *a); if (dabs(cc) < (float)1.1) { goto L10; } /* apply the 15-point gauss-kronrod scheme. */ --(*krul); qk15w_((E_fp)f, (E_fp)qwgtc_, c__, &p2, &p3, &p4, &kp, a, b, result, abserr, &resabs, &resasc); *neval = 15; if (resasc == *abserr) { ++(*krul); } goto L50; /* use the generalized clenshaw-curtis method. */ L10: hlgth = (*b - *a) * (float).5; centr = (*b + *a) * (float).5; *neval = 25; r__1 = hlgth + centr; fval[0] = (*f)(&r__1) * (float).5; fval[12] = (*f)(¢r); r__1 = centr - hlgth; fval[24] = (*f)(&r__1) * (float).5; for (i__ = 2; i__ <= 12; ++i__) { u = hlgth * x[i__ - 2]; isym = 26 - i__; r__1 = u + centr; fval[i__ - 1] = (*f)(&r__1); r__1 = centr - u; fval[isym - 1] = (*f)(&r__1); /* L20: */ } /* compute the chebyshev series expansion. */ qcheb_(x, fval, cheb12, cheb24); /* the modified chebyshev moments are computed */ /* by forward recursion, using amom0 and amom1 */ /* as starting values. */ amom0 = log((r__1 = ((float)1. - cc) / (cc + (float)1.), dabs(r__1))); amom1 = cc * amom0 + (float)2.; res12 = cheb12[0] * amom0 + cheb12[1] * amom1; res24 = cheb24[0] * amom0 + cheb24[1] * amom1; for (k = 3; k <= 13; ++k) { amom2 = cc * (float)2. * amom1 - amom0; ak22 = (real) ((k - 2) * (k - 2)); if (k / 2 << 1 == k) { amom2 -= (float)4. / (ak22 - (float)1.); } res12 += cheb12[k - 1] * amom2; res24 += cheb24[k - 1] * amom2; amom0 = amom1; amom1 = amom2; /* L30: */ } for (k = 14; k <= 25; ++k) { amom2 = cc * (float)2. * amom1 - amom0; ak22 = (real) ((k - 2) * (k - 2)); if (k / 2 << 1 == k) { amom2 -= (float)4. / (ak22 - (float)1.); } res24 += cheb24[k - 1] * amom2; amom0 = amom1; amom1 = amom2; /* L40: */ } *result = res24; *abserr = (r__1 = res24 - res12, dabs(r__1)); L50: return 0; } /* qc25c_ */
/* 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 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 slaed0_(integer *icompq, integer *qsiz, integer *n, real *d, real *e, real *q, integer *ldq, real *qstore, integer *ldqs, 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 ======= SLAED0 computes all eigenvalues and corresponding eigenvectors of a symmetric tridiagonal matrix using the divide and conquer method. Arguments ========= ICOMPQ (input) INTEGER = 0: Compute eigenvalues only. = 1: Compute eigenvectors of original dense symmetric matrix also. On entry, Q contains the orthogonal matrix used to reduce the original matrix to tridiagonal form. = 2: Compute eigenvalues and eigenvectors of tridiagonal matrix. QSIZ (input) INTEGER The dimension of the orthogonal matrix used to reduce the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. N (input) INTEGER The dimension of the symmetric tridiagonal matrix. N >= 0. D (input/output) REAL array, dimension (N) On entry, the main diagonal of the tridiagonal matrix. On exit, its eigenvalues. E (input) REAL array, dimension (N-1) The off-diagonal elements of the tridiagonal matrix. On exit, E has been destroyed. Q (input/output) REAL array, dimension (LDQ, N) On entry, Q must contain an N-by-N orthogonal matrix. If ICOMPQ = 0 Q is not referenced. If ICOMPQ = 1 On entry, Q is a subset of the columns of the orthogonal matrix used to reduce the full matrix to tridiagonal form corresponding to the subset of the full matrix which is being decomposed at this time. If ICOMPQ = 2 On entry, Q will be the identity matrix. On exit, Q contains the eigenvectors of the tridiagonal matrix. LDQ (input) INTEGER The leading dimension of the array Q. If eigenvectors are desired, then LDQ >= max(1,N). In any case, LDQ >= 1. QSTORE (workspace) REAL array, dimension (LDQS, N) Referenced only when ICOMPQ = 1. Used to store parts of the eigenvector matrix when the updating matrix multiplies take place. LDQS (input) INTEGER The leading dimension of the array QSTORE. If ICOMPQ = 1, then LDQS >= max(1,N). In any case, LDQS >= 1. WORK (workspace) REAL array, dimension (1 + 3*N + 2*N*lg N + 2*N**2) ( lg( N ) = smallest integer k such that 2^k >= N ) IWORK (workspace) INTEGER array, If ICOMPQ = 0 or 1, the dimension of IWORK must be at least 6 + 6*N + 5*N*lg N. ( lg( N ) = smallest integer k such that 2^k >= N ) If ICOMPQ = 2, the dimension of IWORK must be at least 2 + 5*N. INFO (output) INTEGER = 0: successful exit. < 0: if INFO = -i, the i-th argument had an illegal value. > 0: The algorithm failed to compute an eigenvalue while working on the submatrix lying in rows and columns INFO/(N+1) through mod(INFO,N+1). ===================================================================== Test the input parameters. Parameter adjustments Function Body */ /* Table of constant values */ static integer c__2 = 2; static real c_b16 = 1.f; static real c_b17 = 0.f; static integer c__1 = 1; /* System generated locals */ integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2; real r__1; /* Builtin functions */ double log(doublereal); integer pow_ii(integer *, integer *); /* Local variables */ static real temp; static integer curr, i, j, k; extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *); static integer iperm, indxq, iwrem; extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *); static integer iqptr, tlvls; extern /* Subroutine */ int slaed1_(integer *, real *, real *, integer *, integer *, real *, integer *, real *, integer *, integer *), slaed7_(integer *, integer *, integer *, integer *, integer *, integer *, real *, real *, integer *, integer *, real *, integer * , real *, integer *, integer *, integer *, integer *, integer *, real *, real *, integer *, integer *); static integer iq, igivcl; extern /* Subroutine */ int xerbla_(char *, integer *); static integer igivnm, submat; extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *); static integer curprb, subpbs, igivpt, curlvl, matsiz, iprmpt; extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *, real *, integer *, real *, integer *); static integer lgn, msd2, smm1, spm1, spm2; #define D(I) d[(I)-1] #define E(I) e[(I)-1] #define WORK(I) work[(I)-1] #define IWORK(I) iwork[(I)-1] #define Q(I,J) q[(I)-1 + ((J)-1)* ( *ldq)] #define QSTORE(I,J) qstore[(I)-1 + ((J)-1)* ( *ldqs)] *info = 0; if (*icompq < 0 || *icompq > 2) { *info = -1; } else if (*icompq == 1 && *qsiz < max(0,*n)) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*ldq < max(1,*n)) { *info = -7; } else if (*ldqs < max(1,*n)) { *info = -9; } if (*info != 0) { i__1 = -(*info); xerbla_("SLAED0", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Determine the size and placement of the submatrices, and save in the leading elements of IWORK. */ IWORK(1) = *n; subpbs = 1; tlvls = 0; L10: if (IWORK(subpbs) > 25) { for (j = subpbs; j >= 1; --j) { IWORK(j * 2) = (IWORK(j) + 1) / 2; IWORK((j << 1) - 1) = IWORK(j) / 2; /* L20: */ } ++tlvls; subpbs <<= 1; goto L10; } i__1 = subpbs; for (j = 2; j <= subpbs; ++j) { IWORK(j) += IWORK(j - 1); /* L30: */ } /* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 using rank-1 modifications (cuts). */ spm1 = subpbs - 1; i__1 = spm1; for (i = 1; i <= spm1; ++i) { submat = IWORK(i) + 1; smm1 = submat - 1; D(smm1) -= (r__1 = E(smm1), dabs(r__1)); D(submat) -= (r__1 = E(smm1), dabs(r__1)); /* L40: */ } indxq = (*n << 2) + 3; if (*icompq != 2) { /* Set up workspaces for eigenvalues only/accumulate new vector s routine */ temp = log((real) (*n)) / log(2.f); lgn = (integer) temp; if (pow_ii(&c__2, &lgn) < *n) { ++lgn; } if (pow_ii(&c__2, &lgn) < *n) { ++lgn; } iprmpt = indxq + *n + 1; iperm = iprmpt + *n * lgn; iqptr = iperm + *n * lgn; igivpt = iqptr + *n + 2; igivcl = igivpt + *n * lgn; igivnm = 1; iq = igivnm + (*n << 1) * lgn; /* Computing 2nd power */ i__1 = *n; iwrem = iq + i__1 * i__1 + 1; /* Initialize pointers */ i__1 = subpbs; for (i = 0; i <= subpbs; ++i) { IWORK(iprmpt + i) = 1; IWORK(igivpt + i) = 1; /* L50: */ } IWORK(iqptr) = 1; } /* Solve each submatrix eigenproblem at the bottom of the divide and conquer tree. */ curr = 0; i__1 = spm1; for (i = 0; i <= spm1; ++i) { if (i == 0) { submat = 1; matsiz = IWORK(1); } else { submat = IWORK(i) + 1; matsiz = IWORK(i + 1) - IWORK(i); } if (*icompq == 2) { ssteqr_("I", &matsiz, &D(submat), &E(submat), &Q(submat,submat), ldq, &WORK(1), info); if (*info != 0) { goto L130; } } else { ssteqr_("I", &matsiz, &D(submat), &E(submat), &WORK(iq - 1 + IWORK(iqptr + curr)), &matsiz, &WORK(1), info); if (*info != 0) { goto L130; } if (*icompq == 1) { sgemm_("N", "N", qsiz, &matsiz, &matsiz, &c_b16, &Q(1,submat), ldq, &WORK(iq - 1 + IWORK(iqptr + curr)), &matsiz, &c_b17, &QSTORE(1,submat), ldqs); } /* Computing 2nd power */ i__2 = matsiz; IWORK(iqptr + curr + 1) = IWORK(iqptr + curr) + i__2 * i__2; ++curr; } k = 1; i__2 = IWORK(i + 1); for (j = submat; j <= IWORK(i+1); ++j) { IWORK(indxq + j) = k; ++k; /* L60: */ } /* L70: */ } /* Successively merge eigensystems of adjacent submatrices into eigensystem for the corresponding larger matrix. while ( SUBPBS > 1 ) */ curlvl = 1; L80: if (subpbs > 1) { spm2 = subpbs - 2; i__1 = spm2; for (i = 0; i <= spm2; i += 2) { if (i == 0) { submat = 1; matsiz = IWORK(2); msd2 = IWORK(1); curprb = 0; } else { submat = IWORK(i) + 1; matsiz = IWORK(i + 2) - IWORK(i); msd2 = matsiz / 2; ++curprb; } /* Merge lower order eigensystems (of size MSD2 and MATSIZ - M SD2) into an eigensystem of size MATSIZ. SLAED1 is used only for the full eigensystem of a tridiagon al matrix. SLAED7 handles the cases in which eigenvalues only or eigen values and eigenvectors of a full symmetric matrix (which was redu ced to tridiagonal form) are desired. */ if (*icompq == 2) { slaed1_(&matsiz, &D(submat), &Q(submat,submat), ldq, &IWORK(indxq + submat), &E(submat + msd2 - 1), & msd2, &WORK(1), &IWORK(subpbs + 1), info); } else { slaed7_(icompq, &matsiz, qsiz, &tlvls, &curlvl, &curprb, &D( submat), &QSTORE(1,submat), ldqs, & IWORK(indxq + submat), &E(submat + msd2 - 1), &msd2, & WORK(iq), &IWORK(iqptr), &IWORK(iprmpt), &IWORK(iperm) , &IWORK(igivpt), &IWORK(igivcl), &WORK(igivnm), & WORK(iwrem), &IWORK(subpbs + 1), info); } if (*info != 0) { goto L130; } IWORK(i / 2 + 1) = IWORK(i + 2); /* L90: */ } subpbs /= 2; ++curlvl; goto L80; } /* end while Re-merge the eigenvalues/vectors which were deflated at the final merge step. */ if (*icompq == 1) { i__1 = *n; for (i = 1; i <= *n; ++i) { j = IWORK(indxq + i); WORK(i) = D(j); scopy_(qsiz, &QSTORE(1,j), &c__1, &Q(1,i), &c__1); /* L100: */ } scopy_(n, &WORK(1), &c__1, &D(1), &c__1); } else if (*icompq == 2) { i__1 = *n; for (i = 1; i <= *n; ++i) { j = IWORK(indxq + i); WORK(i) = D(j); scopy_(n, &Q(1,j), &c__1, &WORK(*n * i + 1), &c__1); /* L110: */ } scopy_(n, &WORK(1), &c__1, &D(1), &c__1); slacpy_("A", n, n, &WORK(*n + 1), n, &Q(1,1), ldq); } else { i__1 = *n; for (i = 1; i <= *n; ++i) { j = IWORK(indxq + i); WORK(i) = D(j); /* L120: */ } scopy_(n, &WORK(1), &c__1, &D(1), &c__1); } goto L140; L130: *info = submat * (*n + 1) + submat + matsiz - 1; L140: return 0; /* End of SLAED0 */ } /* slaed0_ */
/* Subroutine */ int slaev2_(real *a, real *b, real *c__, real *rt1, real * rt2, real *cs1, real *sn1) { /* System generated locals */ real r__1; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static real ab, df, cs, ct, tb, sm, tn, rt, adf, acs; static integer sgn1, sgn2; static real acmn, acmx; /* -- LAPACK auxiliary routine (version 3.0) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ /* Courant Institute, Argonne National Lab, and Rice University */ /* October 31, 1992 */ /* .. Scalar Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix */ /* [ A B ] */ /* [ B C ]. */ /* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the */ /* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right */ /* eigenvector for RT1, giving the decomposition */ /* [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] */ /* [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. */ /* Arguments */ /* ========= */ /* A (input) REAL */ /* The (1,1) element of the 2-by-2 matrix. */ /* B (input) REAL */ /* The (1,2) element and the conjugate of the (2,1) element of */ /* the 2-by-2 matrix. */ /* C (input) REAL */ /* The (2,2) element of the 2-by-2 matrix. */ /* RT1 (output) REAL */ /* The eigenvalue of larger absolute value. */ /* RT2 (output) REAL */ /* The eigenvalue of smaller absolute value. */ /* CS1 (output) REAL */ /* SN1 (output) REAL */ /* The vector (CS1, SN1) is a unit right eigenvector for RT1. */ /* Further Details */ /* =============== */ /* RT1 is accurate to a few ulps barring over/underflow. */ /* RT2 may be inaccurate if there is massive cancellation in the */ /* determinant A*C-B*B; higher precision or correctly rounded or */ /* correctly truncated arithmetic would be needed to compute RT2 */ /* accurately in all cases. */ /* CS1 and SN1 are accurate to a few ulps barring over/underflow. */ /* Overflow is possible only if RT1 is within a factor of 5 of overflow. */ /* Underflow is harmless if the input data is 0 or exceeds */ /* underflow_threshold / macheps. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Compute the eigenvalues */ sm = *a + *c__; df = *a - *c__; adf = dabs(df); tb = *b + *b; ab = dabs(tb); if (dabs(*a) > dabs(*c__)) { acmx = *a; acmn = *c__; } else { acmx = *c__; acmn = *a; } if (adf > ab) { /* Computing 2nd power */ r__1 = ab / adf; rt = adf * sqrt(r__1 * r__1 + 1.f); } else if (adf < ab) { /* Computing 2nd power */ r__1 = adf / ab; rt = ab * sqrt(r__1 * r__1 + 1.f); } else { /* Includes case AB=ADF=0 */ rt = ab * sqrt(2.f); } if (sm < 0.f) { *rt1 = (sm - rt) * .5f; sgn1 = -1; /* Order of execution important. */ /* To get fully accurate smaller eigenvalue, */ /* next line needs to be executed in higher precision. */ *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; } else if (sm > 0.f) { *rt1 = (sm + rt) * .5f; sgn1 = 1; /* Order of execution important. */ /* To get fully accurate smaller eigenvalue, */ /* next line needs to be executed in higher precision. */ *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; } else { /* Includes case RT1 = RT2 = 0 */ *rt1 = rt * .5f; *rt2 = rt * -.5f; sgn1 = 1; } /* Compute the eigenvector */ if (df >= 0.f) { cs = df + rt; sgn2 = 1; } else { cs = df - rt; sgn2 = -1; } acs = dabs(cs); if (acs > ab) { ct = -tb / cs; *sn1 = 1.f / sqrt(ct * ct + 1.f); *cs1 = ct * *sn1; } else { if (ab == 0.f) { *cs1 = 1.f; *sn1 = 0.f; } else { tn = -cs / tb; *cs1 = 1.f / sqrt(tn * tn + 1.f); *sn1 = tn * *cs1; } } if (sgn1 == sgn2) { tn = *cs1; *cs1 = -(*sn1); *sn1 = tn; } return 0; /* End of SLAEV2 */ } /* slaev2_ */
/* Subroutine */ int slacon_(integer *n, real *v, real *x, integer *isgn, real *est, integer *kase) { /* System generated locals */ integer i__1; real r__1; /* Builtin functions */ double r_sign(real *, real *); integer i_nint(real *); /* Local variables */ static integer i__, j, iter; static real temp; static integer jump, jlast; extern doublereal sasum_(integer *, real *, integer *); extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, integer *); extern integer isamax_(integer *, real *, integer *); static real altsgn, estold; /* -- LAPACK auxiliary routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SLACON estimates the 1-norm of a square, real matrix A. */ /* Reverse communication is used for evaluating matrix-vector products. */ /* Arguments */ /* ========= */ /* N (input) INTEGER */ /* The order of the matrix. N >= 1. */ /* V (workspace) REAL array, dimension (N) */ /* On the final return, V = A*W, where EST = norm(V)/norm(W) */ /* (W is not returned). */ /* X (input/output) REAL array, dimension (N) */ /* On an intermediate return, X should be overwritten by */ /* A * X, if KASE=1, */ /* A' * X, if KASE=2, */ /* and SLACON must be re-called with all the other parameters */ /* unchanged. */ /* ISGN (workspace) INTEGER array, dimension (N) */ /* EST (input/output) REAL */ /* On entry with KASE = 1 or 2 and JUMP = 3, EST should be */ /* unchanged from the previous call to SLACON. */ /* On exit, EST is an estimate (a lower bound) for norm(A). */ /* KASE (input/output) INTEGER */ /* On the initial call to SLACON, KASE should be 0. */ /* On an intermediate return, KASE will be 1 or 2, indicating */ /* whether X should be overwritten by A * X or A' * X. */ /* On the final return from SLACON, KASE will again be 0. */ /* Further Details */ /* ======= ======= */ /* Contributed by Nick Higham, University of Manchester. */ /* Originally named SONEST, dated March 16, 1988. */ /* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */ /* a real or complex matrix, with applications to condition estimation", */ /* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Save statement .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ --isgn; --x; --v; /* Function Body */ if (*kase == 0) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { x[i__] = 1.f / (real) (*n); /* L10: */ } *kase = 1; jump = 1; return 0; } switch (jump) { case 1: goto L20; case 2: goto L40; case 3: goto L70; case 4: goto L110; case 5: goto L140; } /* ................ ENTRY (JUMP = 1) */ /* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */ L20: if (*n == 1) { v[1] = x[1]; *est = dabs(v[1]); /* ... QUIT */ goto L150; } *est = sasum_(n, &x[1], &c__1); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { x[i__] = r_sign(&c_b11, &x[i__]); isgn[i__] = i_nint(&x[i__]); /* L30: */ } *kase = 2; jump = 2; return 0; /* ................ ENTRY (JUMP = 2) */ /* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */ L40: j = isamax_(n, &x[1], &c__1); iter = 2; /* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */ L50: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { x[i__] = 0.f; /* L60: */ } x[j] = 1.f; *kase = 1; jump = 3; return 0; /* ................ ENTRY (JUMP = 3) */ /* X HAS BEEN OVERWRITTEN BY A*X. */ L70: scopy_(n, &x[1], &c__1, &v[1], &c__1); estold = *est; *est = sasum_(n, &v[1], &c__1); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { r__1 = r_sign(&c_b11, &x[i__]); if (i_nint(&r__1) != isgn[i__]) { goto L90; } /* L80: */ } /* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */ goto L120; L90: /* TEST FOR CYCLING. */ if (*est <= estold) { goto L120; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { x[i__] = r_sign(&c_b11, &x[i__]); isgn[i__] = i_nint(&x[i__]); /* L100: */ } *kase = 2; jump = 4; return 0; /* ................ ENTRY (JUMP = 4) */ /* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */ L110: jlast = j; j = isamax_(n, &x[1], &c__1); if (x[jlast] != (r__1 = x[j], dabs(r__1)) && iter < 5) { ++iter; goto L50; } /* ITERATION COMPLETE. FINAL STAGE. */ L120: altsgn = 1.f; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { x[i__] = altsgn * ((real) (i__ - 1) / (real) (*n - 1) + 1.f); altsgn = -altsgn; /* L130: */ } *kase = 1; jump = 5; return 0; /* ................ ENTRY (JUMP = 5) */ /* X HAS BEEN OVERWRITTEN BY A*X. */ L140: temp = sasum_(n, &x[1], &c__1) / (real) (*n * 3) * 2.f; if (temp > *est) { scopy_(n, &x[1], &c__1, &v[1], &c__1); *est = temp; } L150: *kase = 0; return 0; /* End of SLACON */ } /* slacon_ */
/* 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_ */
/* Subroutine */ int slamc2_(int *beta, int *t, int *rnd, float * eps, int *emin, float *rmin, int *emax, float *rmax) { /* -- LAPACK auxiliary routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University October 31, 1992 Purpose ======= SLAMC2 determines the machine parameters specified in its argument list. Arguments ========= BETA (output) INT The base of the machine. T (output) INT The number of ( BETA ) digits in the mantissa. RND (output) INT Specifies whether proper rounding ( RND = .TRUE. ) or chopping ( RND = .FALSE. ) occurs in addition. This may not be a reliable guide to the way in which the machine performs its arithmetic. EPS (output) FLOAT The smallest positive number such that fl( 1.0 - EPS ) .LT. 1.0, where fl denotes the computed value. EMIN (output) INT The minimum exponent before (gradual) underflow occurs. RMIN (output) FLOAT The smallest normalized number for the machine, given by BASE**( EMIN - 1 ), where BASE is the floating point value of BETA. EMAX (output) INT The maximum exponent before overflow occurs. RMAX (output) FLOAT The largest positive number for the machine, given by BASE**EMAX * ( 1 - EPS ), where BASE is the floating point value of BETA. Further Details =============== The computation of EPS is based on a routine PARANOIA by W. Kahan of the University of California at Berkeley. ===================================================================== */ /* Table of constant values */ static int c__1 = 1; /* Initialized data */ static int first = TRUE_; static int iwarn = FALSE_; /* System generated locals */ int i__1; float r__1, r__2, r__3, r__4, r__5; /* Builtin functions */ double pow_ri(float *, int *); /* Local variables */ static int ieee; static float half; static int lrnd; static float leps, zero, a, b, c; static int i, lbeta; static float rbase; static int lemin, lemax, gnmin; static float small; static int gpmin; static float third, lrmin, lrmax, sixth; static int lieee1; extern /* Subroutine */ int slamc1_(int *, int *, int *, int *); extern double slamc3_(float *, float *); extern /* Subroutine */ int slamc4_(int *, float *, int *), slamc5_(int *, int *, int *, int *, int *, float *); static int lt, ngnmin, ngpmin; static float one, two; if (first) { first = FALSE_; zero = 0.f; one = 1.f; two = 2.f; /* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of BETA, T, RND, EPS, EMIN and RMIN. Throughout this routine we use the function SLAMC3 to ens ure that relevant values are stored and not held in registers, or are not affected by optimizers. SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. */ slamc1_(&lbeta, <, &lrnd, &lieee1); /* Start to find EPS. */ b = (float) lbeta; i__1 = -lt; a = pow_ri(&b, &i__1); leps = a; /* Try some tricks to see whether or not this is the correct E PS. */ b = two / 3; half = one / 2; r__1 = -(double)half; sixth = slamc3_(&b, &r__1); third = slamc3_(&sixth, &sixth); r__1 = -(double)half; b = slamc3_(&third, &r__1); b = slamc3_(&b, &sixth); b = dabs(b); if (b < leps) { b = leps; } leps = 1.f; /* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */ L10: if (leps > b && b > zero) { leps = b; r__1 = half * leps; /* Computing 5th power */ r__3 = two, r__4 = r__3, r__3 *= r__3; /* Computing 2nd power */ r__5 = leps; r__2 = r__4 * (r__3 * r__3) * (r__5 * r__5); c = slamc3_(&r__1, &r__2); r__1 = -(double)c; c = slamc3_(&half, &r__1); b = slamc3_(&half, &c); r__1 = -(double)b; c = slamc3_(&half, &r__1); b = slamc3_(&half, &c); goto L10; } /* + END WHILE */ if (a < leps) { leps = a; } /* Computation of EPS complete. Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3 )). Keep dividing A by BETA until (gradual) underflow occurs. T his is detected when we cannot recover the previous A. */ rbase = one / lbeta; small = one; for (i = 1; i <= 3; ++i) { r__1 = small * rbase; small = slamc3_(&r__1, &zero); /* L20: */ } a = slamc3_(&one, &small); slamc4_(&ngpmin, &one, &lbeta); r__1 = -(double)one; slamc4_(&ngnmin, &r__1, &lbeta); slamc4_(&gpmin, &a, &lbeta); r__1 = -(double)a; slamc4_(&gnmin, &r__1, &lbeta); ieee = FALSE_; if (ngpmin == ngnmin && gpmin == gnmin) { if (ngpmin == gpmin) { lemin = ngpmin; /* ( Non twos-complement machines, no gradual under flow; e.g., VAX ) */ } else if (gpmin - ngpmin == 3) { lemin = ngpmin - 1 + lt; ieee = TRUE_; /* ( Non twos-complement machines, with gradual und erflow; e.g., IEEE standard followers ) */ } else { lemin = min(ngpmin,gpmin); /* ( A guess; no known machine ) */ iwarn = TRUE_; } } else if (ngpmin == gpmin && ngnmin == gnmin) { if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) { lemin = max(ngpmin,ngnmin); /* ( Twos-complement machines, no gradual underflow ; e.g., CYBER 205 ) */ } else { lemin = min(ngpmin,ngnmin); /* ( A guess; no known machine ) */ iwarn = TRUE_; } } else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin) { if (gpmin - min(ngpmin,ngnmin) == 3) { lemin = max(ngpmin,ngnmin) - 1 + lt; /* ( Twos-complement machines with gradual underflo w; no known machine ) */ } else { lemin = min(ngpmin,ngnmin); /* ( A guess; no known machine ) */ iwarn = TRUE_; } } else { /* Computing MIN */ i__1 = min(ngpmin,ngnmin), i__1 = min(i__1,gpmin); lemin = min(i__1,gnmin); /* ( A guess; no known machine ) */ iwarn = TRUE_; } /* ** Comment out this if block if EMIN is ok */ if (iwarn) { first = TRUE_; printf("\n\n WARNING. The value EMIN may be incorrect:- "); printf("EMIN = %8i\n",lemin); printf("If, after inspection, the value EMIN looks acceptable"); printf("please comment out \n the IF block as marked within the"); printf("code of routine SLAMC2, \n otherwise supply EMIN"); printf("explicitly.\n"); } /* ** Assume IEEE arithmetic if we found denormalised numbers abo ve, or if arithmetic seems to round in the IEEE style, determi ned in routine SLAMC1. A true IEEE machine should have both thi ngs true; however, faulty machines may have one or the other. */ ieee = ieee || lieee1; /* Compute RMIN by successive division by BETA. We could comp ute RMIN as BASE**( EMIN - 1 ), but some machines underflow dur ing this computation. */ lrmin = 1.f; i__1 = 1 - lemin; for (i = 1; i <= 1-lemin; ++i) { r__1 = lrmin * rbase; lrmin = slamc3_(&r__1, &zero); /* L30: */ } /* Finally, call SLAMC5 to compute EMAX and RMAX. */ slamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax); } *beta = lbeta; *t = lt; *rnd = lrnd; *eps = leps; *emin = lemin; *rmin = lrmin; *emax = lemax; *rmax = lrmax; return 0; /* End of SLAMC2 */ } /* slamc2_ */
/* DECK CTRSL */ /* Subroutine */ int ctrsl_(complex *t, integer *ldt, integer *n, complex *b, integer *job, integer *info) { /* System generated locals */ integer t_dim1, t_offset, i__1, i__2, i__3, i__4; real r__1, r__2; complex q__1, q__2; /* Local variables */ static integer j, jj, case__; static complex temp; extern /* Complex */ void cdotc_(complex *, integer *, complex *, integer *, complex *, integer *); extern /* Subroutine */ int caxpy_(integer *, complex *, complex *, integer *, complex *, integer *); /* ***BEGIN PROLOGUE CTRSL */ /* ***PURPOSE Solve a system of the form T*X=B or CTRANS(T)*X=B, where */ /* T is a triangular matrix. Here CTRANS(T) is the conjugate */ /* transpose. */ /* ***LIBRARY SLATEC (LINPACK) */ /* ***CATEGORY D2C3 */ /* ***TYPE COMPLEX (STRSL-S, DTRSL-D, CTRSL-C) */ /* ***KEYWORDS LINEAR ALGEBRA, LINPACK, TRIANGULAR LINEAR SYSTEM, */ /* TRIANGULAR MATRIX */ /* ***AUTHOR Stewart, G. W., (U. of Maryland) */ /* ***DESCRIPTION */ /* CTRSL solves systems of the form */ /* T * X = B */ /* or */ /* CTRANS(T) * X = B */ /* where T is a triangular matrix of order N. Here CTRANS(T) */ /* denotes the conjugate transpose of the matrix T. */ /* On Entry */ /* T COMPLEX(LDT,N) */ /* T contains the matrix of the system. The zero */ /* elements of the matrix are not referenced, and */ /* the corresponding elements of the array can be */ /* used to store other information. */ /* LDT INTEGER */ /* LDT is the leading dimension of the array T. */ /* N INTEGER */ /* N is the order of the system. */ /* B COMPLEX(N). */ /* B contains the right hand side of the system. */ /* JOB INTEGER */ /* JOB specifies what kind of system is to be solved. */ /* If JOB is */ /* 00 solve T*X = B, T lower triangular, */ /* 01 solve T*X = B, T upper triangular, */ /* 10 solve CTRANS(T)*X = B, T lower triangular, */ /* 11 solve CTRANS(T)*X = B, T upper triangular. */ /* On Return */ /* B B contains the solution, if INFO .EQ. 0. */ /* Otherwise B is unaltered. */ /* INFO INTEGER */ /* INFO contains zero if the system is nonsingular. */ /* Otherwise INFO contains the index of */ /* the first zero diagonal element of T. */ /* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */ /* Stewart, LINPACK Users' Guide, SIAM, 1979. */ /* ***ROUTINES CALLED CAXPY, CDOTC */ /* ***REVISION HISTORY (YYMMDD) */ /* 780814 DATE WRITTEN */ /* 890831 Modified array declarations. (WRB) */ /* 890831 REVISION DATE from Version 3.2 */ /* 891214 Prologue converted to Version 4.0 format. (BAB) */ /* 900326 Removed duplicate information from DESCRIPTION section. */ /* (WRB) */ /* 920501 Reformatted the REFERENCES section. (WRB) */ /* ***END PROLOGUE CTRSL */ /* ***FIRST EXECUTABLE STATEMENT CTRSL */ /* CHECK FOR ZERO DIAGONAL ELEMENTS. */ /* Parameter adjustments */ t_dim1 = *ldt; t_offset = 1 + t_dim1; t -= t_offset; --b; /* Function Body */ i__1 = *n; for (*info = 1; *info <= i__1; ++(*info)) { i__2 = *info + *info * t_dim1; if ((r__1 = t[i__2].r, dabs(r__1)) + (r__2 = r_imag(&t[*info + *info * t_dim1]), dabs(r__2)) == 0.f) { goto L150; } /* L10: */ } *info = 0; /* DETERMINE THE TASK AND GO TO IT. */ case__ = 1; if (*job % 10 != 0) { case__ = 2; } if (*job % 100 / 10 != 0) { case__ += 2; } switch (case__) { case 1: goto L20; case 2: goto L50; case 3: goto L80; case 4: goto L110; } /* SOLVE T*X=B FOR T LOWER TRIANGULAR */ L20: c_div(&q__1, &b[1], &t[t_dim1 + 1]); b[1].r = q__1.r, b[1].i = q__1.i; if (*n < 2) { goto L40; } i__1 = *n; for (j = 2; j <= i__1; ++j) { i__2 = j - 1; q__1.r = -b[i__2].r, q__1.i = -b[i__2].i; temp.r = q__1.r, temp.i = q__1.i; i__2 = *n - j + 1; caxpy_(&i__2, &temp, &t[j + (j - 1) * t_dim1], &c__1, &b[j], &c__1); i__2 = j; c_div(&q__1, &b[j], &t[j + j * t_dim1]); b[i__2].r = q__1.r, b[i__2].i = q__1.i; /* L30: */ } L40: goto L140; /* SOLVE T*X=B FOR T UPPER TRIANGULAR. */ L50: i__1 = *n; c_div(&q__1, &b[*n], &t[*n + *n * t_dim1]); b[i__1].r = q__1.r, b[i__1].i = q__1.i; if (*n < 2) { goto L70; } i__1 = *n; for (jj = 2; jj <= i__1; ++jj) { j = *n - jj + 1; i__2 = j + 1; q__1.r = -b[i__2].r, q__1.i = -b[i__2].i; temp.r = q__1.r, temp.i = q__1.i; caxpy_(&j, &temp, &t[(j + 1) * t_dim1 + 1], &c__1, &b[1], &c__1); i__2 = j; c_div(&q__1, &b[j], &t[j + j * t_dim1]); b[i__2].r = q__1.r, b[i__2].i = q__1.i; /* L60: */ } L70: goto L140; /* SOLVE CTRANS(T)*X=B FOR T LOWER TRIANGULAR. */ L80: i__1 = *n; r_cnjg(&q__2, &t[*n + *n * t_dim1]); c_div(&q__1, &b[*n], &q__2); b[i__1].r = q__1.r, b[i__1].i = q__1.i; if (*n < 2) { goto L100; } i__1 = *n; for (jj = 2; jj <= i__1; ++jj) { j = *n - jj + 1; i__2 = j; i__3 = j; i__4 = jj - 1; cdotc_(&q__2, &i__4, &t[j + 1 + j * t_dim1], &c__1, &b[j + 1], &c__1); q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; i__2 = j; r_cnjg(&q__2, &t[j + j * t_dim1]); c_div(&q__1, &b[j], &q__2); b[i__2].r = q__1.r, b[i__2].i = q__1.i; /* L90: */ } L100: goto L140; /* SOLVE CTRANS(T)*X=B FOR T UPPER TRIANGULAR. */ L110: r_cnjg(&q__2, &t[t_dim1 + 1]); c_div(&q__1, &b[1], &q__2); b[1].r = q__1.r, b[1].i = q__1.i; if (*n < 2) { goto L130; } i__1 = *n; for (j = 2; j <= i__1; ++j) { i__2 = j; i__3 = j; i__4 = j - 1; cdotc_(&q__2, &i__4, &t[j * t_dim1 + 1], &c__1, &b[1], &c__1); q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i; b[i__2].r = q__1.r, b[i__2].i = q__1.i; i__2 = j; r_cnjg(&q__2, &t[j + j * t_dim1]); c_div(&q__1, &b[j], &q__2); b[i__2].r = q__1.r, b[i__2].i = q__1.i; /* L120: */ } L130: L140: L150: return 0; } /* ctrsl_ */
/* 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 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 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_ */