/* Subroutine */ int cla_syrfsx_extended_(integer *prec_type__, char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, logical *colequ, real *c__, complex *b, integer *ldb, complex *y, integer *ldy, real *berr_out__, integer * n_norms__, real *err_bnds_norm__, real *err_bnds_comp__, complex *res, real *ayb, complex *dy, complex *y_tail__, real *rcond, integer * ithresh, real *rthresh, real *dz_ub__, logical *ignore_cwise__, integer *info) { /* System generated locals */ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1, y_offset, err_bnds_norm_dim1, err_bnds_norm_offset, err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3, i__4; real r__1, r__2; /* Builtin functions */ double r_imag(complex *); /* Local variables */ real dxratmax, dzratmax; integer i__, j; logical incr_prec__; extern /* Subroutine */ int cla_syamv_(integer *, integer *, real *, complex *, integer *, complex *, integer *, real *, real *, integer *); real prev_dz_z__, yk, final_dx_x__; extern /* Subroutine */ int cla_wwaddw_(integer *, complex *, complex *, complex *); real final_dz_z__, prevnormdx; integer cnt; real dyk, eps, incr_thresh__, dx_x__, dz_z__; extern /* Subroutine */ int cla_lin_berr_(integer *, integer *, integer * , complex *, real *, real *); real ymin; integer y_prec_state__; extern /* Subroutine */ int blas_csymv_x_(integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *, integer *); integer uplo2; extern logical lsame_(char *, char *); extern /* Subroutine */ int blas_csymv2_x_(integer *, integer *, complex *, complex *, integer *, complex *, complex *, integer *, complex *, complex *, integer *, integer *), ccopy_(integer *, complex *, integer *, complex *, integer *); real dxrat, dzrat; extern /* Subroutine */ int caxpy_(integer *, complex *, complex *, integer *, complex *, integer *); logical upper; extern /* Subroutine */ int csymv_(char *, integer *, complex *, complex * , integer *, complex *, integer *, complex *, complex *, integer * ); real normx, normy; extern real slamch_(char *); extern /* Subroutine */ int xerbla_(char *, integer *); real normdx; extern /* Subroutine */ int csytrs_(char *, integer *, integer *, complex *, integer *, integer *, complex *, integer *, integer *); real hugeval; extern integer ilauplo_(char *); integer x_state__, z_state__; /* -- LAPACK computational routine (version 3.4.2) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* September 2012 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ===================================================================== */ /* .. Local Scalars .. */ /* .. */ /* .. Parameters .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Statement Functions .. */ /* .. */ /* .. Statement Function Definitions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ err_bnds_comp_dim1 = *nrhs; err_bnds_comp_offset = 1 + err_bnds_comp_dim1; err_bnds_comp__ -= err_bnds_comp_offset; err_bnds_norm_dim1 = *nrhs; err_bnds_norm_offset = 1 + err_bnds_norm_dim1; err_bnds_norm__ -= err_bnds_norm_offset; a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; af_dim1 = *ldaf; af_offset = 1 + af_dim1; af -= af_offset; --ipiv; --c__; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; y_dim1 = *ldy; y_offset = 1 + y_dim1; y -= y_offset; --berr_out__; --res; --ayb; --dy; --y_tail__; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*nrhs < 0) { *info = -4; } else if (*lda < max(1,*n)) { *info = -6; } else if (*ldaf < max(1,*n)) { *info = -8; } else if (*ldb < max(1,*n)) { *info = -13; } else if (*ldy < max(1,*n)) { *info = -15; } if (*info != 0) { i__1 = -(*info); xerbla_("CLA_SYRFSX_EXTENDED", &i__1); return 0; } eps = slamch_("Epsilon"); hugeval = slamch_("Overflow"); /* Force HUGEVAL to Inf */ hugeval *= hugeval; /* Using HUGEVAL may lead to spurious underflows. */ incr_thresh__ = (real) (*n) * eps; if (lsame_(uplo, "L")) { uplo2 = ilauplo_("L"); } else { uplo2 = ilauplo_("U"); } i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { y_prec_state__ = 1; if (y_prec_state__ == 2) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__; y_tail__[i__3].r = 0.f; y_tail__[i__3].i = 0.f; // , expr subst } } dxrat = 0.f; dxratmax = 0.f; dzrat = 0.f; dzratmax = 0.f; final_dx_x__ = hugeval; final_dz_z__ = hugeval; prevnormdx = hugeval; prev_dz_z__ = hugeval; dz_z__ = hugeval; dx_x__ = hugeval; x_state__ = 1; z_state__ = 0; incr_prec__ = FALSE_; i__2 = *ithresh; for (cnt = 1; cnt <= i__2; ++cnt) { /* Compute residual RES = B_s - op(A_s) * Y, */ /* op(A) = A, A**T, or A**H depending on TRANS (and type). */ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); if (y_prec_state__ == 0) { csymv_(uplo, n, &c_b14, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1, &c_b15, &res[1], &c__1); } else if (y_prec_state__ == 1) { blas_csymv_x_(&uplo2, n, &c_b14, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1, &c_b15, &res[1], &c__1, prec_type__); } else { blas_csymv2_x_(&uplo2, n, &c_b14, &a[a_offset], lda, &y[j * y_dim1 + 1], &y_tail__[1], &c__1, &c_b15, &res[1], & c__1, prec_type__); } /* XXX: RES is no longer needed. */ ccopy_(n, &res[1], &c__1, &dy[1], &c__1); csytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &dy[1], n, info); /* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */ normx = 0.f; normy = 0.f; normdx = 0.f; dz_z__ = 0.f; ymin = hugeval; i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = i__ + j * y_dim1; yk = (r__1 = y[i__4].r, f2c_abs(r__1)) + (r__2 = r_imag(&y[i__ + j * y_dim1]), f2c_abs(r__2)); i__4 = i__; dyk = (r__1 = dy[i__4].r, f2c_abs(r__1)) + (r__2 = r_imag(&dy[i__] ), f2c_abs(r__2)); if (yk != 0.f) { /* Computing MAX */ r__1 = dz_z__; r__2 = dyk / yk; // , expr subst dz_z__ = max(r__1,r__2); } else if (dyk != 0.f) { dz_z__ = hugeval; } ymin = min(ymin,yk); normy = max(normy,yk); if (*colequ) { /* Computing MAX */ r__1 = normx; r__2 = yk * c__[i__]; // , expr subst normx = max(r__1,r__2); /* Computing MAX */ r__1 = normdx; r__2 = dyk * c__[i__]; // , expr subst normdx = max(r__1,r__2); } else { normx = normy; normdx = max(normdx,dyk); } } if (normx != 0.f) { dx_x__ = normdx / normx; } else if (normdx == 0.f) { dx_x__ = 0.f; } else { dx_x__ = hugeval; } dxrat = normdx / prevnormdx; dzrat = dz_z__ / prev_dz_z__; /* Check termination criteria. */ if (ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2) { incr_prec__ = TRUE_; } if (x_state__ == 3 && dxrat <= *rthresh) { x_state__ = 1; } if (x_state__ == 1) { if (dx_x__ <= eps) { x_state__ = 2; } else if (dxrat > *rthresh) { if (y_prec_state__ != 2) { incr_prec__ = TRUE_; } else { x_state__ = 3; } } else { if (dxrat > dxratmax) { dxratmax = dxrat; } } if (x_state__ > 1) { final_dx_x__ = dx_x__; } } if (z_state__ == 0 && dz_z__ <= *dz_ub__) { z_state__ = 1; } if (z_state__ == 3 && dzrat <= *rthresh) { z_state__ = 1; } if (z_state__ == 1) { if (dz_z__ <= eps) { z_state__ = 2; } else if (dz_z__ > *dz_ub__) { z_state__ = 0; dzratmax = 0.f; final_dz_z__ = hugeval; } else if (dzrat > *rthresh) { if (y_prec_state__ != 2) { incr_prec__ = TRUE_; } else { z_state__ = 3; } } else { if (dzrat > dzratmax) { dzratmax = dzrat; } } if (z_state__ > 1) { final_dz_z__ = dz_z__; } } if (x_state__ != 1 && (*ignore_cwise__ || z_state__ != 1)) { goto L666; } if (incr_prec__) { incr_prec__ = FALSE_; ++y_prec_state__; i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = i__; y_tail__[i__4].r = 0.f; y_tail__[i__4].i = 0.f; // , expr subst } } prevnormdx = normdx; prev_dz_z__ = dz_z__; /* Update soluton. */ if (y_prec_state__ < 2) { caxpy_(n, &c_b15, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1); } else { cla_wwaddw_(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]); } } /* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't CALL F90_EXIT. */ L666: /* Set final_* when cnt hits ithresh. */ if (x_state__ == 1) { final_dx_x__ = dx_x__; } if (z_state__ == 1) { final_dz_z__ = dz_z__; } /* Compute error bounds. */ if (*n_norms__ >= 1) { err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / ( 1 - dxratmax); } if (*n_norms__ >= 2) { err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / ( 1 - dzratmax); } /* Compute componentwise relative backward error from formula */ /* max(i) ( f2c_abs(R(i)) / ( f2c_abs(op(A_s))*f2c_abs(Y) + f2c_abs(B_s) )(i) ) */ /* where f2c_abs(Z) is the componentwise absolute value of the matrix */ /* or vector Z. */ /* Compute residual RES = B_s - op(A_s) * Y, */ /* op(A) = A, A**T, or A**H depending on TRANS (and type). */ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); csymv_(uplo, n, &c_b14, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1, &c_b15, &res[1], &c__1); i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * b_dim1; ayb[i__] = (r__1 = b[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(&b[i__ + j * b_dim1]), f2c_abs(r__2)); } /* Compute f2c_abs(op(A_s))*f2c_abs(Y) + f2c_abs(B_s). */ cla_syamv_(&uplo2, n, &c_b37, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1, &c_b37, &ayb[1], &c__1); cla_lin_berr_(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]); /* End of loop for each RHS. */ } return 0; }
/* Subroutine */ int csyrfs_(char *uplo, integer *n, integer *nrhs, complex * a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex * b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, integer *info) { /* System generated locals */ integer a_dim1, a_offset, af_dim1, af_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 */ integer i__, j, k; real s, xk; integer nz; real eps; integer kase; real safe1, safe2; extern logical lsame_(char *, char *); integer isave[3]; extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *); integer count; logical upper; extern /* Subroutine */ int csymv_(char *, integer *, complex *, complex * , integer *, complex *, integer *, complex *, complex *, integer * ), clacn2_(integer *, complex *, complex *, real *, integer *, integer *); extern doublereal slamch_(char *); real safmin; extern /* Subroutine */ int xerbla_(char *, integer *); real lstres; extern /* Subroutine */ int csytrs_(char *, integer *, integer *, complex *, integer *, integer *, complex *, integer *, integer *); /* -- 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 */ /* ======= */ /* CSYRFS improves the computed solution to a system of linear */ /* equations when the coefficient matrix is symmetric indefinite, 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. */ /* NRHS (input) INTEGER */ /* The number of right hand sides, i.e., the number of columns */ /* of the matrices B and X. NRHS >= 0. */ /* A (input) COMPLEX array, dimension (LDA,N) */ /* The symmetric 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). */ /* AF (input) COMPLEX array, dimension (LDAF,N) */ /* The factored form of the matrix A. AF contains the block */ /* diagonal matrix D and the multipliers used to obtain the */ /* factor U or L from the factorization A = U*D*U**T or */ /* A = L*D*L**T as computed by CSYTRF. */ /* LDAF (input) INTEGER */ /* The leading dimension of the array AF. LDAF >= max(1,N). */ /* IPIV (input) INTEGER array, dimension (N) */ /* Details of the interchanges and the block structure of D */ /* as determined by CSYTRF. */ /* 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 CSYTRS. */ /* 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. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External 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; af_dim1 = *ldaf; af_offset = 1 + af_dim1; af -= af_offset; --ipiv; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; x_dim1 = *ldx; x_offset = 1 + x_dim1; x -= x_offset; --ferr; --berr; --work; --rwork; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*nrhs < 0) { *info = -3; } else if (*lda < max(1,*n)) { *info = -5; } else if (*ldaf < max(1,*n)) { *info = -7; } else if (*ldb < max(1,*n)) { *info = -10; } else if (*ldx < max(1,*n)) { *info = -12; } if (*info != 0) { i__1 = -(*info); xerbla_("CSYRFS", &i__1); return 0; } /* Quick return if possible */ if (*n == 0 || *nrhs == 0) { i__1 = *nrhs; for (j = 1; j <= i__1; ++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 */ nz = *n + 1; 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 <= i__1; ++j) { count = 1; lstres = 3.f; L20: /* Loop until stopping criterion is satisfied. */ /* Compute residual R = B - A * X */ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1); q__1.r = -1.f, q__1.i = -0.f; csymv_(uplo, n, &q__1, &a[a_offset], lda, &x[j * x_dim1 + 1], &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 matrix */ /* or vector Z. If the i-th component of the denominator is less */ /* than SAFE2, then SAFE1 is added to the i-th components of the */ /* numerator and denominator before dividing. */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * b_dim1; rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[ i__ + j * b_dim1]), dabs(r__2)); /* L30: */ } /* Compute abs(A)*abs(X) + abs(B). */ if (upper) { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = 0.f; i__3 = k + j * x_dim1; xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j * x_dim1]), dabs(r__2)); i__3 = k - 1; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = i__ + k * a_dim1; rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&a[i__ + k * a_dim1]), dabs(r__2))) * xk; i__4 = i__ + k * a_dim1; i__5 = i__ + j * x_dim1; s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&a[ i__ + k * a_dim1]), dabs(r__2))) * ((r__3 = x[ i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]), dabs(r__4))); /* L40: */ } i__3 = k + k * a_dim1; rwork[k] = rwork[k] + ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[k + k * a_dim1]), dabs(r__2))) * xk + s; /* L50: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = 0.f; i__3 = k + j * x_dim1; xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j * x_dim1]), dabs(r__2)); i__3 = k + k * a_dim1; rwork[k] += ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(& a[k + k * a_dim1]), dabs(r__2))) * xk; i__3 = *n; for (i__ = k + 1; i__ <= i__3; ++i__) { i__4 = i__ + k * a_dim1; rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&a[i__ + k * a_dim1]), dabs(r__2))) * xk; i__4 = i__ + k * a_dim1; i__5 = i__ + j * x_dim1; s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&a[ i__ + k * a_dim1]), dabs(r__2))) * ((r__3 = x[ i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]), dabs(r__4))); /* L60: */ } rwork[k] += s; /* L70: */ } } s = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (rwork[i__] > safe2) { /* Computing MAX */ i__3 = i__; r__3 = s, r__4 = ((r__1 = work[i__3].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__3 = i__; r__3 = s, r__4 = ((r__1 = work[i__3].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, and */ /* 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. */ csytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[1], n, info); caxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &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 or */ /* 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 CLACN2 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__ <= i__2; ++i__) { if (rwork[i__] > safe2) { i__3 = i__; rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 = r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[ i__]; } else { i__3 = i__; rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 = r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[ i__] + safe1; } /* L90: */ } kase = 0; L100: clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave); if (kase != 0) { if (kase == 1) { /* Multiply by diag(W)*inv(A'). */ csytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ 1], n, info); i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__; i__4 = i__; i__5 = i__; q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4] * work[i__5].i; work[i__3].r = q__1.r, work[i__3].i = q__1.i; /* L110: */ } } else if (kase == 2) { /* Multiply by inv(A)*diag(W). */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__; i__4 = i__; i__5 = i__; q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4] * work[i__5].i; work[i__3].r = q__1.r, work[i__3].i = q__1.i; /* L120: */ } csytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ 1], n, info); } goto L100; } /* Normalize error. */ lstres = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ i__3 = i__ + j * x_dim1; r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[i__ + j * x_dim1]), dabs(r__2)); lstres = dmax(r__3,r__4); /* L130: */ } if (lstres != 0.f) { ferr[j] /= lstres; } /* L140: */ } return 0; /* End of CSYRFS */ } /* csyrfs_ */
/* Subroutine */ int clagsy_(integer *n, integer *k, real *d, complex *a, integer *lda, integer *iseed, complex *work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9; doublereal d__1; complex q__1, q__2, q__3, q__4; /* Builtin functions */ double c_abs(complex *); void c_div(complex *, complex *, complex *); /* Local variables */ static integer i, j; extern /* Subroutine */ int cgerc_(integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, integer *); static complex alpha; extern /* Subroutine */ int cscal_(integer *, complex *, complex *, integer *); extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer *, complex *, integer *); extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *), csymv_(char *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *); extern real scnrm2_(integer *, complex *, integer *); static integer ii, jj; static complex wa, wb; extern /* Subroutine */ int clacgv_(integer *, complex *, integer *); static real wn; extern /* Subroutine */ int xerbla_(char *, integer *), clarnv_( integer *, integer *, integer *, complex *); static complex tau; /* -- LAPACK auxiliary test 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 ======= CLAGSY generates a complex symmetric matrix A, by pre- and post- multiplying a real diagonal matrix D with a random unitary matrix: A = U*D*U**T. The semi-bandwidth may then be reduced to k by additional unitary transformations. Arguments ========= N (input) INTEGER The order of the matrix A. N >= 0. K (input) INTEGER The number of nonzero subdiagonals within the band of A. 0 <= K <= N-1. D (input) REAL array, dimension (N) The diagonal elements of the diagonal matrix D. A (output) COMPLEX array, dimension (LDA,N) The generated n by n symmetric matrix A (the full matrix is stored). LDA (input) INTEGER The leading dimension of the array A. LDA >= N. ISEED (input/output) INTEGER array, dimension (4) On entry, the seed of the random number generator; the array elements must be between 0 and 4095, and ISEED(4) must be odd. On exit, the seed is updated. WORK (workspace) COMPLEX array, dimension (2*N) INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value ===================================================================== Test the input arguments Parameter adjustments */ --d; a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --iseed; --work; /* Function Body */ *info = 0; if (*n < 0) { *info = -1; } else if (*k < 0 || *k > *n - 1) { *info = -2; } else if (*lda < max(1,*n)) { *info = -5; } if (*info < 0) { i__1 = -(*info); xerbla_("CLAGSY", &i__1); return 0; } /* initialize lower triangle of A to diagonal matrix */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i = j + 1; i <= i__2; ++i) { i__3 = i + j * a_dim1; a[i__3].r = 0.f, a[i__3].i = 0.f; /* L10: */ } /* L20: */ } i__1 = *n; for (i = 1; i <= i__1; ++i) { i__2 = i + i * a_dim1; i__3 = i; a[i__2].r = d[i__3], a[i__2].i = 0.f; /* L30: */ } /* Generate lower triangle of symmetric matrix */ for (i = *n - 1; i >= 1; --i) { /* generate random reflection */ i__1 = *n - i + 1; clarnv_(&c__3, &iseed[1], &i__1, &work[1]); i__1 = *n - i + 1; wn = scnrm2_(&i__1, &work[1], &c__1); d__1 = wn / c_abs(&work[1]); q__1.r = d__1 * work[1].r, q__1.i = d__1 * work[1].i; wa.r = q__1.r, wa.i = q__1.i; if (wn == 0.f) { tau.r = 0.f, tau.i = 0.f; } else { q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i; wb.r = q__1.r, wb.i = q__1.i; i__1 = *n - i; c_div(&q__1, &c_b2, &wb); cscal_(&i__1, &q__1, &work[2], &c__1); work[1].r = 1.f, work[1].i = 0.f; c_div(&q__1, &wb, &wa); d__1 = q__1.r; tau.r = d__1, tau.i = 0.f; } /* apply random reflection to A(i:n,i:n) from the left and the right compute y := tau * A * conjg(u) */ i__1 = *n - i + 1; clacgv_(&i__1, &work[1], &c__1); i__1 = *n - i + 1; csymv_("Lower", &i__1, &tau, &a[i + i * a_dim1], lda, &work[1], &c__1, &c_b1, &work[*n + 1], &c__1); i__1 = *n - i + 1; clacgv_(&i__1, &work[1], &c__1); /* compute v := y - 1/2 * tau * ( u, y ) * u */ q__3.r = -.5f, q__3.i = 0.f; q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i + q__3.i * tau.r; i__1 = *n - i + 1; cdotc_(&q__4, &i__1, &work[1], &c__1, &work[*n + 1], &c__1); q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i + q__2.i * q__4.r; alpha.r = q__1.r, alpha.i = q__1.i; i__1 = *n - i + 1; caxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1); /* apply the transformation as a rank-2 update to A(i:n,i:n) CALL CSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1, $ A( I, I ), LDA ) */ i__1 = *n; for (jj = i; jj <= i__1; ++jj) { i__2 = *n; for (ii = jj; ii <= i__2; ++ii) { i__3 = ii + jj * a_dim1; i__4 = ii + jj * a_dim1; i__5 = ii - i + 1; i__6 = *n + jj - i + 1; q__3.r = work[i__5].r * work[i__6].r - work[i__5].i * work[ i__6].i, q__3.i = work[i__5].r * work[i__6].i + work[ i__5].i * work[i__6].r; q__2.r = a[i__4].r - q__3.r, q__2.i = a[i__4].i - q__3.i; i__7 = *n + ii - i + 1; i__8 = jj - i + 1; q__4.r = work[i__7].r * work[i__8].r - work[i__7].i * work[ i__8].i, q__4.i = work[i__7].r * work[i__8].i + work[ i__7].i * work[i__8].r; q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i; a[i__3].r = q__1.r, a[i__3].i = q__1.i; /* L40: */ } /* L50: */ } /* L60: */ } /* Reduce number of subdiagonals to K */ i__1 = *n - 1 - *k; for (i = 1; i <= i__1; ++i) { /* generate reflection to annihilate A(k+i+1:n,i) */ i__2 = *n - *k - i + 1; wn = scnrm2_(&i__2, &a[*k + i + i * a_dim1], &c__1); d__1 = wn / c_abs(&a[*k + i + i * a_dim1]); i__2 = *k + i + i * a_dim1; q__1.r = d__1 * a[i__2].r, q__1.i = d__1 * a[i__2].i; wa.r = q__1.r, wa.i = q__1.i; if (wn == 0.f) { tau.r = 0.f, tau.i = 0.f; } else { i__2 = *k + i + i * a_dim1; q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i; wb.r = q__1.r, wb.i = q__1.i; i__2 = *n - *k - i; c_div(&q__1, &c_b2, &wb); cscal_(&i__2, &q__1, &a[*k + i + 1 + i * a_dim1], &c__1); i__2 = *k + i + i * a_dim1; a[i__2].r = 1.f, a[i__2].i = 0.f; c_div(&q__1, &wb, &wa); d__1 = q__1.r; tau.r = d__1, tau.i = 0.f; } /* apply reflection to A(k+i:n,i+1:k+i-1) from the left */ i__2 = *n - *k - i + 1; i__3 = *k - 1; cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i + (i + 1) * a_dim1], lda, &a[*k + i + i * a_dim1], &c__1, &c_b1, &work[ 1], &c__1); i__2 = *n - *k - i + 1; i__3 = *k - 1; q__1.r = -(doublereal)tau.r, q__1.i = -(doublereal)tau.i; cgerc_(&i__2, &i__3, &q__1, &a[*k + i + i * a_dim1], &c__1, &work[1], &c__1, &a[*k + i + (i + 1) * a_dim1], lda); /* apply reflection to A(k+i:n,k+i:n) from the left and the rig ht compute y := tau * A * conjg(u) */ i__2 = *n - *k - i + 1; clacgv_(&i__2, &a[*k + i + i * a_dim1], &c__1); i__2 = *n - *k - i + 1; csymv_("Lower", &i__2, &tau, &a[*k + i + (*k + i) * a_dim1], lda, &a[* k + i + i * a_dim1], &c__1, &c_b1, &work[1], &c__1); i__2 = *n - *k - i + 1; clacgv_(&i__2, &a[*k + i + i * a_dim1], &c__1); /* compute v := y - 1/2 * tau * ( u, y ) * u */ q__3.r = -.5f, q__3.i = 0.f; q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i + q__3.i * tau.r; i__2 = *n - *k - i + 1; cdotc_(&q__4, &i__2, &a[*k + i + i * a_dim1], &c__1, &work[1], &c__1); q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i + q__2.i * q__4.r; alpha.r = q__1.r, alpha.i = q__1.i; i__2 = *n - *k - i + 1; caxpy_(&i__2, &alpha, &a[*k + i + i * a_dim1], &c__1, &work[1], &c__1) ; /* apply symmetric rank-2 update to A(k+i:n,k+i:n) CALL CSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1, $ A( K+I, K+I ), LDA ) */ i__2 = *n; for (jj = *k + i; jj <= i__2; ++jj) { i__3 = *n; for (ii = jj; ii <= i__3; ++ii) { i__4 = ii + jj * a_dim1; i__5 = ii + jj * a_dim1; i__6 = ii + i * a_dim1; i__7 = jj - *k - i + 1; q__3.r = a[i__6].r * work[i__7].r - a[i__6].i * work[i__7].i, q__3.i = a[i__6].r * work[i__7].i + a[i__6].i * work[ i__7].r; q__2.r = a[i__5].r - q__3.r, q__2.i = a[i__5].i - q__3.i; i__8 = ii - *k - i + 1; i__9 = jj + i * a_dim1; q__4.r = work[i__8].r * a[i__9].r - work[i__8].i * a[i__9].i, q__4.i = work[i__8].r * a[i__9].i + work[i__8].i * a[ i__9].r; q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i; a[i__4].r = q__1.r, a[i__4].i = q__1.i; /* L70: */ } /* L80: */ } i__2 = *k + i + i * a_dim1; q__1.r = -(doublereal)wa.r, q__1.i = -(doublereal)wa.i; a[i__2].r = q__1.r, a[i__2].i = q__1.i; i__2 = *n; for (j = *k + i + 1; j <= i__2; ++j) { i__3 = j + i * a_dim1; a[i__3].r = 0.f, a[i__3].i = 0.f; /* L90: */ } /* L100: */ } /* Store full symmetric matrix */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i = j + 1; i <= i__2; ++i) { i__3 = j + i * a_dim1; i__4 = i + j * a_dim1; a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; /* L110: */ } /* L120: */ } return 0; /* End of CLAGSY */ } /* clagsy_ */
/* Subroutine */ int clagsy_(integer *n, integer *k, real *d__, complex *a, integer *lda, integer *iseed, complex *work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9; real r__1; complex q__1, q__2, q__3, q__4; /* Local variables */ integer i__, j, ii, jj; complex wa, wb; real wn; complex tau; complex alpha; /* -- LAPACK auxiliary test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CLAGSY generates a complex symmetric matrix A, by pre- and post- */ /* multiplying a real diagonal matrix D with a random unitary matrix: */ /* A = U*D*U**T. The semi-bandwidth may then be reduced to k by */ /* additional unitary transformations. */ /* Arguments */ /* ========= */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* K (input) INTEGER */ /* The number of nonzero subdiagonals within the band of A. */ /* 0 <= K <= N-1. */ /* D (input) REAL array, dimension (N) */ /* The diagonal elements of the diagonal matrix D. */ /* A (output) COMPLEX array, dimension (LDA,N) */ /* The generated n by n symmetric matrix A (the full matrix is */ /* stored). */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= N. */ /* ISEED (input/output) INTEGER array, dimension (4) */ /* On entry, the seed of the random number generator; the array */ /* elements must be between 0 and 4095, and ISEED(4) must be */ /* odd. */ /* On exit, the seed is updated. */ /* WORK (workspace) COMPLEX 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 .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ --d__; a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --iseed; --work; /* Function Body */ *info = 0; if (*n < 0) { *info = -1; } else if (*k < 0 || *k > *n - 1) { *info = -2; } else if (*lda < max(1,*n)) { *info = -5; } if (*info < 0) { i__1 = -(*info); xerbla_("CLAGSY", &i__1); return 0; } /* initialize lower triangle of A to diagonal matrix */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { i__3 = i__ + j * a_dim1; a[i__3].r = 0.f, a[i__3].i = 0.f; /* L10: */ } /* L20: */ } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__ + i__ * a_dim1; i__3 = i__; a[i__2].r = d__[i__3], a[i__2].i = 0.f; /* L30: */ } /* Generate lower triangle of symmetric matrix */ for (i__ = *n - 1; i__ >= 1; --i__) { /* generate random reflection */ i__1 = *n - i__ + 1; clarnv_(&c__3, &iseed[1], &i__1, &work[1]); i__1 = *n - i__ + 1; wn = scnrm2_(&i__1, &work[1], &c__1); r__1 = wn / c_abs(&work[1]); q__1.r = r__1 * work[1].r, q__1.i = r__1 * work[1].i; wa.r = q__1.r, wa.i = q__1.i; if (wn == 0.f) { tau.r = 0.f, tau.i = 0.f; } else { q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i; wb.r = q__1.r, wb.i = q__1.i; i__1 = *n - i__; c_div(&q__1, &c_b2, &wb); cscal_(&i__1, &q__1, &work[2], &c__1); work[1].r = 1.f, work[1].i = 0.f; c_div(&q__1, &wb, &wa); r__1 = q__1.r; tau.r = r__1, tau.i = 0.f; } /* apply random reflection to A(i:n,i:n) from the left */ /* and the right */ /* compute y := tau * A * conjg(u) */ i__1 = *n - i__ + 1; clacgv_(&i__1, &work[1], &c__1); i__1 = *n - i__ + 1; csymv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], & c__1, &c_b1, &work[*n + 1], &c__1); i__1 = *n - i__ + 1; clacgv_(&i__1, &work[1], &c__1); /* compute v := y - 1/2 * tau * ( u, y ) * u */ q__3.r = -.5f, q__3.i = -0.f; q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i + q__3.i * tau.r; i__1 = *n - i__ + 1; cdotc_(&q__4, &i__1, &work[1], &c__1, &work[*n + 1], &c__1); q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i + q__2.i * q__4.r; alpha.r = q__1.r, alpha.i = q__1.i; i__1 = *n - i__ + 1; caxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1); /* apply the transformation as a rank-2 update to A(i:n,i:n) */ /* CALL CSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1, */ /* $ A( I, I ), LDA ) */ i__1 = *n; for (jj = i__; jj <= i__1; ++jj) { i__2 = *n; for (ii = jj; ii <= i__2; ++ii) { i__3 = ii + jj * a_dim1; i__4 = ii + jj * a_dim1; i__5 = ii - i__ + 1; i__6 = *n + jj - i__ + 1; q__3.r = work[i__5].r * work[i__6].r - work[i__5].i * work[ i__6].i, q__3.i = work[i__5].r * work[i__6].i + work[ i__5].i * work[i__6].r; q__2.r = a[i__4].r - q__3.r, q__2.i = a[i__4].i - q__3.i; i__7 = *n + ii - i__ + 1; i__8 = jj - i__ + 1; q__4.r = work[i__7].r * work[i__8].r - work[i__7].i * work[ i__8].i, q__4.i = work[i__7].r * work[i__8].i + work[ i__7].i * work[i__8].r; q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i; a[i__3].r = q__1.r, a[i__3].i = q__1.i; /* L40: */ } /* L50: */ } /* L60: */ } /* Reduce number of subdiagonals to K */ i__1 = *n - 1 - *k; for (i__ = 1; i__ <= i__1; ++i__) { /* generate reflection to annihilate A(k+i+1:n,i) */ i__2 = *n - *k - i__ + 1; wn = scnrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1); r__1 = wn / c_abs(&a[*k + i__ + i__ * a_dim1]); i__2 = *k + i__ + i__ * a_dim1; q__1.r = r__1 * a[i__2].r, q__1.i = r__1 * a[i__2].i; wa.r = q__1.r, wa.i = q__1.i; if (wn == 0.f) { tau.r = 0.f, tau.i = 0.f; } else { i__2 = *k + i__ + i__ * a_dim1; q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i; wb.r = q__1.r, wb.i = q__1.i; i__2 = *n - *k - i__; c_div(&q__1, &c_b2, &wb); cscal_(&i__2, &q__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1); i__2 = *k + i__ + i__ * a_dim1; a[i__2].r = 1.f, a[i__2].i = 0.f; c_div(&q__1, &wb, &wa); r__1 = q__1.r; tau.r = r__1, tau.i = 0.f; } /* apply reflection to A(k+i:n,i+1:k+i-1) from the left */ i__2 = *n - *k - i__ + 1; i__3 = *k - 1; cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + (i__ + 1) * a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, & c_b1, &work[1], &c__1); i__2 = *n - *k - i__ + 1; i__3 = *k - 1; q__1.r = -tau.r, q__1.i = -tau.i; cgerc_(&i__2, &i__3, &q__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[ 1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda); /* apply reflection to A(k+i:n,k+i:n) from the left and the right */ /* compute y := tau * A * conjg(u) */ i__2 = *n - *k - i__ + 1; clacgv_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1); i__2 = *n - *k - i__ + 1; csymv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &work[1], &c__1); i__2 = *n - *k - i__ + 1; clacgv_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1); /* compute v := y - 1/2 * tau * ( u, y ) * u */ q__3.r = -.5f, q__3.i = -0.f; q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i + q__3.i * tau.r; i__2 = *n - *k - i__ + 1; cdotc_(&q__4, &i__2, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], & c__1); q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i + q__2.i * q__4.r; alpha.r = q__1.r, alpha.i = q__1.i; i__2 = *n - *k - i__ + 1; caxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], & c__1); /* apply symmetric rank-2 update to A(k+i:n,k+i:n) */ /* CALL CSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1, */ /* $ A( K+I, K+I ), LDA ) */ i__2 = *n; for (jj = *k + i__; jj <= i__2; ++jj) { i__3 = *n; for (ii = jj; ii <= i__3; ++ii) { i__4 = ii + jj * a_dim1; i__5 = ii + jj * a_dim1; i__6 = ii + i__ * a_dim1; i__7 = jj - *k - i__ + 1; q__3.r = a[i__6].r * work[i__7].r - a[i__6].i * work[i__7].i, q__3.i = a[i__6].r * work[i__7].i + a[i__6].i * work[ i__7].r; q__2.r = a[i__5].r - q__3.r, q__2.i = a[i__5].i - q__3.i; i__8 = ii - *k - i__ + 1; i__9 = jj + i__ * a_dim1; q__4.r = work[i__8].r * a[i__9].r - work[i__8].i * a[i__9].i, q__4.i = work[i__8].r * a[i__9].i + work[i__8].i * a[ i__9].r; q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i; a[i__4].r = q__1.r, a[i__4].i = q__1.i; /* L70: */ } /* L80: */ } i__2 = *k + i__ + i__ * a_dim1; q__1.r = -wa.r, q__1.i = -wa.i; a[i__2].r = q__1.r, a[i__2].i = q__1.i; i__2 = *n; for (j = *k + i__ + 1; j <= i__2; ++j) { i__3 = j + i__ * a_dim1; a[i__3].r = 0.f, a[i__3].i = 0.f; /* L90: */ } /* L100: */ } /* Store full symmetric matrix */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { i__3 = j + i__ * a_dim1; i__4 = i__ + j * a_dim1; a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; /* L110: */ } /* L120: */ } return 0; /* End of CLAGSY */ } /* clagsy_ */
/* Subroutine */ int csytri_(char *uplo, integer *n, complex *a, integer *lda, integer *ipiv, complex *work, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= CSYTRI computes the inverse of a complex symmetric indefinite matrix A using the factorization A = U*D*U**T or A = L*D*L**T computed by CSYTRF. Arguments ========= UPLO (input) CHARACTER*1 Specifies whether the details of the factorization are stored as an upper or lower triangular matrix. = 'U': Upper triangular, form is A = U*D*U**T; = 'L': Lower triangular, form is A = L*D*L**T. N (input) INTEGER The order of the matrix A. N >= 0. A (input/output) COMPLEX array, dimension (LDA,N) On entry, the block diagonal matrix D and the multipliers used to obtain the factor U or L as computed by CSYTRF. On exit, if INFO = 0, the (symmetric) inverse of the original matrix. If UPLO = 'U', the upper triangular part of the inverse is formed and the part of A below the diagonal is not referenced; if UPLO = 'L' the lower triangular part of the inverse is formed and the part of A above the diagonal is not referenced. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,N). IPIV (input) INTEGER array, dimension (N) Details of the interchanges and the block structure of D as determined by CSYTRF. WORK (workspace) COMPLEX array, dimension (2*N) INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its inverse could not be computed. ===================================================================== Test the input parameters. Parameter adjustments */ /* Table of constant values */ static complex c_b1 = {1.f,0.f}; static complex c_b2 = {0.f,0.f}; static integer c__1 = 1; /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; complex q__1, q__2, q__3; /* Builtin functions */ void c_div(complex *, complex *, complex *); /* Local variables */ static complex temp, akkp1, d__; static integer k; static complex t; extern logical lsame_(char *, char *); extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *); extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer *, complex *, integer *); extern /* Subroutine */ int cswap_(integer *, complex *, integer *, complex *, integer *); static integer kstep; static logical upper; extern /* Subroutine */ int csymv_(char *, integer *, complex *, complex * , integer *, complex *, integer *, complex *, complex *, integer * ); static complex ak; static integer kp; extern /* Subroutine */ int xerbla_(char *, integer *); static complex akp1; #define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1 #define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; --ipiv; --work; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*n)) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("CSYTRI", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Check that the diagonal matrix D is nonsingular. */ if (upper) { /* Upper triangular storage: examine D from bottom to top */ for (*info = *n; *info >= 1; --(*info)) { i__1 = a_subscr(*info, *info); if (ipiv[*info] > 0 && (a[i__1].r == 0.f && a[i__1].i == 0.f)) { return 0; } /* L10: */ } } else { /* Lower triangular storage: examine D from top to bottom. */ i__1 = *n; for (*info = 1; *info <= i__1; ++(*info)) { i__2 = a_subscr(*info, *info); if (ipiv[*info] > 0 && (a[i__2].r == 0.f && a[i__2].i == 0.f)) { return 0; } /* L20: */ } } *info = 0; if (upper) { /* Compute inv(A) from the factorization A = U*D*U'. K is the main loop index, increasing from 1 to N in steps of 1 or 2, depending on the size of the diagonal blocks. */ k = 1; L30: /* If K > N, exit from loop. */ if (k > *n) { goto L40; } if (ipiv[k] > 0) { /* 1 x 1 diagonal block Invert the diagonal block. */ i__1 = a_subscr(k, k); c_div(&q__1, &c_b1, &a_ref(k, k)); a[i__1].r = q__1.r, a[i__1].i = q__1.i; /* Compute column K of the inverse. */ if (k > 1) { i__1 = k - 1; ccopy_(&i__1, &a_ref(1, k), &c__1, &work[1], &c__1); i__1 = k - 1; q__1.r = -1.f, q__1.i = 0.f; csymv_(uplo, &i__1, &q__1, &a[a_offset], lda, &work[1], &c__1, &c_b2, &a_ref(1, k), &c__1); i__1 = a_subscr(k, k); i__2 = a_subscr(k, k); i__3 = k - 1; cdotu_(&q__2, &i__3, &work[1], &c__1, &a_ref(1, k), &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; } kstep = 1; } else { /* 2 x 2 diagonal block Invert the diagonal block. */ i__1 = a_subscr(k, k + 1); t.r = a[i__1].r, t.i = a[i__1].i; c_div(&q__1, &a_ref(k, k), &t); ak.r = q__1.r, ak.i = q__1.i; c_div(&q__1, &a_ref(k + 1, k + 1), &t); akp1.r = q__1.r, akp1.i = q__1.i; c_div(&q__1, &a_ref(k, k + 1), &t); akkp1.r = q__1.r, akkp1.i = q__1.i; q__3.r = ak.r * akp1.r - ak.i * akp1.i, q__3.i = ak.r * akp1.i + ak.i * akp1.r; q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i * q__2.r; d__.r = q__1.r, d__.i = q__1.i; i__1 = a_subscr(k, k); c_div(&q__1, &akp1, &d__); a[i__1].r = q__1.r, a[i__1].i = q__1.i; i__1 = a_subscr(k + 1, k + 1); c_div(&q__1, &ak, &d__); a[i__1].r = q__1.r, a[i__1].i = q__1.i; i__1 = a_subscr(k, k + 1); q__2.r = -akkp1.r, q__2.i = -akkp1.i; c_div(&q__1, &q__2, &d__); a[i__1].r = q__1.r, a[i__1].i = q__1.i; /* Compute columns K and K+1 of the inverse. */ if (k > 1) { i__1 = k - 1; ccopy_(&i__1, &a_ref(1, k), &c__1, &work[1], &c__1); i__1 = k - 1; q__1.r = -1.f, q__1.i = 0.f; csymv_(uplo, &i__1, &q__1, &a[a_offset], lda, &work[1], &c__1, &c_b2, &a_ref(1, k), &c__1); i__1 = a_subscr(k, k); i__2 = a_subscr(k, k); i__3 = k - 1; cdotu_(&q__2, &i__3, &work[1], &c__1, &a_ref(1, k), &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; i__1 = a_subscr(k, k + 1); i__2 = a_subscr(k, k + 1); i__3 = k - 1; cdotu_(&q__2, &i__3, &a_ref(1, k), &c__1, &a_ref(1, k + 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; i__1 = k - 1; ccopy_(&i__1, &a_ref(1, k + 1), &c__1, &work[1], &c__1); i__1 = k - 1; q__1.r = -1.f, q__1.i = 0.f; csymv_(uplo, &i__1, &q__1, &a[a_offset], lda, &work[1], &c__1, &c_b2, &a_ref(1, k + 1), &c__1); i__1 = a_subscr(k + 1, k + 1); i__2 = a_subscr(k + 1, k + 1); i__3 = k - 1; cdotu_(&q__2, &i__3, &work[1], &c__1, &a_ref(1, k + 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; } kstep = 2; } kp = (i__1 = ipiv[k], abs(i__1)); if (kp != k) { /* Interchange rows and columns K and KP in the leading submatrix A(1:k+1,1:k+1) */ i__1 = kp - 1; cswap_(&i__1, &a_ref(1, k), &c__1, &a_ref(1, kp), &c__1); i__1 = k - kp - 1; cswap_(&i__1, &a_ref(kp + 1, k), &c__1, &a_ref(kp, kp + 1), lda); i__1 = a_subscr(k, k); temp.r = a[i__1].r, temp.i = a[i__1].i; i__1 = a_subscr(k, k); i__2 = a_subscr(kp, kp); a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; i__1 = a_subscr(kp, kp); a[i__1].r = temp.r, a[i__1].i = temp.i; if (kstep == 2) { i__1 = a_subscr(k, k + 1); temp.r = a[i__1].r, temp.i = a[i__1].i; i__1 = a_subscr(k, k + 1); i__2 = a_subscr(kp, k + 1); a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; i__1 = a_subscr(kp, k + 1); a[i__1].r = temp.r, a[i__1].i = temp.i; } } k += kstep; goto L30; L40: ; } else { /* Compute inv(A) from the factorization A = L*D*L'. K is the main loop index, increasing from 1 to N in steps of 1 or 2, depending on the size of the diagonal blocks. */ k = *n; L50: /* If K < 1, exit from loop. */ if (k < 1) { goto L60; } if (ipiv[k] > 0) { /* 1 x 1 diagonal block Invert the diagonal block. */ i__1 = a_subscr(k, k); c_div(&q__1, &c_b1, &a_ref(k, k)); a[i__1].r = q__1.r, a[i__1].i = q__1.i; /* Compute column K of the inverse. */ if (k < *n) { i__1 = *n - k; ccopy_(&i__1, &a_ref(k + 1, k), &c__1, &work[1], &c__1); i__1 = *n - k; q__1.r = -1.f, q__1.i = 0.f; csymv_(uplo, &i__1, &q__1, &a_ref(k + 1, k + 1), lda, &work[1] , &c__1, &c_b2, &a_ref(k + 1, k), &c__1); i__1 = a_subscr(k, k); i__2 = a_subscr(k, k); i__3 = *n - k; cdotu_(&q__2, &i__3, &work[1], &c__1, &a_ref(k + 1, k), &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; } kstep = 1; } else { /* 2 x 2 diagonal block Invert the diagonal block. */ i__1 = a_subscr(k, k - 1); t.r = a[i__1].r, t.i = a[i__1].i; c_div(&q__1, &a_ref(k - 1, k - 1), &t); ak.r = q__1.r, ak.i = q__1.i; c_div(&q__1, &a_ref(k, k), &t); akp1.r = q__1.r, akp1.i = q__1.i; c_div(&q__1, &a_ref(k, k - 1), &t); akkp1.r = q__1.r, akkp1.i = q__1.i; q__3.r = ak.r * akp1.r - ak.i * akp1.i, q__3.i = ak.r * akp1.i + ak.i * akp1.r; q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f; q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i * q__2.r; d__.r = q__1.r, d__.i = q__1.i; i__1 = a_subscr(k - 1, k - 1); c_div(&q__1, &akp1, &d__); a[i__1].r = q__1.r, a[i__1].i = q__1.i; i__1 = a_subscr(k, k); c_div(&q__1, &ak, &d__); a[i__1].r = q__1.r, a[i__1].i = q__1.i; i__1 = a_subscr(k, k - 1); q__2.r = -akkp1.r, q__2.i = -akkp1.i; c_div(&q__1, &q__2, &d__); a[i__1].r = q__1.r, a[i__1].i = q__1.i; /* Compute columns K-1 and K of the inverse. */ if (k < *n) { i__1 = *n - k; ccopy_(&i__1, &a_ref(k + 1, k), &c__1, &work[1], &c__1); i__1 = *n - k; q__1.r = -1.f, q__1.i = 0.f; csymv_(uplo, &i__1, &q__1, &a_ref(k + 1, k + 1), lda, &work[1] , &c__1, &c_b2, &a_ref(k + 1, k), &c__1); i__1 = a_subscr(k, k); i__2 = a_subscr(k, k); i__3 = *n - k; cdotu_(&q__2, &i__3, &work[1], &c__1, &a_ref(k + 1, k), &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; i__1 = a_subscr(k, k - 1); i__2 = a_subscr(k, k - 1); i__3 = *n - k; cdotu_(&q__2, &i__3, &a_ref(k + 1, k), &c__1, &a_ref(k + 1, k - 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; i__1 = *n - k; ccopy_(&i__1, &a_ref(k + 1, k - 1), &c__1, &work[1], &c__1); i__1 = *n - k; q__1.r = -1.f, q__1.i = 0.f; csymv_(uplo, &i__1, &q__1, &a_ref(k + 1, k + 1), lda, &work[1] , &c__1, &c_b2, &a_ref(k + 1, k - 1), &c__1); i__1 = a_subscr(k - 1, k - 1); i__2 = a_subscr(k - 1, k - 1); i__3 = *n - k; cdotu_(&q__2, &i__3, &work[1], &c__1, &a_ref(k + 1, k - 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; } kstep = 2; } kp = (i__1 = ipiv[k], abs(i__1)); if (kp != k) { /* Interchange rows and columns K and KP in the trailing submatrix A(k-1:n,k-1:n) */ if (kp < *n) { i__1 = *n - kp; cswap_(&i__1, &a_ref(kp + 1, k), &c__1, &a_ref(kp + 1, kp), & c__1); } i__1 = kp - k - 1; cswap_(&i__1, &a_ref(k + 1, k), &c__1, &a_ref(kp, k + 1), lda); i__1 = a_subscr(k, k); temp.r = a[i__1].r, temp.i = a[i__1].i; i__1 = a_subscr(k, k); i__2 = a_subscr(kp, kp); a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; i__1 = a_subscr(kp, kp); a[i__1].r = temp.r, a[i__1].i = temp.i; if (kstep == 2) { i__1 = a_subscr(k, k - 1); temp.r = a[i__1].r, temp.i = a[i__1].i; i__1 = a_subscr(k, k - 1); i__2 = a_subscr(kp, k - 1); a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; i__1 = a_subscr(kp, k - 1); a[i__1].r = temp.r, a[i__1].i = temp.i; } } k -= kstep; goto L50; L60: ; } return 0; /* End of CSYTRI */ } /* csytri_ */
/* Subroutine */ int csytri_rook_(char *uplo, integer *n, complex *a, integer *lda, integer *ipiv, complex *work, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; complex q__1, q__2, q__3; /* Builtin functions */ void c_div(complex *, complex *, complex *); /* Local variables */ complex d__; integer k; complex t, ak; integer kp; complex akp1, temp, akkp1; extern logical lsame_(char *, char *); extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *); extern /* Complex */ VOID cdotu_f2c_(complex *, integer *, complex *, integer *, complex *, integer *); extern /* Subroutine */ int cswap_(integer *, complex *, integer *, complex *, integer *); integer kstep; logical upper; extern /* Subroutine */ int csymv_(char *, integer *, complex *, complex * , integer *, complex *, integer *, complex *, complex *, integer * ), xerbla_(char *, integer *); /* -- LAPACK computational routine (version 3.4.0) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* November 2011 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ===================================================================== */ /* .. 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; --ipiv; --work; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*lda < max(1,*n)) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("CSYTRI_ROOK", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Check that the diagonal matrix D is nonsingular. */ if (upper) { /* Upper triangular storage: examine D from bottom to top */ for (*info = *n; *info >= 1; --(*info)) { i__1 = *info + *info * a_dim1; if (ipiv[*info] > 0 && (a[i__1].r == 0.f && a[i__1].i == 0.f)) { return 0; } /* L10: */ } } else { /* Lower triangular storage: examine D from top to bottom. */ i__1 = *n; for (*info = 1; *info <= i__1; ++(*info)) { i__2 = *info + *info * a_dim1; if (ipiv[*info] > 0 && (a[i__2].r == 0.f && a[i__2].i == 0.f)) { return 0; } /* L20: */ } } *info = 0; if (upper) { /* Compute inv(A) from the factorization A = U*D*U**T. */ /* K is the main loop index, increasing from 1 to N in steps of */ /* 1 or 2, depending on the size of the diagonal blocks. */ k = 1; L30: /* If K > N, exit from loop. */ if (k > *n) { goto L40; } if (ipiv[k] > 0) { /* 1 x 1 diagonal block */ /* Invert the diagonal block. */ i__1 = k + k * a_dim1; c_div(&q__1, &c_b1, &a[k + k * a_dim1]); a[i__1].r = q__1.r; a[i__1].i = q__1.i; // , expr subst /* Compute column K of the inverse. */ if (k > 1) { i__1 = k - 1; ccopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1); i__1 = k - 1; q__1.r = -1.f; q__1.i = -0.f; // , expr subst csymv_(uplo, &i__1, &q__1, &a[a_offset], lda, &work[1], &c__1, &c_b2, &a[k * a_dim1 + 1], &c__1); i__1 = k + k * a_dim1; i__2 = k + k * a_dim1; i__3 = k - 1; cdotu_f2c_(&q__2, &i__3, &work[1], &c__1, &a[k * 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; // , expr subst a[i__1].r = q__1.r; a[i__1].i = q__1.i; // , expr subst } kstep = 1; } else { /* 2 x 2 diagonal block */ /* Invert the diagonal block. */ i__1 = k + (k + 1) * a_dim1; t.r = a[i__1].r; t.i = a[i__1].i; // , expr subst c_div(&q__1, &a[k + k * a_dim1], &t); ak.r = q__1.r; ak.i = q__1.i; // , expr subst c_div(&q__1, &a[k + 1 + (k + 1) * a_dim1], &t); akp1.r = q__1.r; akp1.i = q__1.i; // , expr subst c_div(&q__1, &a[k + (k + 1) * a_dim1], &t); akkp1.r = q__1.r; akkp1.i = q__1.i; // , expr subst q__3.r = ak.r * akp1.r - ak.i * akp1.i; q__3.i = ak.r * akp1.i + ak.i * akp1.r; // , expr subst q__2.r = q__3.r - 1.f; q__2.i = q__3.i - 0.f; // , expr subst q__1.r = t.r * q__2.r - t.i * q__2.i; q__1.i = t.r * q__2.i + t.i * q__2.r; // , expr subst d__.r = q__1.r; d__.i = q__1.i; // , expr subst i__1 = k + k * a_dim1; c_div(&q__1, &akp1, &d__); a[i__1].r = q__1.r; a[i__1].i = q__1.i; // , expr subst i__1 = k + 1 + (k + 1) * a_dim1; c_div(&q__1, &ak, &d__); a[i__1].r = q__1.r; a[i__1].i = q__1.i; // , expr subst i__1 = k + (k + 1) * a_dim1; q__2.r = -akkp1.r; q__2.i = -akkp1.i; // , expr subst c_div(&q__1, &q__2, &d__); a[i__1].r = q__1.r; a[i__1].i = q__1.i; // , expr subst /* Compute columns K and K+1 of the inverse. */ if (k > 1) { i__1 = k - 1; ccopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1); i__1 = k - 1; q__1.r = -1.f; q__1.i = -0.f; // , expr subst csymv_(uplo, &i__1, &q__1, &a[a_offset], lda, &work[1], &c__1, &c_b2, &a[k * a_dim1 + 1], &c__1); i__1 = k + k * a_dim1; i__2 = k + k * a_dim1; i__3 = k - 1; cdotu_f2c_(&q__2, &i__3, &work[1], &c__1, &a[k * 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; // , expr subst a[i__1].r = q__1.r; a[i__1].i = q__1.i; // , expr subst i__1 = k + (k + 1) * a_dim1; i__2 = k + (k + 1) * a_dim1; i__3 = k - 1; cdotu_f2c_(&q__2, &i__3, &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; // , expr subst a[i__1].r = q__1.r; a[i__1].i = q__1.i; // , expr subst i__1 = k - 1; ccopy_(&i__1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], & c__1); i__1 = k - 1; q__1.r = -1.f; q__1.i = -0.f; // , expr subst csymv_(uplo, &i__1, &q__1, &a[a_offset], lda, &work[1], &c__1, &c_b2, &a[(k + 1) * a_dim1 + 1], &c__1); i__1 = k + 1 + (k + 1) * a_dim1; i__2 = k + 1 + (k + 1) * a_dim1; i__3 = k - 1; cdotu_f2c_(&q__2, &i__3, &work[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; // , expr subst a[i__1].r = q__1.r; a[i__1].i = q__1.i; // , expr subst } kstep = 2; } if (kstep == 1) { /* Interchange rows and columns K and IPIV(K) in the leading */ /* submatrix A(1:k+1,1:k+1) */ kp = ipiv[k]; if (kp != k) { if (kp > 1) { i__1 = kp - 1; cswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &c__1); } i__1 = k - kp - 1; cswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1) * a_dim1], lda); i__1 = k + k * a_dim1; temp.r = a[i__1].r; temp.i = a[i__1].i; // , expr subst i__1 = k + k * a_dim1; i__2 = kp + kp * a_dim1; a[i__1].r = a[i__2].r; a[i__1].i = a[i__2].i; // , expr subst i__1 = kp + kp * a_dim1; a[i__1].r = temp.r; a[i__1].i = temp.i; // , expr subst } } else { /* Interchange rows and columns K and K+1 with -IPIV(K) and */ /* -IPIV(K+1)in the leading submatrix A(1:k+1,1:k+1) */ kp = -ipiv[k]; if (kp != k) { if (kp > 1) { i__1 = kp - 1; cswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &c__1); } i__1 = k - kp - 1; cswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1) * a_dim1], lda); i__1 = k + k * a_dim1; temp.r = a[i__1].r; temp.i = a[i__1].i; // , expr subst i__1 = k + k * a_dim1; i__2 = kp + kp * a_dim1; a[i__1].r = a[i__2].r; a[i__1].i = a[i__2].i; // , expr subst i__1 = kp + kp * a_dim1; a[i__1].r = temp.r; a[i__1].i = temp.i; // , expr subst i__1 = k + (k + 1) * a_dim1; temp.r = a[i__1].r; temp.i = a[i__1].i; // , expr subst i__1 = k + (k + 1) * a_dim1; i__2 = kp + (k + 1) * a_dim1; a[i__1].r = a[i__2].r; a[i__1].i = a[i__2].i; // , expr subst i__1 = kp + (k + 1) * a_dim1; a[i__1].r = temp.r; a[i__1].i = temp.i; // , expr subst } ++k; kp = -ipiv[k]; if (kp != k) { if (kp > 1) { i__1 = kp - 1; cswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &c__1); } i__1 = k - kp - 1; cswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1) * a_dim1], lda); i__1 = k + k * a_dim1; temp.r = a[i__1].r; temp.i = a[i__1].i; // , expr subst i__1 = k + k * a_dim1; i__2 = kp + kp * a_dim1; a[i__1].r = a[i__2].r; a[i__1].i = a[i__2].i; // , expr subst i__1 = kp + kp * a_dim1; a[i__1].r = temp.r; a[i__1].i = temp.i; // , expr subst } } ++k; goto L30; L40: ; } else { /* Compute inv(A) from the factorization A = L*D*L**T. */ /* K is the main loop index, increasing from 1 to N in steps of */ /* 1 or 2, depending on the size of the diagonal blocks. */ k = *n; L50: /* If K < 1, exit from loop. */ if (k < 1) { goto L60; } if (ipiv[k] > 0) { /* 1 x 1 diagonal block */ /* Invert the diagonal block. */ i__1 = k + k * a_dim1; c_div(&q__1, &c_b1, &a[k + k * a_dim1]); a[i__1].r = q__1.r; a[i__1].i = q__1.i; // , expr subst /* Compute column K of the inverse. */ if (k < *n) { i__1 = *n - k; ccopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1); i__1 = *n - k; q__1.r = -1.f; q__1.i = -0.f; // , expr subst csymv_(uplo, &i__1, &q__1, &a[k + 1 + (k + 1) * a_dim1], lda, &work[1], &c__1, &c_b2, &a[k + 1 + k * a_dim1], &c__1); i__1 = k + k * a_dim1; i__2 = k + k * a_dim1; i__3 = *n - k; cdotu_f2c_(&q__2, &i__3, &work[1], &c__1, &a[k + 1 + k * a_dim1], &c__1); q__1.r = a[i__2].r - q__2.r; q__1.i = a[i__2].i - q__2.i; // , expr subst a[i__1].r = q__1.r; a[i__1].i = q__1.i; // , expr subst } kstep = 1; } else { /* 2 x 2 diagonal block */ /* Invert the diagonal block. */ i__1 = k + (k - 1) * a_dim1; t.r = a[i__1].r; t.i = a[i__1].i; // , expr subst c_div(&q__1, &a[k - 1 + (k - 1) * a_dim1], &t); ak.r = q__1.r; ak.i = q__1.i; // , expr subst c_div(&q__1, &a[k + k * a_dim1], &t); akp1.r = q__1.r; akp1.i = q__1.i; // , expr subst c_div(&q__1, &a[k + (k - 1) * a_dim1], &t); akkp1.r = q__1.r; akkp1.i = q__1.i; // , expr subst q__3.r = ak.r * akp1.r - ak.i * akp1.i; q__3.i = ak.r * akp1.i + ak.i * akp1.r; // , expr subst q__2.r = q__3.r - 1.f; q__2.i = q__3.i - 0.f; // , expr subst q__1.r = t.r * q__2.r - t.i * q__2.i; q__1.i = t.r * q__2.i + t.i * q__2.r; // , expr subst d__.r = q__1.r; d__.i = q__1.i; // , expr subst i__1 = k - 1 + (k - 1) * a_dim1; c_div(&q__1, &akp1, &d__); a[i__1].r = q__1.r; a[i__1].i = q__1.i; // , expr subst i__1 = k + k * a_dim1; c_div(&q__1, &ak, &d__); a[i__1].r = q__1.r; a[i__1].i = q__1.i; // , expr subst i__1 = k + (k - 1) * a_dim1; q__2.r = -akkp1.r; q__2.i = -akkp1.i; // , expr subst c_div(&q__1, &q__2, &d__); a[i__1].r = q__1.r; a[i__1].i = q__1.i; // , expr subst /* Compute columns K-1 and K of the inverse. */ if (k < *n) { i__1 = *n - k; ccopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1); i__1 = *n - k; q__1.r = -1.f; q__1.i = -0.f; // , expr subst csymv_(uplo, &i__1, &q__1, &a[k + 1 + (k + 1) * a_dim1], lda, &work[1], &c__1, &c_b2, &a[k + 1 + k * a_dim1], &c__1); i__1 = k + k * a_dim1; i__2 = k + k * a_dim1; i__3 = *n - k; cdotu_f2c_(&q__2, &i__3, &work[1], &c__1, &a[k + 1 + k * a_dim1], &c__1); q__1.r = a[i__2].r - q__2.r; q__1.i = a[i__2].i - q__2.i; // , expr subst a[i__1].r = q__1.r; a[i__1].i = q__1.i; // , expr subst i__1 = k + (k - 1) * a_dim1; i__2 = k + (k - 1) * a_dim1; i__3 = *n - k; cdotu_f2c_(&q__2, &i__3, &a[k + 1 + k * a_dim1], &c__1, &a[k + 1 + (k - 1) * a_dim1], &c__1); q__1.r = a[i__2].r - q__2.r; q__1.i = a[i__2].i - q__2.i; // , expr subst a[i__1].r = q__1.r; a[i__1].i = q__1.i; // , expr subst i__1 = *n - k; ccopy_(&i__1, &a[k + 1 + (k - 1) * a_dim1], &c__1, &work[1], & c__1); i__1 = *n - k; q__1.r = -1.f; q__1.i = -0.f; // , expr subst csymv_(uplo, &i__1, &q__1, &a[k + 1 + (k + 1) * a_dim1], lda, &work[1], &c__1, &c_b2, &a[k + 1 + (k - 1) * a_dim1], &c__1); i__1 = k - 1 + (k - 1) * a_dim1; i__2 = k - 1 + (k - 1) * a_dim1; i__3 = *n - k; cdotu_f2c_(&q__2, &i__3, &work[1], &c__1, &a[k + 1 + (k - 1) * a_dim1], &c__1); q__1.r = a[i__2].r - q__2.r; q__1.i = a[i__2].i - q__2.i; // , expr subst a[i__1].r = q__1.r; a[i__1].i = q__1.i; // , expr subst } kstep = 2; } if (kstep == 1) { /* Interchange rows and columns K and IPIV(K) in the trailing */ /* submatrix A(k-1:n,k-1:n) */ kp = ipiv[k]; if (kp != k) { if (kp < *n) { i__1 = *n - kp; cswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + kp * a_dim1], &c__1); } i__1 = kp - k - 1; cswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) * a_dim1], lda); i__1 = k + k * a_dim1; temp.r = a[i__1].r; temp.i = a[i__1].i; // , expr subst i__1 = k + k * a_dim1; i__2 = kp + kp * a_dim1; a[i__1].r = a[i__2].r; a[i__1].i = a[i__2].i; // , expr subst i__1 = kp + kp * a_dim1; a[i__1].r = temp.r; a[i__1].i = temp.i; // , expr subst } } else { /* Interchange rows and columns K and K-1 with -IPIV(K) and */ /* -IPIV(K-1) in the trailing submatrix A(k-1:n,k-1:n) */ kp = -ipiv[k]; if (kp != k) { if (kp < *n) { i__1 = *n - kp; cswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + kp * a_dim1], &c__1); } i__1 = kp - k - 1; cswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) * a_dim1], lda); i__1 = k + k * a_dim1; temp.r = a[i__1].r; temp.i = a[i__1].i; // , expr subst i__1 = k + k * a_dim1; i__2 = kp + kp * a_dim1; a[i__1].r = a[i__2].r; a[i__1].i = a[i__2].i; // , expr subst i__1 = kp + kp * a_dim1; a[i__1].r = temp.r; a[i__1].i = temp.i; // , expr subst i__1 = k + (k - 1) * a_dim1; temp.r = a[i__1].r; temp.i = a[i__1].i; // , expr subst i__1 = k + (k - 1) * a_dim1; i__2 = kp + (k - 1) * a_dim1; a[i__1].r = a[i__2].r; a[i__1].i = a[i__2].i; // , expr subst i__1 = kp + (k - 1) * a_dim1; a[i__1].r = temp.r; a[i__1].i = temp.i; // , expr subst } --k; kp = -ipiv[k]; if (kp != k) { if (kp < *n) { i__1 = *n - kp; cswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + kp * a_dim1], &c__1); } i__1 = kp - k - 1; cswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) * a_dim1], lda); i__1 = k + k * a_dim1; temp.r = a[i__1].r; temp.i = a[i__1].i; // , expr subst i__1 = k + k * a_dim1; i__2 = kp + kp * a_dim1; a[i__1].r = a[i__2].r; a[i__1].i = a[i__2].i; // , expr subst i__1 = kp + kp * a_dim1; a[i__1].r = temp.r; a[i__1].i = temp.i; // , expr subst } } --k; goto L50; L60: ; } return 0; /* End of CSYTRI_ROOK */ }
/* Subroutine */ int cla_syrfsx_extended__(integer *prec_type__, char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, logical *colequ, real *c__, complex *b, integer *ldb, complex *y, integer *ldy, real *berr_out__, integer * n_norms__, real *err_bnds_norm__, real *err_bnds_comp__, complex *res, real *ayb, complex *dy, complex *y_tail__, real *rcond, integer * ithresh, real *rthresh, real *dz_ub__, logical *ignore_cwise__, integer *info, ftnlen uplo_len) { /* System generated locals */ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1, y_offset, err_bnds_norm_dim1, err_bnds_norm_offset, err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3, i__4; real r__1, r__2; /* Builtin functions */ double r_imag(complex *); /* Local variables */ real dxratmax, dzratmax; integer i__, j; logical incr_prec__; extern /* Subroutine */ int cla_syamv__(integer *, integer *, real *, complex *, integer *, complex *, integer *, real *, real *, integer *); real prev_dz_z__, yk, final_dx_x__; extern /* Subroutine */ int cla_wwaddw__(integer *, complex *, complex *, complex *); real final_dz_z__, prevnormdx; integer cnt; real dyk, eps, incr_thresh__, dx_x__, dz_z__; extern /* Subroutine */ int cla_lin_berr__(integer *, integer *, integer * , complex *, real *, real *); real ymin; integer y_prec_state__; extern /* Subroutine */ int blas_csymv_x__(integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *, integer *); integer uplo2; extern logical lsame_(char *, char *); extern /* Subroutine */ int blas_csymv2_x__(integer *, integer *, complex *, complex *, integer *, complex *, complex *, integer *, complex *, complex *, integer *, integer *), ccopy_(integer *, complex *, integer *, complex *, integer *); real dxrat, dzrat; extern /* Subroutine */ int caxpy_(integer *, complex *, complex *, integer *, complex *, integer *), csymv_(char *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *); real normx, normy; extern doublereal slamch_(char *); real normdx; extern /* Subroutine */ int csytrs_(char *, integer *, integer *, complex *, integer *, integer *, complex *, integer *, integer *); real hugeval; extern integer ilauplo_(char *); integer x_state__, z_state__; /* -- 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. -- */ /* .. */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CLA_SYRFSX_EXTENDED improves the computed solution to a system of */ /* linear equations by performing extra-precise iterative refinement */ /* and provides error bounds and backward error estimates for the solution. */ /* This subroutine is called by CSYRFSX to perform iterative refinement. */ /* In addition to normwise error bound, the code provides maximum */ /* componentwise error bound if possible. See comments for ERR_BNDS_NORM */ /* and ERR_BNDS_COMP for details of the error bounds. Note that this */ /* subroutine is only resonsible for setting the second fields of */ /* ERR_BNDS_NORM and ERR_BNDS_COMP. */ /* Arguments */ /* ========= */ /* PREC_TYPE (input) INTEGER */ /* Specifies the intermediate precision to be used in refinement. */ /* The value is defined by ILAPREC(P) where P is a CHARACTER and */ /* P = 'S': Single */ /* = 'D': Double */ /* = 'I': Indigenous */ /* = 'X', 'E': Extra */ /* UPLO (input) CHARACTER*1 */ /* = 'U': Upper triangle of A is stored; */ /* = 'L': Lower triangle of A is stored. */ /* N (input) INTEGER */ /* The number of linear equations, i.e., the order of the */ /* matrix A. N >= 0. */ /* NRHS (input) INTEGER */ /* The number of right-hand-sides, i.e., the number of columns of the */ /* matrix B. */ /* A (input) COMPLEX array, dimension (LDA,N) */ /* On entry, the N-by-N matrix A. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* AF (input) COMPLEX array, dimension (LDAF,N) */ /* The block diagonal matrix D and the multipliers used to */ /* obtain the factor U or L as computed by CSYTRF. */ /* LDAF (input) INTEGER */ /* The leading dimension of the array AF. LDAF >= max(1,N). */ /* IPIV (input) INTEGER array, dimension (N) */ /* Details of the interchanges and the block structure of D */ /* as determined by CSYTRF. */ /* COLEQU (input) LOGICAL */ /* If .TRUE. then column equilibration was done to A before calling */ /* this routine. This is needed to compute the solution and error */ /* bounds correctly. */ /* C (input) REAL array, dimension (N) */ /* The column scale factors for A. If COLEQU = .FALSE., C */ /* is not accessed. If C is input, each element of C should be a power */ /* of the radix to ensure a reliable solution and error estimates. */ /* Scaling by powers of the radix does not cause rounding errors unless */ /* the result underflows or overflows. Rounding errors during scaling */ /* lead to refining with a matrix that is not equivalent to the */ /* input matrix, producing error estimates that may not be */ /* reliable. */ /* 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). */ /* Y (input/output) COMPLEX array, dimension */ /* (LDY,NRHS) */ /* On entry, the solution matrix X, as computed by CSYTRS. */ /* On exit, the improved solution matrix Y. */ /* LDY (input) INTEGER */ /* The leading dimension of the array Y. LDY >= max(1,N). */ /* BERR_OUT (output) REAL array, dimension (NRHS) */ /* On exit, BERR_OUT(j) contains the componentwise relative backward */ /* error for right-hand-side j from the formula */ /* max(i) ( abs(RES(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. This is computed by CLA_LIN_BERR. */ /* N_NORMS (input) INTEGER */ /* Determines which error bounds to return (see ERR_BNDS_NORM */ /* and ERR_BNDS_COMP). */ /* If N_NORMS >= 1 return normwise error bounds. */ /* If N_NORMS >= 2 return componentwise error bounds. */ /* ERR_BNDS_NORM (input/output) REAL array, dimension */ /* (NRHS, N_ERR_BNDS) */ /* For each right-hand side, this array contains information about */ /* various error bounds and condition numbers corresponding to the */ /* normwise relative error, which is defined as follows: */ /* Normwise relative error in the ith solution vector: */ /* max_j (abs(XTRUE(j,i) - X(j,i))) */ /* ------------------------------ */ /* max_j abs(X(j,i)) */ /* The array is indexed by the type of error information as described */ /* below. There currently are up to three pieces of information */ /* returned. */ /* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ /* right-hand side. */ /* The second index in ERR_BNDS_NORM(:,err) contains the following */ /* three fields: */ /* err = 1 "Trust/don't trust" boolean. Trust the answer if the */ /* reciprocal condition number is less than the threshold */ /* sqrt(n) * slamch('Epsilon'). */ /* err = 2 "Guaranteed" error bound: The estimated forward error, */ /* almost certainly within a factor of 10 of the true error */ /* so long as the next entry is greater than the threshold */ /* sqrt(n) * slamch('Epsilon'). This error bound should only */ /* be trusted if the previous boolean is true. */ /* err = 3 Reciprocal condition number: Estimated normwise */ /* reciprocal condition number. Compared with the threshold */ /* sqrt(n) * slamch('Epsilon') to determine if the error */ /* estimate is "guaranteed". These reciprocal condition */ /* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ /* appropriately scaled matrix Z. */ /* Let Z = S*A, where S scales each row by a power of the */ /* radix so all absolute row sums of Z are approximately 1. */ /* This subroutine is only responsible for setting the second field */ /* above. */ /* See Lapack Working Note 165 for further details and extra */ /* cautions. */ /* ERR_BNDS_COMP (input/output) REAL array, dimension */ /* (NRHS, N_ERR_BNDS) */ /* For each right-hand side, this array contains information about */ /* various error bounds and condition numbers corresponding to the */ /* componentwise relative error, which is defined as follows: */ /* Componentwise relative error in the ith solution vector: */ /* abs(XTRUE(j,i) - X(j,i)) */ /* max_j ---------------------- */ /* abs(X(j,i)) */ /* The array is indexed by the right-hand side i (on which the */ /* componentwise relative error depends), and the type of error */ /* information as described below. There currently are up to three */ /* pieces of information returned for each right-hand side. If */ /* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ /* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */ /* the first (:,N_ERR_BNDS) entries are returned. */ /* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ /* right-hand side. */ /* The second index in ERR_BNDS_COMP(:,err) contains the following */ /* three fields: */ /* err = 1 "Trust/don't trust" boolean. Trust the answer if the */ /* reciprocal condition number is less than the threshold */ /* sqrt(n) * slamch('Epsilon'). */ /* err = 2 "Guaranteed" error bound: The estimated forward error, */ /* almost certainly within a factor of 10 of the true error */ /* so long as the next entry is greater than the threshold */ /* sqrt(n) * slamch('Epsilon'). This error bound should only */ /* be trusted if the previous boolean is true. */ /* err = 3 Reciprocal condition number: Estimated componentwise */ /* reciprocal condition number. Compared with the threshold */ /* sqrt(n) * slamch('Epsilon') to determine if the error */ /* estimate is "guaranteed". These reciprocal condition */ /* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ /* appropriately scaled matrix Z. */ /* Let Z = S*(A*diag(x)), where x is the solution for the */ /* current right-hand side and S scales each row of */ /* A*diag(x) by a power of the radix so all absolute row */ /* sums of Z are approximately 1. */ /* This subroutine is only responsible for setting the second field */ /* above. */ /* See Lapack Working Note 165 for further details and extra */ /* cautions. */ /* RES (input) COMPLEX array, dimension (N) */ /* Workspace to hold the intermediate residual. */ /* AYB (input) REAL array, dimension (N) */ /* Workspace. */ /* DY (input) COMPLEX array, dimension (N) */ /* Workspace to hold the intermediate solution. */ /* Y_TAIL (input) COMPLEX array, dimension (N) */ /* Workspace to hold the trailing bits of the intermediate solution. */ /* RCOND (input) REAL */ /* Reciprocal scaled condition number. This is an estimate of the */ /* reciprocal Skeel condition number of the matrix A after */ /* equilibration (if done). If this is less than the machine */ /* precision (in particular, if it is zero), the matrix is singular */ /* to working precision. Note that the error may still be small even */ /* if this number is very small and the matrix appears ill- */ /* conditioned. */ /* ITHRESH (input) INTEGER */ /* The maximum number of residual computations allowed for */ /* refinement. The default is 10. For 'aggressive' set to 100 to */ /* permit convergence using approximate factorizations or */ /* factorizations other than LU. If the factorization uses a */ /* technique other than Gaussian elimination, the guarantees in */ /* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */ /* RTHRESH (input) REAL */ /* Determines when to stop refinement if the error estimate stops */ /* decreasing. Refinement will stop when the next solution no longer */ /* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */ /* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */ /* default value is 0.5. For 'aggressive' set to 0.9 to permit */ /* convergence on extremely ill-conditioned matrices. See LAWN 165 */ /* for more details. */ /* DZ_UB (input) REAL */ /* Determines when to start considering componentwise convergence. */ /* Componentwise convergence is only considered after each component */ /* of the solution Y is stable, which we definte as the relative */ /* change in each component being less than DZ_UB. The default value */ /* is 0.25, requiring the first bit to be stable. See LAWN 165 for */ /* more details. */ /* IGNORE_CWISE (input) LOGICAL */ /* If .TRUE. then ignore componentwise convergence. Default value */ /* is .FALSE.. */ /* INFO (output) INTEGER */ /* = 0: Successful exit. */ /* < 0: if INFO = -i, the ith argument to CSYTRS had an illegal */ /* value */ /* ===================================================================== */ /* .. Local Scalars .. */ /* .. */ /* .. Parameters .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Statement Functions .. */ /* .. */ /* .. Statement Function Definitions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ err_bnds_comp_dim1 = *nrhs; err_bnds_comp_offset = 1 + err_bnds_comp_dim1; err_bnds_comp__ -= err_bnds_comp_offset; err_bnds_norm_dim1 = *nrhs; err_bnds_norm_offset = 1 + err_bnds_norm_dim1; err_bnds_norm__ -= err_bnds_norm_offset; a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; af_dim1 = *ldaf; af_offset = 1 + af_dim1; af -= af_offset; --ipiv; --c__; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; y_dim1 = *ldy; y_offset = 1 + y_dim1; y -= y_offset; --berr_out__; --res; --ayb; --dy; --y_tail__; /* Function Body */ if (*info != 0) { return 0; } eps = slamch_("Epsilon"); hugeval = slamch_("Overflow"); /* Force HUGEVAL to Inf */ hugeval *= hugeval; /* Using HUGEVAL may lead to spurious underflows. */ incr_thresh__ = (real) (*n) * eps; if (lsame_(uplo, "L")) { uplo2 = ilauplo_("L"); } else { uplo2 = ilauplo_("U"); } i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { y_prec_state__ = 1; if (y_prec_state__ == 2) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__; y_tail__[i__3].r = 0.f, y_tail__[i__3].i = 0.f; } } dxrat = 0.f; dxratmax = 0.f; dzrat = 0.f; dzratmax = 0.f; final_dx_x__ = hugeval; final_dz_z__ = hugeval; prevnormdx = hugeval; prev_dz_z__ = hugeval; dz_z__ = hugeval; dx_x__ = hugeval; x_state__ = 1; z_state__ = 0; incr_prec__ = FALSE_; i__2 = *ithresh; for (cnt = 1; cnt <= i__2; ++cnt) { /* Compute residual RES = B_s - op(A_s) * Y, */ /* op(A) = A, A**T, or A**H depending on TRANS (and type). */ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); if (y_prec_state__ == 0) { csymv_(uplo, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1, &c_b12, &res[1], &c__1); } else if (y_prec_state__ == 1) { blas_csymv_x__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1, &c_b12, &res[1], &c__1, prec_type__); } else { blas_csymv2_x__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1], &y_tail__[1], &c__1, &c_b12, &res[1], & c__1, prec_type__); } /* XXX: RES is no longer needed. */ ccopy_(n, &res[1], &c__1, &dy[1], &c__1); csytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &dy[1], n, info); /* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */ normx = 0.f; normy = 0.f; normdx = 0.f; dz_z__ = 0.f; ymin = hugeval; i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = i__ + j * y_dim1; yk = (r__1 = y[i__4].r, dabs(r__1)) + (r__2 = r_imag(&y[i__ + j * y_dim1]), dabs(r__2)); i__4 = i__; dyk = (r__1 = dy[i__4].r, dabs(r__1)) + (r__2 = r_imag(&dy[ i__]), dabs(r__2)); if (yk != 0.f) { /* Computing MAX */ r__1 = dz_z__, r__2 = dyk / yk; dz_z__ = dmax(r__1,r__2); } else if (dyk != 0.f) { dz_z__ = hugeval; } ymin = dmin(ymin,yk); normy = dmax(normy,yk); if (*colequ) { /* Computing MAX */ r__1 = normx, r__2 = yk * c__[i__]; normx = dmax(r__1,r__2); /* Computing MAX */ r__1 = normdx, r__2 = dyk * c__[i__]; normdx = dmax(r__1,r__2); } else { normx = normy; normdx = dmax(normdx,dyk); } } if (normx != 0.f) { dx_x__ = normdx / normx; } else if (normdx == 0.f) { dx_x__ = 0.f; } else { dx_x__ = hugeval; } dxrat = normdx / prevnormdx; dzrat = dz_z__ / prev_dz_z__; /* Check termination criteria. */ if (ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2) { incr_prec__ = TRUE_; } if (x_state__ == 3 && dxrat <= *rthresh) { x_state__ = 1; } if (x_state__ == 1) { if (dx_x__ <= eps) { x_state__ = 2; } else if (dxrat > *rthresh) { if (y_prec_state__ != 2) { incr_prec__ = TRUE_; } else { x_state__ = 3; } } else { if (dxrat > dxratmax) { dxratmax = dxrat; } } if (x_state__ > 1) { final_dx_x__ = dx_x__; } } if (z_state__ == 0 && dz_z__ <= *dz_ub__) { z_state__ = 1; } if (z_state__ == 3 && dzrat <= *rthresh) { z_state__ = 1; } if (z_state__ == 1) { if (dz_z__ <= eps) { z_state__ = 2; } else if (dz_z__ > *dz_ub__) { z_state__ = 0; dzratmax = 0.f; final_dz_z__ = hugeval; } else if (dzrat > *rthresh) { if (y_prec_state__ != 2) { incr_prec__ = TRUE_; } else { z_state__ = 3; } } else { if (dzrat > dzratmax) { dzratmax = dzrat; } } if (z_state__ > 1) { final_dz_z__ = dz_z__; } } if (x_state__ != 1 && (*ignore_cwise__ || z_state__ != 1)) { goto L666; } if (incr_prec__) { incr_prec__ = FALSE_; ++y_prec_state__; i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = i__; y_tail__[i__4].r = 0.f, y_tail__[i__4].i = 0.f; } } prevnormdx = normdx; prev_dz_z__ = dz_z__; /* Update soluton. */ if (y_prec_state__ < 2) { caxpy_(n, &c_b12, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1); } else { cla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]); } } /* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */ L666: /* Set final_* when cnt hits ithresh. */ if (x_state__ == 1) { final_dx_x__ = dx_x__; } if (z_state__ == 1) { final_dz_z__ = dz_z__; } /* Compute error bounds. */ if (*n_norms__ >= 1) { err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / ( 1 - dxratmax); } if (*n_norms__ >= 2) { err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / ( 1 - dzratmax); } /* Compute componentwise relative backward error from 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. */ /* Compute residual RES = B_s - op(A_s) * Y, */ /* op(A) = A, A**T, or A**H depending on TRANS (and type). */ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); csymv_(uplo, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1, &c_b12, &res[1], &c__1); i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * b_dim1; ayb[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[i__ + j * b_dim1]), dabs(r__2)); } /* Compute abs(op(A_s))*abs(Y) + abs(B_s). */ cla_syamv__(&uplo2, n, &c_b33, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1, &c_b33, &ayb[1], &c__1); cla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]); /* End of loop for each RHS. */ } return 0; } /* cla_syrfsx_extended__ */