Exemplo n.º 1
0
int
f2c_cher(char* uplo, integer* N,
         real* alpha,
         complex* X, integer* incX,
         complex* A, integer* lda)
{
    cher_(uplo, N, alpha,
          X, incX, A, lda);
    return 0;
}
Exemplo n.º 2
0
 int cpbstf_(char *uplo, int *n, int *kd, complex *ab, 
	 int *ldab, int *info)
{
    /* System generated locals */
    int ab_dim1, ab_offset, i__1, i__2, i__3;
    float r__1;

    /* Builtin functions */
    double sqrt(double);

    /* Local variables */
    int j, m, km;
    float ajj;
    int kld;
    extern  int cher_(char *, int *, float *, complex *, 
	    int *, complex *, int *);
    extern int lsame_(char *, char *);
    int upper;
    extern  int clacgv_(int *, complex *, int *), 
	    csscal_(int *, float *, complex *, int *), xerbla_(char *, 
	    int *);


/*  -- LAPACK routine (version 3.2) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  CPBSTF computes a split Cholesky factorization of a complex */
/*  Hermitian positive definite band matrix A. */

/*  This routine is designed to be used in conjunction with CHBGST. */

/*  The factorization has the form  A = S**H*S  where S is a band matrix */
/*  of the same bandwidth as A and the following structure: */

/*    S = ( U    ) */
/*        ( M  L ) */

/*  where U is upper triangular of order m = (n+kd)/2, and L is lower */
/*  triangular of order n-m. */

/*  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. */

/*  AB      (input/output) COMPLEX array, dimension (LDAB,N) */
/*          On entry, 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). */

/*          On exit, if INFO = 0, the factor S from the split Cholesky */
/*          factorization A = S**H*S. See Further Details. */

/*  LDAB    (input) INTEGER */
/*          The leading dimension of the array AB.  LDAB >= KD+1. */

/*  INFO    (output) INTEGER */
/*          = 0: successful exit */
/*          < 0: if INFO = -i, the i-th argument had an illegal value */
/*          > 0: if INFO = i, the factorization could not be completed, */
/*               because the updated element a(i,i) was negative; the */
/*               matrix A is not positive definite. */

/*  Further Details */
/*  =============== */

/*  The band storage scheme is illustrated by the following example, when */
/*  N = 7, KD = 2: */

/*  S = ( s11  s12  s13                     ) */
/*      (      s22  s23  s24                ) */
/*      (           s33  s34                ) */
/*      (                s44                ) */
/*      (           s53  s54  s55           ) */
/*      (                s64  s65  s66      ) */
/*      (                     s75  s76  s77 ) */

/*  If UPLO = 'U', the array AB holds: */

/*  on entry:                          on exit: */

/*   *    *   a13  a24  a35  a46  a57   *    *   s13  s24  s53' s64' s75' */
/*   *   a12  a23  a34  a45  a56  a67   *   s12  s23  s34  s54' s65' s76' */
/*  a11  a22  a33  a44  a55  a66  a77  s11  s22  s33  s44  s55  s66  s77 */

/*  If UPLO = 'L', the array AB holds: */

/*  on entry:                          on exit: */

/*  a11  a22  a33  a44  a55  a66  a77  s11  s22  s33  s44  s55  s66  s77 */
/*  a21  a32  a43  a54  a65  a76   *   s12' s23' s34' s54  s65  s76   * */
/*  a31  a42  a53  a64  a64   *    *   s13' s24' s53  s64  s75   *    * */

/*  Array elements marked * are not used by the routine; s12' denotes */
/*  conjg(s12); the diagonal elements of S are float. */

/*  ===================================================================== */

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Test the input parameters. */

    /* Parameter adjustments */
    ab_dim1 = *ldab;
    ab_offset = 1 + ab_dim1;
    ab -= ab_offset;

    /* Function Body */
    *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 (*ldab < *kd + 1) {
	*info = -5;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("CPBSTF", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0) {
	return 0;
    }

/* Computing MAX */
    i__1 = 1, i__2 = *ldab - 1;
    kld = MAX(i__1,i__2);

/*     Set the splitting point m. */

    m = (*n + *kd) / 2;

    if (upper) {

/*        Factorize A(m+1:n,m+1:n) as L**H*L, and update A(1:m,1:m). */

	i__1 = m + 1;
	for (j = *n; j >= i__1; --j) {

/*           Compute s(j,j) and test for non-positive-definiteness. */

	    i__2 = *kd + 1 + j * ab_dim1;
	    ajj = ab[i__2].r;
	    if (ajj <= 0.f) {
		i__2 = *kd + 1 + j * ab_dim1;
		ab[i__2].r = ajj, ab[i__2].i = 0.f;
		goto L50;
	    }
	    ajj = sqrt(ajj);
	    i__2 = *kd + 1 + j * ab_dim1;
	    ab[i__2].r = ajj, ab[i__2].i = 0.f;
/* Computing MIN */
	    i__2 = j - 1;
	    km = MIN(i__2,*kd);

/*           Compute elements j-km:j-1 of the j-th column and update the */
/*           the leading submatrix within the band. */

	    r__1 = 1.f / ajj;
	    csscal_(&km, &r__1, &ab[*kd + 1 - km + j * ab_dim1], &c__1);
	    cher_("Upper", &km, &c_b9, &ab[*kd + 1 - km + j * ab_dim1], &c__1, 
		     &ab[*kd + 1 + (j - km) * ab_dim1], &kld);
/* L10: */
	}

/*        Factorize the updated submatrix A(1:m,1:m) as U**H*U. */

	i__1 = m;
	for (j = 1; j <= i__1; ++j) {

/*           Compute s(j,j) and test for non-positive-definiteness. */

	    i__2 = *kd + 1 + j * ab_dim1;
	    ajj = ab[i__2].r;
	    if (ajj <= 0.f) {
		i__2 = *kd + 1 + j * ab_dim1;
		ab[i__2].r = ajj, ab[i__2].i = 0.f;
		goto L50;
	    }
	    ajj = sqrt(ajj);
	    i__2 = *kd + 1 + j * ab_dim1;
	    ab[i__2].r = ajj, ab[i__2].i = 0.f;
/* Computing MIN */
	    i__2 = *kd, i__3 = m - j;
	    km = MIN(i__2,i__3);

/*           Compute elements j+1:j+km of the j-th row and update the */
/*           trailing submatrix within the band. */

	    if (km > 0) {
		r__1 = 1.f / ajj;
		csscal_(&km, &r__1, &ab[*kd + (j + 1) * ab_dim1], &kld);
		clacgv_(&km, &ab[*kd + (j + 1) * ab_dim1], &kld);
		cher_("Upper", &km, &c_b9, &ab[*kd + (j + 1) * ab_dim1], &kld, 
			 &ab[*kd + 1 + (j + 1) * ab_dim1], &kld);
		clacgv_(&km, &ab[*kd + (j + 1) * ab_dim1], &kld);
	    }
/* L20: */
	}
    } else {

/*        Factorize A(m+1:n,m+1:n) as L**H*L, and update A(1:m,1:m). */

	i__1 = m + 1;
	for (j = *n; j >= i__1; --j) {

/*           Compute s(j,j) and test for non-positive-definiteness. */

	    i__2 = j * ab_dim1 + 1;
	    ajj = ab[i__2].r;
	    if (ajj <= 0.f) {
		i__2 = j * ab_dim1 + 1;
		ab[i__2].r = ajj, ab[i__2].i = 0.f;
		goto L50;
	    }
	    ajj = sqrt(ajj);
	    i__2 = j * ab_dim1 + 1;
	    ab[i__2].r = ajj, ab[i__2].i = 0.f;
/* Computing MIN */
	    i__2 = j - 1;
	    km = MIN(i__2,*kd);

/*           Compute elements j-km:j-1 of the j-th row and update the */
/*           trailing submatrix within the band. */

	    r__1 = 1.f / ajj;
	    csscal_(&km, &r__1, &ab[km + 1 + (j - km) * ab_dim1], &kld);
	    clacgv_(&km, &ab[km + 1 + (j - km) * ab_dim1], &kld);
	    cher_("Lower", &km, &c_b9, &ab[km + 1 + (j - km) * ab_dim1], &kld, 
		     &ab[(j - km) * ab_dim1 + 1], &kld);
	    clacgv_(&km, &ab[km + 1 + (j - km) * ab_dim1], &kld);
/* L30: */
	}

/*        Factorize the updated submatrix A(1:m,1:m) as U**H*U. */

	i__1 = m;
	for (j = 1; j <= i__1; ++j) {

/*           Compute s(j,j) and test for non-positive-definiteness. */

	    i__2 = j * ab_dim1 + 1;
	    ajj = ab[i__2].r;
	    if (ajj <= 0.f) {
		i__2 = j * ab_dim1 + 1;
		ab[i__2].r = ajj, ab[i__2].i = 0.f;
		goto L50;
	    }
	    ajj = sqrt(ajj);
	    i__2 = j * ab_dim1 + 1;
	    ab[i__2].r = ajj, ab[i__2].i = 0.f;
/* Computing MIN */
	    i__2 = *kd, i__3 = m - j;
	    km = MIN(i__2,i__3);

/*           Compute elements j+1:j+km of the j-th column and update the */
/*           trailing submatrix within the band. */

	    if (km > 0) {
		r__1 = 1.f / ajj;
		csscal_(&km, &r__1, &ab[j * ab_dim1 + 2], &c__1);
		cher_("Lower", &km, &c_b9, &ab[j * ab_dim1 + 2], &c__1, &ab[(
			j + 1) * ab_dim1 + 1], &kld);
	    }
/* L40: */
	}
    }
    return 0;

L50:
    *info = j;
    return 0;

/*     End of CPBSTF */

} /* cpbstf_ */
Exemplo n.º 3
0
void
cher(char uplo, int n, float alpha, complex *x, int incx, complex *a, int lda)
{
   cher_( &uplo, &n, &alpha, x, &incx, a, &lda);
}
Exemplo n.º 4
0
/* Subroutine */ int cpst01_(char *uplo, integer *n, complex *a, integer *lda, 
	 complex *afac, integer *ldafac, complex *perm, integer *ldperm, 
	integer *piv, real *rwork, real *resid, integer *rank)
{
    /* System generated locals */
    integer a_dim1, a_offset, afac_dim1, afac_offset, perm_dim1, perm_offset, 
	    i__1, i__2, i__3, i__4, i__5;
    real r__1;
    complex q__1;

    /* Local variables */
    integer i__, j, k;
    complex tc;
    real tr, eps;
    real anorm;


/*  -- LAPACK test routine (version 3.1) -- */
/*     Craig Lucas, University of Manchester / NAG Ltd. */
/*     October, 2008 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  CPST01 reconstructs an Hermitian positive semidefinite matrix A */
/*  from its L or U factors and the permutation matrix P and computes */
/*  the residual */
/*     norm( P*L*L'*P' - A ) / ( N * norm(A) * EPS ) or */
/*     norm( P*U'*U*P' - A ) / ( N * norm(A) * EPS ), */
/*  where EPS is the machine epsilon, L' is the conjugate transpose of L, */
/*  and U' is the conjugate transpose of U. */

/*  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 and columns of the matrix A.  N >= 0. */

/*  A       (input) COMPLEX array, dimension (LDA,N) */
/*          The original Hermitian matrix A. */

/*  LDA     (input) INTEGER */
/*          The leading dimension of the array A.  LDA >= max(1,N) */

/*  AFAC    (input) COMPLEX array, dimension (LDAFAC,N) */
/*          The factor L or U from the L*L' or U'*U */
/*          factorization of A. */

/*  LDAFAC  (input) INTEGER */
/*          The leading dimension of the array AFAC.  LDAFAC >= max(1,N). */

/*  PERM    (output) COMPLEX array, dimension (LDPERM,N) */
/*          Overwritten with the reconstructed matrix, and then with the */
/*          difference P*L*L'*P' - A (or P*U'*U*P' - A) */

/*  LDPERM  (input) INTEGER */
/*          The leading dimension of the array PERM. */
/*          LDAPERM >= max(1,N). */

/*  PIV     (input) INTEGER array, dimension (N) */
/*          PIV is such that the nonzero entries are */
/*          P( PIV( K ), K ) = 1. */

/*  RWORK   (workspace) REAL array, dimension (N) */

/*  RESID   (output) REAL */
/*          If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
/*          If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */

/*  ===================================================================== */

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Quick exit if N = 0. */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    afac_dim1 = *ldafac;
    afac_offset = 1 + afac_dim1;
    afac -= afac_offset;
    perm_dim1 = *ldperm;
    perm_offset = 1 + perm_dim1;
    perm -= perm_offset;
    --piv;
    --rwork;

    /* Function Body */
    if (*n <= 0) {
	*resid = 0.f;
	return 0;
    }

/*     Exit with RESID = 1/EPS if ANORM = 0. */

    eps = slamch_("Epsilon");
    anorm = clanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
    if (anorm <= 0.f) {
	*resid = 1.f / eps;
	return 0;
    }

/*     Check the imaginary parts of the diagonal elements and return with */
/*     an error code if any are nonzero. */

    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	if (r_imag(&afac[j + j * afac_dim1]) != 0.f) {
	    *resid = 1.f / eps;
	    return 0;
	}
/* L100: */
    }

/*     Compute the product U'*U, overwriting U. */

    if (lsame_(uplo, "U")) {

	if (*rank < *n) {
	    i__1 = *n;
	    for (j = *rank + 1; j <= i__1; ++j) {
		i__2 = j;
		for (i__ = *rank + 1; i__ <= i__2; ++i__) {
		    i__3 = i__ + j * afac_dim1;
		    afac[i__3].r = 0.f, afac[i__3].i = 0.f;
/* L110: */
		}
/* L120: */
	    }
	}

	for (k = *n; k >= 1; --k) {

/*           Compute the (K,K) element of the result. */

	    cdotc_(&q__1, &k, &afac[k * afac_dim1 + 1], &c__1, &afac[k * 
		    afac_dim1 + 1], &c__1);
	    tr = q__1.r;
	    i__1 = k + k * afac_dim1;
	    afac[i__1].r = tr, afac[i__1].i = 0.f;

/*           Compute the rest of column K. */

	    i__1 = k - 1;
	    ctrmv_("Upper", "Conjugate", "Non-unit", &i__1, &afac[afac_offset]
, ldafac, &afac[k * afac_dim1 + 1], &c__1);

/* L130: */
	}

/*     Compute the product L*L', overwriting L. */

    } else {

	if (*rank < *n) {
	    i__1 = *n;
	    for (j = *rank + 1; j <= i__1; ++j) {
		i__2 = *n;
		for (i__ = j; i__ <= i__2; ++i__) {
		    i__3 = i__ + j * afac_dim1;
		    afac[i__3].r = 0.f, afac[i__3].i = 0.f;
/* L140: */
		}
/* L150: */
	    }
	}

	for (k = *n; k >= 1; --k) {
/*           Add a multiple of column K of the factor L to each of */
/*           columns K+1 through N. */

	    if (k + 1 <= *n) {
		i__1 = *n - k;
		cher_("Lower", &i__1, &c_b20, &afac[k + 1 + k * afac_dim1], &
			c__1, &afac[k + 1 + (k + 1) * afac_dim1], ldafac);
	    }

/*           Scale column K by the diagonal element. */

	    i__1 = k + k * afac_dim1;
	    tc.r = afac[i__1].r, tc.i = afac[i__1].i;
	    i__1 = *n - k + 1;
	    cscal_(&i__1, &tc, &afac[k + k * afac_dim1], &c__1);
/* L160: */
	}

    }

/*        Form P*L*L'*P' or P*U'*U*P' */

    if (lsame_(uplo, "U")) {

	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = *n;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		if (piv[i__] <= piv[j]) {
		    if (i__ <= j) {
			i__3 = piv[i__] + piv[j] * perm_dim1;
			i__4 = i__ + j * afac_dim1;
			perm[i__3].r = afac[i__4].r, perm[i__3].i = afac[i__4]
				.i;
		    } else {
			i__3 = piv[i__] + piv[j] * perm_dim1;
			r_cnjg(&q__1, &afac[j + i__ * afac_dim1]);
			perm[i__3].r = q__1.r, perm[i__3].i = q__1.i;
		    }
		}
/* L170: */
	    }
/* L180: */
	}


    } else {

	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = *n;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		if (piv[i__] >= piv[j]) {
		    if (i__ >= j) {
			i__3 = piv[i__] + piv[j] * perm_dim1;
			i__4 = i__ + j * afac_dim1;
			perm[i__3].r = afac[i__4].r, perm[i__3].i = afac[i__4]
				.i;
		    } else {
			i__3 = piv[i__] + piv[j] * perm_dim1;
			r_cnjg(&q__1, &afac[j + i__ * afac_dim1]);
			perm[i__3].r = q__1.r, perm[i__3].i = q__1.i;
		    }
		}
/* L190: */
	    }
/* L200: */
	}

    }

/*     Compute the difference  P*L*L'*P' - A (or P*U'*U*P' - A). */

    if (lsame_(uplo, "U")) {
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = j - 1;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		i__3 = i__ + j * perm_dim1;
		i__4 = i__ + j * perm_dim1;
		i__5 = i__ + j * a_dim1;
		q__1.r = perm[i__4].r - a[i__5].r, q__1.i = perm[i__4].i - a[
			i__5].i;
		perm[i__3].r = q__1.r, perm[i__3].i = q__1.i;
/* L210: */
	    }
	    i__2 = j + j * perm_dim1;
	    i__3 = j + j * perm_dim1;
	    i__4 = j + j * a_dim1;
	    r__1 = a[i__4].r;
	    q__1.r = perm[i__3].r - r__1, q__1.i = perm[i__3].i;
	    perm[i__2].r = q__1.r, perm[i__2].i = q__1.i;
/* L220: */
	}
    } else {
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = j + j * perm_dim1;
	    i__3 = j + j * perm_dim1;
	    i__4 = j + j * a_dim1;
	    r__1 = a[i__4].r;
	    q__1.r = perm[i__3].r - r__1, q__1.i = perm[i__3].i;
	    perm[i__2].r = q__1.r, perm[i__2].i = q__1.i;
	    i__2 = *n;
	    for (i__ = j + 1; i__ <= i__2; ++i__) {
		i__3 = i__ + j * perm_dim1;
		i__4 = i__ + j * perm_dim1;
		i__5 = i__ + j * a_dim1;
		q__1.r = perm[i__4].r - a[i__5].r, q__1.i = perm[i__4].i - a[
			i__5].i;
		perm[i__3].r = q__1.r, perm[i__3].i = q__1.i;
/* L230: */
	    }
/* L240: */
	}
    }

/*     Compute norm( P*L*L'P - A ) / ( N * norm(A) * EPS ), or */
/*     ( P*U'*U*P' - A )/ ( N * norm(A) * EPS ). */

    *resid = clanhe_("1", uplo, n, &perm[perm_offset], ldafac, &rwork[1]);

    *resid = *resid / (real) (*n) / anorm / eps;

    return 0;

/*     End of CPST01 */

} /* cpst01_ */
Exemplo n.º 5
0
/* Subroutine */
int cpbtf2_(char *uplo, integer *n, integer *kd, complex *ab, integer *ldab, integer *info)
{
    /* System generated locals */
    integer ab_dim1, ab_offset, i__1, i__2, i__3;
    real r__1;
    /* Builtin functions */
    double sqrt(doublereal);
    /* Local variables */
    integer j, kn;
    real ajj;
    integer kld;
    extern /* Subroutine */
    int cher_(char *, integer *, real *, complex *, integer *, complex *, integer *);
    extern logical lsame_(char *, char *);
    logical upper;
    extern /* Subroutine */
    int clacgv_(integer *, complex *, integer *), csscal_(integer *, real *, complex *, integer *), xerbla_(char *, integer *);
    /* -- 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 .. */
    /* .. */
    /* ===================================================================== */
    /* .. Parameters .. */
    /* .. */
    /* .. Local Scalars .. */
    /* .. */
    /* .. External Functions .. */
    /* .. */
    /* .. External Subroutines .. */
    /* .. */
    /* .. Intrinsic Functions .. */
    /* .. */
    /* .. Executable Statements .. */
    /* Test the input parameters. */
    /* Parameter adjustments */
    ab_dim1 = *ldab;
    ab_offset = 1 + ab_dim1;
    ab -= ab_offset;
    /* Function Body */
    *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 (*ldab < *kd + 1)
    {
        *info = -5;
    }
    if (*info != 0)
    {
        i__1 = -(*info);
        xerbla_("CPBTF2", &i__1);
        return 0;
    }
    /* Quick return if possible */
    if (*n == 0)
    {
        return 0;
    }
    /* Computing MAX */
    i__1 = 1;
    i__2 = *ldab - 1; // , expr subst
    kld = max(i__1,i__2);
    if (upper)
    {
        /* Compute the Cholesky factorization A = U**H * U. */
        i__1 = *n;
        for (j = 1;
                j <= i__1;
                ++j)
        {
            /* Compute U(J,J) and test for non-positive-definiteness. */
            i__2 = *kd + 1 + j * ab_dim1;
            ajj = ab[i__2].r;
            if (ajj <= 0.f)
            {
                i__2 = *kd + 1 + j * ab_dim1;
                ab[i__2].r = ajj;
                ab[i__2].i = 0.f; // , expr subst
                goto L30;
            }
            ajj = sqrt(ajj);
            i__2 = *kd + 1 + j * ab_dim1;
            ab[i__2].r = ajj;
            ab[i__2].i = 0.f; // , expr subst
            /* Compute elements J+1:J+KN of row J and update the */
            /* trailing submatrix within the band. */
            /* Computing MIN */
            i__2 = *kd;
            i__3 = *n - j; // , expr subst
            kn = min(i__2,i__3);
            if (kn > 0)
            {
                r__1 = 1.f / ajj;
                csscal_(&kn, &r__1, &ab[*kd + (j + 1) * ab_dim1], &kld);
                clacgv_(&kn, &ab[*kd + (j + 1) * ab_dim1], &kld);
                cher_("Upper", &kn, &c_b8, &ab[*kd + (j + 1) * ab_dim1], &kld, &ab[*kd + 1 + (j + 1) * ab_dim1], &kld);
                clacgv_(&kn, &ab[*kd + (j + 1) * ab_dim1], &kld);
            }
            /* L10: */
        }
    }
    else
    {
        /* Compute the Cholesky factorization A = L*L**H. */
        i__1 = *n;
        for (j = 1;
                j <= i__1;
                ++j)
        {
            /* Compute L(J,J) and test for non-positive-definiteness. */
            i__2 = j * ab_dim1 + 1;
            ajj = ab[i__2].r;
            if (ajj <= 0.f)
            {
                i__2 = j * ab_dim1 + 1;
                ab[i__2].r = ajj;
                ab[i__2].i = 0.f; // , expr subst
                goto L30;
            }
            ajj = sqrt(ajj);
            i__2 = j * ab_dim1 + 1;
            ab[i__2].r = ajj;
            ab[i__2].i = 0.f; // , expr subst
            /* Compute elements J+1:J+KN of column J and update the */
            /* trailing submatrix within the band. */
            /* Computing MIN */
            i__2 = *kd;
            i__3 = *n - j; // , expr subst
            kn = min(i__2,i__3);
            if (kn > 0)
            {
                r__1 = 1.f / ajj;
                csscal_(&kn, &r__1, &ab[j * ab_dim1 + 2], &c__1);
                cher_("Lower", &kn, &c_b8, &ab[j * ab_dim1 + 2], &c__1, &ab[( j + 1) * ab_dim1 + 1], &kld);
            }
            /* L20: */
        }
    }
    return 0;
L30:
    *info = j;
    return 0;
    /* End of CPBTF2 */
}
Exemplo n.º 6
0
/* Subroutine */ int chetf2_(char *uplo, integer *n, complex *a, integer *lda,
	 integer *ipiv, integer *info, ftnlen uplo_len)
{
    /* System generated locals */
    integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
    real r__1, r__2, r__3, r__4;
    complex q__1, q__2, q__3, q__4, q__5, q__6;

    /* Builtin functions */
    double sqrt(doublereal), r_imag(complex *);
    void r_cnjg(complex *, complex *);

    /* Local variables */
    static real d__;
    static integer i__, j, k;
    static complex t;
    static real r1, d11;
    static complex d12;
    static real d22;
    static complex d21;
    static integer kk, kp;
    static complex wk;
    static real tt;
    static complex wkm1, wkp1;
    extern /* Subroutine */ int cher_(char *, integer *, real *, complex *, 
	    integer *, complex *, integer *, ftnlen);
    static integer imax, jmax;
    static real alpha;
    extern logical lsame_(char *, char *, ftnlen, ftnlen);
    extern /* Subroutine */ int cswap_(integer *, complex *, integer *, 
	    complex *, integer *);
    static integer kstep;
    static logical upper;
    extern doublereal slapy2_(real *, real *);
    static real absakk;
    extern integer icamax_(integer *, complex *, integer *);
    extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer 
	    *), xerbla_(char *, integer *, ftnlen);
    static real colmax, rowmax;


/*  -- 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 */
/*  ======= */

/*  CHETF2 computes the factorization of a complex Hermitian matrix A */
/*  using the Bunch-Kaufman diagonal pivoting method: */

/*     A = U*D*U'  or  A = L*D*L' */

/*  where U (or L) is a product of permutation and unit upper (lower) */
/*  triangular matrices, U' is the conjugate transpose of U, and D is */
/*  Hermitian and block diagonal with 1-by-1 and 2-by-2 diagonal blocks. */

/*  This is the unblocked version of the algorithm, calling Level 2 BLAS. */

/*  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 order of the matrix A.  N >= 0. */

/*  A       (input/output) COMPLEX array, dimension (LDA,N) */
/*          On entry, 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. */

/*          On exit, the block diagonal matrix D and the multipliers used */
/*          to obtain the factor U or L (see below for further details). */

/*  LDA     (input) INTEGER */
/*          The leading dimension of the array A.  LDA >= max(1,N). */

/*  IPIV    (output) INTEGER array, dimension (N) */
/*          Details of the interchanges and the block structure of D. */
/*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
/*          interchanged and D(k,k) is a 1-by-1 diagonal block. */
/*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
/*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
/*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) = */
/*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
/*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */

/*  INFO    (output) INTEGER */
/*          = 0: successful exit */
/*          < 0: if INFO = -k, the k-th argument had an illegal value */
/*          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization */
/*               has been completed, but the block diagonal matrix D is */
/*               exactly singular, and division by zero will occur if it */
/*               is used to solve a system of equations. */

/*  Further Details */
/*  =============== */

/*  1-96 - Based on modifications by */
/*    J. Lewis, Boeing Computer Services Company */
/*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */

/*  If UPLO = 'U', then A = U*D*U', where */
/*     U = P(n)*U(n)* ... *P(k)U(k)* ..., */
/*  i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
/*  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
/*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as */
/*  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
/*  that if the diagonal block D(k) is of order s (s = 1 or 2), then */

/*             (   I    v    0   )   k-s */
/*     U(k) =  (   0    I    0   )   s */
/*             (   0    0    I   )   n-k */
/*                k-s   s   n-k */

/*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
/*  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
/*  and A(k,k), and v overwrites A(1:k-2,k-1:k). */

/*  If UPLO = 'L', then A = L*D*L', where */
/*     L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
/*  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
/*  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
/*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as */
/*  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
/*  that if the diagonal block D(k) is of order s (s = 1 or 2), then */

/*             (   I    0     0   )  k-1 */
/*     L(k) =  (   0    I     0   )  s */
/*             (   0    v     I   )  n-k-s+1 */
/*                k-1   s  n-k-s+1 */

/*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
/*  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
/*  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */

/*  ===================================================================== */

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. 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;
    --ipiv;

    /* Function Body */
    *info = 0;
    upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
    if (! upper && ! lsame_(uplo, "L", (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_("CHETF2", &i__1, (ftnlen)6);
	return 0;
    }

/*     Initialize ALPHA for use in choosing pivot block size. */

    alpha = (sqrt(17.f) + 1.f) / 8.f;

    if (upper) {

/*        Factorize A as U*D*U' using the upper triangle of A */

/*        K is the main loop index, decreasing from N to 1 in steps of */
/*        1 or 2 */

	k = *n;
L10:

/*        If K < 1, exit from loop */

	if (k < 1) {
	    goto L90;
	}
	kstep = 1;

/*        Determine rows and columns to be interchanged and whether */
/*        a 1-by-1 or 2-by-2 pivot block will be used */

	i__1 = k + k * a_dim1;
	absakk = (r__1 = a[i__1].r, dabs(r__1));

/*        IMAX is the row-index of the largest off-diagonal element in */
/*        column K, and COLMAX is its absolute value */

	if (k > 1) {
	    i__1 = k - 1;
	    imax = icamax_(&i__1, &a[k * a_dim1 + 1], &c__1);
	    i__1 = imax + k * a_dim1;
	    colmax = (r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a[imax 
		    + k * a_dim1]), dabs(r__2));
	} else {
	    colmax = 0.f;
	}

	if (dmax(absakk,colmax) == 0.f) {

/*           Column K is zero: set INFO and continue */

	    if (*info == 0) {
		*info = k;
	    }
	    kp = k;
	    i__1 = k + k * a_dim1;
	    i__2 = k + k * a_dim1;
	    r__1 = a[i__2].r;
	    a[i__1].r = r__1, a[i__1].i = 0.f;
	} else {
	    if (absakk >= alpha * colmax) {

/*              no interchange, use 1-by-1 pivot block */

		kp = k;
	    } else {

/*              JMAX is the column-index of the largest off-diagonal */
/*              element in row IMAX, and ROWMAX is its absolute value */

		i__1 = k - imax;
		jmax = imax + icamax_(&i__1, &a[imax + (imax + 1) * a_dim1], 
			lda);
		i__1 = imax + jmax * a_dim1;
		rowmax = (r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a[
			imax + jmax * a_dim1]), dabs(r__2));
		if (imax > 1) {
		    i__1 = imax - 1;
		    jmax = icamax_(&i__1, &a[imax * a_dim1 + 1], &c__1);
/* Computing MAX */
		    i__1 = jmax + imax * a_dim1;
		    r__3 = rowmax, r__4 = (r__1 = a[i__1].r, dabs(r__1)) + (
			    r__2 = r_imag(&a[jmax + imax * a_dim1]), dabs(
			    r__2));
		    rowmax = dmax(r__3,r__4);
		}

		if (absakk >= alpha * colmax * (colmax / rowmax)) {

/*                 no interchange, use 1-by-1 pivot block */

		    kp = k;
		} else /* if(complicated condition) */ {
		    i__1 = imax + imax * a_dim1;
		    if ((r__1 = a[i__1].r, dabs(r__1)) >= alpha * rowmax) {

/*                 interchange rows and columns K and IMAX, use 1-by-1 */
/*                 pivot block */

			kp = imax;
		    } else {

/*                 interchange rows and columns K-1 and IMAX, use 2-by-2 */
/*                 pivot block */

			kp = imax;
			kstep = 2;
		    }
		}
	    }

	    kk = k - kstep + 1;
	    if (kp != kk) {

/*              Interchange rows and columns KK and KP in the leading */
/*              submatrix A(1:k,1:k) */

		i__1 = kp - 1;
		cswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1],
			 &c__1);
		i__1 = kk - 1;
		for (j = kp + 1; j <= i__1; ++j) {
		    r_cnjg(&q__1, &a[j + kk * a_dim1]);
		    t.r = q__1.r, t.i = q__1.i;
		    i__2 = j + kk * a_dim1;
		    r_cnjg(&q__1, &a[kp + j * a_dim1]);
		    a[i__2].r = q__1.r, a[i__2].i = q__1.i;
		    i__2 = kp + j * a_dim1;
		    a[i__2].r = t.r, a[i__2].i = t.i;
/* L20: */
		}
		i__1 = kp + kk * a_dim1;
		r_cnjg(&q__1, &a[kp + kk * a_dim1]);
		a[i__1].r = q__1.r, a[i__1].i = q__1.i;
		i__1 = kk + kk * a_dim1;
		r1 = a[i__1].r;
		i__1 = kk + kk * a_dim1;
		i__2 = kp + kp * a_dim1;
		r__1 = a[i__2].r;
		a[i__1].r = r__1, a[i__1].i = 0.f;
		i__1 = kp + kp * a_dim1;
		a[i__1].r = r1, a[i__1].i = 0.f;
		if (kstep == 2) {
		    i__1 = k + k * a_dim1;
		    i__2 = k + k * a_dim1;
		    r__1 = a[i__2].r;
		    a[i__1].r = r__1, a[i__1].i = 0.f;
		    i__1 = k - 1 + k * a_dim1;
		    t.r = a[i__1].r, t.i = a[i__1].i;
		    i__1 = k - 1 + k * a_dim1;
		    i__2 = kp + k * a_dim1;
		    a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
		    i__1 = kp + k * a_dim1;
		    a[i__1].r = t.r, a[i__1].i = t.i;
		}
	    } else {
		i__1 = k + k * a_dim1;
		i__2 = k + k * a_dim1;
		r__1 = a[i__2].r;
		a[i__1].r = r__1, a[i__1].i = 0.f;
		if (kstep == 2) {
		    i__1 = k - 1 + (k - 1) * a_dim1;
		    i__2 = k - 1 + (k - 1) * a_dim1;
		    r__1 = a[i__2].r;
		    a[i__1].r = r__1, a[i__1].i = 0.f;
		}
	    }

/*           Update the leading submatrix */

	    if (kstep == 1) {

/*              1-by-1 pivot block D(k): column k now holds */

/*              W(k) = U(k)*D(k) */

/*              where U(k) is the k-th column of U */

/*              Perform a rank-1 update of A(1:k-1,1:k-1) as */

/*              A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */

		i__1 = k + k * a_dim1;
		r1 = 1.f / a[i__1].r;
		i__1 = k - 1;
		r__1 = -r1;
		cher_(uplo, &i__1, &r__1, &a[k * a_dim1 + 1], &c__1, &a[
			a_offset], lda, (ftnlen)1);

/*              Store U(k) in column k */

		i__1 = k - 1;
		csscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
	    } else {

/*              2-by-2 pivot block D(k): columns k and k-1 now hold */

/*              ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */

/*              where U(k) and U(k-1) are the k-th and (k-1)-th columns */
/*              of U */

/*              Perform a rank-2 update of A(1:k-2,1:k-2) as */

/*              A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )' */
/*                 = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */

		if (k > 2) {

		    i__1 = k - 1 + k * a_dim1;
		    r__1 = a[i__1].r;
		    r__2 = r_imag(&a[k - 1 + k * a_dim1]);
		    d__ = slapy2_(&r__1, &r__2);
		    i__1 = k - 1 + (k - 1) * a_dim1;
		    d22 = a[i__1].r / d__;
		    i__1 = k + k * a_dim1;
		    d11 = a[i__1].r / d__;
		    tt = 1.f / (d11 * d22 - 1.f);
		    i__1 = k - 1 + k * a_dim1;
		    q__1.r = a[i__1].r / d__, q__1.i = a[i__1].i / d__;
		    d12.r = q__1.r, d12.i = q__1.i;
		    d__ = tt / d__;

		    for (j = k - 2; j >= 1; --j) {
			i__1 = j + (k - 1) * a_dim1;
			q__3.r = d11 * a[i__1].r, q__3.i = d11 * a[i__1].i;
			r_cnjg(&q__5, &d12);
			i__2 = j + k * a_dim1;
			q__4.r = q__5.r * a[i__2].r - q__5.i * a[i__2].i, 
				q__4.i = q__5.r * a[i__2].i + q__5.i * a[i__2]
				.r;
			q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
			q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
			wkm1.r = q__1.r, wkm1.i = q__1.i;
			i__1 = j + k * a_dim1;
			q__3.r = d22 * a[i__1].r, q__3.i = d22 * a[i__1].i;
			i__2 = j + (k - 1) * a_dim1;
			q__4.r = d12.r * a[i__2].r - d12.i * a[i__2].i, 
				q__4.i = d12.r * a[i__2].i + d12.i * a[i__2]
				.r;
			q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
			q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
			wk.r = q__1.r, wk.i = q__1.i;
			for (i__ = j; i__ >= 1; --i__) {
			    i__1 = i__ + j * a_dim1;
			    i__2 = i__ + j * a_dim1;
			    i__3 = i__ + k * a_dim1;
			    r_cnjg(&q__4, &wk);
			    q__3.r = a[i__3].r * q__4.r - a[i__3].i * q__4.i, 
				    q__3.i = a[i__3].r * q__4.i + a[i__3].i * 
				    q__4.r;
			    q__2.r = a[i__2].r - q__3.r, q__2.i = a[i__2].i - 
				    q__3.i;
			    i__4 = i__ + (k - 1) * a_dim1;
			    r_cnjg(&q__6, &wkm1);
			    q__5.r = a[i__4].r * q__6.r - a[i__4].i * q__6.i, 
				    q__5.i = a[i__4].r * q__6.i + a[i__4].i * 
				    q__6.r;
			    q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - 
				    q__5.i;
			    a[i__1].r = q__1.r, a[i__1].i = q__1.i;
/* L30: */
			}
			i__1 = j + k * a_dim1;
			a[i__1].r = wk.r, a[i__1].i = wk.i;
			i__1 = j + (k - 1) * a_dim1;
			a[i__1].r = wkm1.r, a[i__1].i = wkm1.i;
			i__1 = j + j * a_dim1;
			i__2 = j + j * a_dim1;
			r__1 = 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;
/* L40: */
		    }

		}

	    }
	}

/*        Store details of the interchanges in IPIV */

	if (kstep == 1) {
	    ipiv[k] = kp;
	} else {
	    ipiv[k] = -kp;
	    ipiv[k - 1] = -kp;
	}

/*        Decrease K and return to the start of the main loop */

	k -= kstep;
	goto L10;

    } else {

/*        Factorize A as L*D*L' using the lower triangle of A */

/*        K is the main loop index, increasing from 1 to N in steps of */
/*        1 or 2 */

	k = 1;
L50:

/*        If K > N, exit from loop */

	if (k > *n) {
	    goto L90;
	}
	kstep = 1;

/*        Determine rows and columns to be interchanged and whether */
/*        a 1-by-1 or 2-by-2 pivot block will be used */

	i__1 = k + k * a_dim1;
	absakk = (r__1 = a[i__1].r, dabs(r__1));

/*        IMAX is the row-index of the largest off-diagonal element in */
/*        column K, and COLMAX is its absolute value */

	if (k < *n) {
	    i__1 = *n - k;
	    imax = k + icamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1);
	    i__1 = imax + k * a_dim1;
	    colmax = (r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a[imax 
		    + k * a_dim1]), dabs(r__2));
	} else {
	    colmax = 0.f;
	}

	if (dmax(absakk,colmax) == 0.f) {

/*           Column K is zero: set INFO and continue */

	    if (*info == 0) {
		*info = k;
	    }
	    kp = k;
	    i__1 = k + k * a_dim1;
	    i__2 = k + k * a_dim1;
	    r__1 = a[i__2].r;
	    a[i__1].r = r__1, a[i__1].i = 0.f;
	} else {
	    if (absakk >= alpha * colmax) {

/*              no interchange, use 1-by-1 pivot block */

		kp = k;
	    } else {

/*              JMAX is the column-index of the largest off-diagonal */
/*              element in row IMAX, and ROWMAX is its absolute value */

		i__1 = imax - k;
		jmax = k - 1 + icamax_(&i__1, &a[imax + k * a_dim1], lda);
		i__1 = imax + jmax * a_dim1;
		rowmax = (r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a[
			imax + jmax * a_dim1]), dabs(r__2));
		if (imax < *n) {
		    i__1 = *n - imax;
		    jmax = imax + icamax_(&i__1, &a[imax + 1 + imax * a_dim1],
			     &c__1);
/* Computing MAX */
		    i__1 = jmax + imax * a_dim1;
		    r__3 = rowmax, r__4 = (r__1 = a[i__1].r, dabs(r__1)) + (
			    r__2 = r_imag(&a[jmax + imax * a_dim1]), dabs(
			    r__2));
		    rowmax = dmax(r__3,r__4);
		}

		if (absakk >= alpha * colmax * (colmax / rowmax)) {

/*                 no interchange, use 1-by-1 pivot block */

		    kp = k;
		} else /* if(complicated condition) */ {
		    i__1 = imax + imax * a_dim1;
		    if ((r__1 = a[i__1].r, dabs(r__1)) >= alpha * rowmax) {

/*                 interchange rows and columns K and IMAX, use 1-by-1 */
/*                 pivot block */

			kp = imax;
		    } else {

/*                 interchange rows and columns K+1 and IMAX, use 2-by-2 */
/*                 pivot block */

			kp = imax;
			kstep = 2;
		    }
		}
	    }

	    kk = k + kstep - 1;
	    if (kp != kk) {

/*              Interchange rows and columns KK and KP in the trailing */
/*              submatrix A(k:n,k:n) */

		if (kp < *n) {
		    i__1 = *n - kp;
		    cswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 
			    + kp * a_dim1], &c__1);
		}
		i__1 = kp - 1;
		for (j = kk + 1; j <= i__1; ++j) {
		    r_cnjg(&q__1, &a[j + kk * a_dim1]);
		    t.r = q__1.r, t.i = q__1.i;
		    i__2 = j + kk * a_dim1;
		    r_cnjg(&q__1, &a[kp + j * a_dim1]);
		    a[i__2].r = q__1.r, a[i__2].i = q__1.i;
		    i__2 = kp + j * a_dim1;
		    a[i__2].r = t.r, a[i__2].i = t.i;
/* L60: */
		}
		i__1 = kp + kk * a_dim1;
		r_cnjg(&q__1, &a[kp + kk * a_dim1]);
		a[i__1].r = q__1.r, a[i__1].i = q__1.i;
		i__1 = kk + kk * a_dim1;
		r1 = a[i__1].r;
		i__1 = kk + kk * a_dim1;
		i__2 = kp + kp * a_dim1;
		r__1 = a[i__2].r;
		a[i__1].r = r__1, a[i__1].i = 0.f;
		i__1 = kp + kp * a_dim1;
		a[i__1].r = r1, a[i__1].i = 0.f;
		if (kstep == 2) {
		    i__1 = k + k * a_dim1;
		    i__2 = k + k * a_dim1;
		    r__1 = a[i__2].r;
		    a[i__1].r = r__1, a[i__1].i = 0.f;
		    i__1 = k + 1 + k * a_dim1;
		    t.r = a[i__1].r, t.i = a[i__1].i;
		    i__1 = k + 1 + k * a_dim1;
		    i__2 = kp + k * a_dim1;
		    a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
		    i__1 = kp + k * a_dim1;
		    a[i__1].r = t.r, a[i__1].i = t.i;
		}
	    } else {
		i__1 = k + k * a_dim1;
		i__2 = k + k * a_dim1;
		r__1 = a[i__2].r;
		a[i__1].r = r__1, a[i__1].i = 0.f;
		if (kstep == 2) {
		    i__1 = k + 1 + (k + 1) * a_dim1;
		    i__2 = k + 1 + (k + 1) * a_dim1;
		    r__1 = a[i__2].r;
		    a[i__1].r = r__1, a[i__1].i = 0.f;
		}
	    }

/*           Update the trailing submatrix */

	    if (kstep == 1) {

/*              1-by-1 pivot block D(k): column k now holds */

/*              W(k) = L(k)*D(k) */

/*              where L(k) is the k-th column of L */

		if (k < *n) {

/*                 Perform a rank-1 update of A(k+1:n,k+1:n) as */

/*                 A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */

		    i__1 = k + k * a_dim1;
		    r1 = 1.f / a[i__1].r;
		    i__1 = *n - k;
		    r__1 = -r1;
		    cher_(uplo, &i__1, &r__1, &a[k + 1 + k * a_dim1], &c__1, &
			    a[k + 1 + (k + 1) * a_dim1], lda, (ftnlen)1);

/*                 Store L(k) in column K */

		    i__1 = *n - k;
		    csscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1);
		}
	    } else {

/*              2-by-2 pivot block D(k) */

		if (k < *n - 1) {

/*                 Perform a rank-2 update of A(k+2:n,k+2:n) as */

/*                 A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )' */
/*                    = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' */

/*                 where L(k) and L(k+1) are the k-th and (k+1)-th */
/*                 columns of L */

		    i__1 = k + 1 + k * a_dim1;
		    r__1 = a[i__1].r;
		    r__2 = r_imag(&a[k + 1 + k * a_dim1]);
		    d__ = slapy2_(&r__1, &r__2);
		    i__1 = k + 1 + (k + 1) * a_dim1;
		    d11 = a[i__1].r / d__;
		    i__1 = k + k * a_dim1;
		    d22 = a[i__1].r / d__;
		    tt = 1.f / (d11 * d22 - 1.f);
		    i__1 = k + 1 + k * a_dim1;
		    q__1.r = a[i__1].r / d__, q__1.i = a[i__1].i / d__;
		    d21.r = q__1.r, d21.i = q__1.i;
		    d__ = tt / d__;

		    i__1 = *n;
		    for (j = k + 2; j <= i__1; ++j) {
			i__2 = j + k * a_dim1;
			q__3.r = d11 * a[i__2].r, q__3.i = d11 * a[i__2].i;
			i__3 = j + (k + 1) * a_dim1;
			q__4.r = d21.r * a[i__3].r - d21.i * a[i__3].i, 
				q__4.i = d21.r * a[i__3].i + d21.i * a[i__3]
				.r;
			q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
			q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
			wk.r = q__1.r, wk.i = q__1.i;
			i__2 = j + (k + 1) * a_dim1;
			q__3.r = d22 * a[i__2].r, q__3.i = d22 * a[i__2].i;
			r_cnjg(&q__5, &d21);
			i__3 = j + k * a_dim1;
			q__4.r = q__5.r * a[i__3].r - q__5.i * a[i__3].i, 
				q__4.i = q__5.r * a[i__3].i + q__5.i * a[i__3]
				.r;
			q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
			q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
			wkp1.r = q__1.r, wkp1.i = q__1.i;
			i__2 = *n;
			for (i__ = j; i__ <= i__2; ++i__) {
			    i__3 = i__ + j * a_dim1;
			    i__4 = i__ + j * a_dim1;
			    i__5 = i__ + k * a_dim1;
			    r_cnjg(&q__4, &wk);
			    q__3.r = a[i__5].r * q__4.r - a[i__5].i * q__4.i, 
				    q__3.i = a[i__5].r * q__4.i + a[i__5].i * 
				    q__4.r;
			    q__2.r = a[i__4].r - q__3.r, q__2.i = a[i__4].i - 
				    q__3.i;
			    i__6 = i__ + (k + 1) * a_dim1;
			    r_cnjg(&q__6, &wkp1);
			    q__5.r = a[i__6].r * q__6.r - a[i__6].i * q__6.i, 
				    q__5.i = a[i__6].r * q__6.i + a[i__6].i * 
				    q__6.r;
			    q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - 
				    q__5.i;
			    a[i__3].r = q__1.r, a[i__3].i = q__1.i;
/* L70: */
			}
			i__2 = j + k * a_dim1;
			a[i__2].r = wk.r, a[i__2].i = wk.i;
			i__2 = j + (k + 1) * a_dim1;
			a[i__2].r = wkp1.r, a[i__2].i = wkp1.i;
			i__2 = j + j * a_dim1;
			i__3 = j + j * a_dim1;
			r__1 = a[i__3].r;
			q__1.r = r__1, q__1.i = 0.f;
			a[i__2].r = q__1.r, a[i__2].i = q__1.i;
/* L80: */
		    }
		}
	    }
	}

/*        Store details of the interchanges in IPIV */

	if (kstep == 1) {
	    ipiv[k] = kp;
	} else {
	    ipiv[k] = -kp;
	    ipiv[k + 1] = -kp;
	}

/*        Increase K and return to the start of the main loop */

	k += kstep;
	goto L50;

    }

L90:
    return 0;

/*     End of CHETF2 */

} /* chetf2_ */
Exemplo n.º 7
0
/* Subroutine */ int cpbtf2_(char *uplo, integer *n, integer *kd, complex *ab,
	 integer *ldab, integer *info, ftnlen uplo_len)
{
    /* System generated locals */
    integer ab_dim1, ab_offset, i__1, i__2, i__3;
    real r__1;

    /* Builtin functions */
    double sqrt(doublereal);

    /* Local variables */
    static integer j, kn;
    static real ajj;
    static integer kld;
    extern /* Subroutine */ int cher_(char *, integer *, real *, complex *, 
	    integer *, complex *, integer *, ftnlen);
    extern logical lsame_(char *, char *, ftnlen, ftnlen);
    static logical upper;
    extern /* Subroutine */ int clacgv_(integer *, complex *, integer *), 
	    csscal_(integer *, real *, complex *, integer *), xerbla_(char *, 
	    integer *, ftnlen);


/*  -- LAPACK routine (version 3.0) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/*     Courant Institute, Argonne National Lab, and Rice University */
/*     February 29, 1992 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  CPBTF2 computes the Cholesky factorization of a complex Hermitian */
/*  positive definite band matrix A. */

/*  The factorization has the form */
/*     A = U' * U ,  if UPLO = 'U', or */
/*     A = L  * L',  if UPLO = 'L', */
/*  where U is an upper triangular matrix, U' is the conjugate transpose */
/*  of U, and L is lower triangular. */

/*  This is the unblocked version of the algorithm, calling Level 2 BLAS. */

/*  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 order of the matrix A.  N >= 0. */

/*  KD      (input) INTEGER */
/*          The number of super-diagonals of the matrix A if UPLO = 'U', */
/*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0. */

/*  AB      (input/output) COMPLEX array, dimension (LDAB,N) */
/*          On entry, 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). */

/*          On exit, if INFO = 0, the triangular factor U or L from the */
/*          Cholesky factorization A = U'*U or A = L*L' of the band */
/*          matrix A, in the same storage format as A. */

/*  LDAB    (input) INTEGER */
/*          The leading dimension of the array AB.  LDAB >= KD+1. */

/*  INFO    (output) INTEGER */
/*          = 0: successful exit */
/*          < 0: if INFO = -k, the k-th argument had an illegal value */
/*          > 0: if INFO = k, the leading minor of order k is not */
/*               positive definite, and the factorization could not be */
/*               completed. */

/*  Further Details */
/*  =============== */

/*  The band storage scheme is illustrated by the following example, when */
/*  N = 6, KD = 2, and UPLO = 'U': */

/*  On entry:                       On exit: */

/*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46 */
/*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56 */
/*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66 */

/*  Similarly, if UPLO = 'L' the format of A is as follows: */

/*  On entry:                       On exit: */

/*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66 */
/*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   * */
/*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    * */

/*  Array elements marked * are not used by the routine. */

/*  ===================================================================== */

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Test the input parameters. */

    /* Parameter adjustments */
    ab_dim1 = *ldab;
    ab_offset = 1 + ab_dim1;
    ab -= ab_offset;

    /* Function Body */
    *info = 0;
    upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
    if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*kd < 0) {
	*info = -3;
    } else if (*ldab < *kd + 1) {
	*info = -5;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("CPBTF2", &i__1, (ftnlen)6);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0) {
	return 0;
    }

/* Computing MAX */
    i__1 = 1, i__2 = *ldab - 1;
    kld = max(i__1,i__2);

    if (upper) {

/*        Compute the Cholesky factorization A = U'*U. */

	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {

/*           Compute U(J,J) and test for non-positive-definiteness. */

	    i__2 = *kd + 1 + j * ab_dim1;
	    ajj = ab[i__2].r;
	    if (ajj <= 0.f) {
		i__2 = *kd + 1 + j * ab_dim1;
		ab[i__2].r = ajj, ab[i__2].i = 0.f;
		goto L30;
	    }
	    ajj = sqrt(ajj);
	    i__2 = *kd + 1 + j * ab_dim1;
	    ab[i__2].r = ajj, ab[i__2].i = 0.f;

/*           Compute elements J+1:J+KN of row J and update the */
/*           trailing submatrix within the band. */

/* Computing MIN */
	    i__2 = *kd, i__3 = *n - j;
	    kn = min(i__2,i__3);
	    if (kn > 0) {
		r__1 = 1.f / ajj;
		csscal_(&kn, &r__1, &ab[*kd + (j + 1) * ab_dim1], &kld);
		clacgv_(&kn, &ab[*kd + (j + 1) * ab_dim1], &kld);
		cher_("Upper", &kn, &c_b8, &ab[*kd + (j + 1) * ab_dim1], &kld,
			 &ab[*kd + 1 + (j + 1) * ab_dim1], &kld, (ftnlen)5);
		clacgv_(&kn, &ab[*kd + (j + 1) * ab_dim1], &kld);
	    }
/* L10: */
	}
    } else {

/*        Compute the Cholesky factorization A = L*L'. */

	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {

/*           Compute L(J,J) and test for non-positive-definiteness. */

	    i__2 = j * ab_dim1 + 1;
	    ajj = ab[i__2].r;
	    if (ajj <= 0.f) {
		i__2 = j * ab_dim1 + 1;
		ab[i__2].r = ajj, ab[i__2].i = 0.f;
		goto L30;
	    }
	    ajj = sqrt(ajj);
	    i__2 = j * ab_dim1 + 1;
	    ab[i__2].r = ajj, ab[i__2].i = 0.f;

/*           Compute elements J+1:J+KN of column J and update the */
/*           trailing submatrix within the band. */

/* Computing MIN */
	    i__2 = *kd, i__3 = *n - j;
	    kn = min(i__2,i__3);
	    if (kn > 0) {
		r__1 = 1.f / ajj;
		csscal_(&kn, &r__1, &ab[j * ab_dim1 + 2], &c__1);
		cher_("Lower", &kn, &c_b8, &ab[j * ab_dim1 + 2], &c__1, &ab[(
			j + 1) * ab_dim1 + 1], &kld, (ftnlen)5);
	    }
/* L20: */
	}
    }
    return 0;

L30:
    *info = j;
    return 0;

/*     End of CPBTF2 */

} /* cpbtf2_ */
Exemplo n.º 8
0
/* Subroutine */ int cpbt01_(char *uplo, integer *n, integer *kd, complex *a, 
	integer *lda, complex *afac, integer *ldafac, real *rwork, real *
	resid)
{
    /* System generated locals */
    integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3, i__4, 
	    i__5;
    complex q__1;

    /* Builtin functions */
    double r_imag(complex *);

    /* Local variables */
    integer i__, j, k, kc, ml, mu;
    real akk, eps;
    extern /* Subroutine */ int cher_(char *, integer *, real *, complex *, 
	    integer *, complex *, integer *);
    integer klen;
    extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer 
	    *, complex *, integer *);
    extern logical lsame_(char *, char *);
    real anorm;
    extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *, 
	    complex *, integer *, complex *, integer *);
    extern doublereal clanhb_(char *, char *, integer *, integer *, complex *, 
	     integer *, real *), slamch_(char *);
    extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer 
	    *);


/*  -- LAPACK test routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  CPBT01 reconstructs a Hermitian positive definite band matrix A from */
/*  its L*L' or U'*U factorization and computes the residual */
/*     norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
/*     norm( U'*U - A ) / ( N * norm(A) * EPS ), */
/*  where EPS is the machine epsilon, L' is the conjugate transpose of */
/*  L, and U' is the conjugate transpose of U. */

/*  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 and columns of the matrix A.  N >= 0. */

/*  KD      (input) INTEGER */
/*          The number of super-diagonals of the matrix A if UPLO = 'U', */
/*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0. */

/*  A       (input) COMPLEX array, dimension (LDA,N) */
/*          The original Hermitian band matrix A.  If UPLO = 'U', the */
/*          upper triangular part of A is stored as a band matrix; if */
/*          UPLO = 'L', the lower triangular part of A is stored.  The */
/*          columns of the appropriate triangle are stored in the columns */
/*          of A and the diagonals of the triangle are stored in the rows */
/*          of A.  See CPBTRF for further details. */

/*  LDA     (input) INTEGER. */
/*          The leading dimension of the array A.  LDA >= max(1,KD+1). */

/*  AFAC    (input) COMPLEX array, dimension (LDAFAC,N) */
/*          The factored form of the matrix A.  AFAC contains the factor */
/*          L or U from the L*L' or U'*U factorization in band storage */
/*          format, as computed by CPBTRF. */

/*  LDAFAC  (input) INTEGER */
/*          The leading dimension of the array AFAC. */
/*          LDAFAC >= max(1,KD+1). */

/*  RWORK   (workspace) REAL array, dimension (N) */

/*  RESID   (output) REAL */
/*          If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
/*          If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */

/*  ===================================================================== */


/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Quick exit if N = 0. */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    afac_dim1 = *ldafac;
    afac_offset = 1 + afac_dim1;
    afac -= afac_offset;
    --rwork;

    /* Function Body */
    if (*n <= 0) {
	*resid = 0.f;
	return 0;
    }

/*     Exit with RESID = 1/EPS if ANORM = 0. */

    eps = slamch_("Epsilon");
    anorm = clanhb_("1", uplo, n, kd, &a[a_offset], lda, &rwork[1]);
    if (anorm <= 0.f) {
	*resid = 1.f / eps;
	return 0;
    }

/*     Check the imaginary parts of the diagonal elements and return with */
/*     an error code if any are nonzero. */

    if (lsame_(uplo, "U")) {
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    if (r_imag(&afac[*kd + 1 + j * afac_dim1]) != 0.f) {
		*resid = 1.f / eps;
		return 0;
	    }
/* L10: */
	}
    } else {
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    if (r_imag(&afac[j * afac_dim1 + 1]) != 0.f) {
		*resid = 1.f / eps;
		return 0;
	    }
/* L20: */
	}
    }

/*     Compute the product U'*U, overwriting U. */

    if (lsame_(uplo, "U")) {
	for (k = *n; k >= 1; --k) {
/* Computing MAX */
	    i__1 = 1, i__2 = *kd + 2 - k;
	    kc = max(i__1,i__2);
	    klen = *kd + 1 - kc;

/*           Compute the (K,K) element of the result. */

	    i__1 = klen + 1;
	    cdotc_(&q__1, &i__1, &afac[kc + k * afac_dim1], &c__1, &afac[kc + 
		    k * afac_dim1], &c__1);
	    akk = q__1.r;
	    i__1 = *kd + 1 + k * afac_dim1;
	    afac[i__1].r = akk, afac[i__1].i = 0.f;

/*           Compute the rest of column K. */

	    if (klen > 0) {
		i__1 = *ldafac - 1;
		ctrmv_("Upper", "Conjugate", "Non-unit", &klen, &afac[*kd + 1 
			+ (k - klen) * afac_dim1], &i__1, &afac[kc + k * 
			afac_dim1], &c__1);
	    }

/* L30: */
	}

/*     UPLO = 'L':  Compute the product L*L', overwriting L. */

    } else {
	for (k = *n; k >= 1; --k) {
/* Computing MIN */
	    i__1 = *kd, i__2 = *n - k;
	    klen = min(i__1,i__2);

/*           Add a multiple of column K of the factor L to each of */
/*           columns K+1 through N. */

	    if (klen > 0) {
		i__1 = *ldafac - 1;
		cher_("Lower", &klen, &c_b17, &afac[k * afac_dim1 + 2], &c__1, 
			 &afac[(k + 1) * afac_dim1 + 1], &i__1);
	    }

/*           Scale column K by the diagonal element. */

	    i__1 = k * afac_dim1 + 1;
	    akk = afac[i__1].r;
	    i__1 = klen + 1;
	    csscal_(&i__1, &akk, &afac[k * afac_dim1 + 1], &c__1);

/* L40: */
	}
    }

/*     Compute the difference  L*L' - A  or  U'*U - A. */

    if (lsame_(uplo, "U")) {
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
	    i__2 = 1, i__3 = *kd + 2 - j;
	    mu = max(i__2,i__3);
	    i__2 = *kd + 1;
	    for (i__ = mu; i__ <= i__2; ++i__) {
		i__3 = i__ + j * afac_dim1;
		i__4 = i__ + j * afac_dim1;
		i__5 = i__ + j * a_dim1;
		q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
			i__5].i;
		afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
/* L50: */
	    }
/* L60: */
	}
    } else {
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
	    i__2 = *kd + 1, i__3 = *n - j + 1;
	    ml = min(i__2,i__3);
	    i__2 = ml;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		i__3 = i__ + j * afac_dim1;
		i__4 = i__ + j * afac_dim1;
		i__5 = i__ + j * a_dim1;
		q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
			i__5].i;
		afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
/* L70: */
	    }
/* L80: */
	}
    }

/*     Compute norm( L*L' - A ) / ( N * norm(A) * EPS ) */

    *resid = clanhb_("1", uplo, n, kd, &afac[afac_offset], ldafac, &rwork[1]);

    *resid = *resid / (real) (*n) / anorm / eps;

    return 0;

/*     End of CPBT01 */

} /* cpbt01_ */
Exemplo n.º 9
0
/* Subroutine */ int cstt21_(integer *n, integer *kband, real *ad, real *ae, 
	real *sd, real *se, complex *u, integer *ldu, complex *work, real *
	rwork, real *result)
{
    /* System generated locals */
    integer u_dim1, u_offset, i__1, i__2, i__3;
    real r__1, r__2, r__3;
    complex q__1, q__2;

    /* Local variables */
    extern /* Subroutine */ int cher_(char *, integer *, real *, complex *, 
	    integer *, complex *, integer *);
    static real unfl;
    extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex *
	    , integer *, complex *, integer *, complex *, integer *);
    static real temp1, temp2;
    static integer j;
    extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, 
	    integer *, complex *, complex *, integer *, complex *, integer *, 
	    complex *, complex *, integer *);
    static real anorm, wnorm;
    extern doublereal clange_(char *, integer *, integer *, complex *, 
	    integer *, real *), clanhe_(char *, char *, integer *, 
	    complex *, integer *, real *), slamch_(char *);
    extern /* Subroutine */ int claset_(char *, integer *, integer *, complex 
	    *, complex *, complex *, integer *);
    static real ulp;


#define u_subscr(a_1,a_2) (a_2)*u_dim1 + a_1
#define u_ref(a_1,a_2) u[u_subscr(a_1,a_2)]


/*  -- LAPACK test 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   
    =======   

    CSTT21  checks a decomposition of the form   

       A = U S U*   

    where * means conjugate transpose, A is real symmetric tridiagonal,   
    U is unitary, and S is real and diagonal (if KBAND=0) or symmetric   
    tridiagonal (if KBAND=1).  Two tests are performed:   

       RESULT(1) = | A - U S U* | / ( |A| n ulp )   

       RESULT(2) = | I - UU* | / ( n ulp )   

    Arguments   
    =========   

    N       (input) INTEGER   
            The size of the matrix.  If it is zero, CSTT21 does nothing.   
            It must be at least zero.   

    KBAND   (input) INTEGER   
            The bandwidth of the matrix S.  It may only be zero or one.   
            If zero, then S is diagonal, and SE is not referenced.  If   
            one, then S is symmetric tri-diagonal.   

    AD      (input) REAL array, dimension (N)   
            The diagonal of the original (unfactored) matrix A.  A is   
            assumed to be real symmetric tridiagonal.   

    AE      (input) REAL array, dimension (N-1)   
            The off-diagonal of the original (unfactored) matrix A.  A   
            is assumed to be symmetric tridiagonal.  AE(1) is the (1,2)   
            and (2,1) element, AE(2) is the (2,3) and (3,2) element, etc.   

    SD      (input) REAL array, dimension (N)   
            The diagonal of the real (symmetric tri-) diagonal matrix S.   

    SE      (input) REAL array, dimension (N-1)   
            The off-diagonal of the (symmetric tri-) diagonal matrix S.   
            Not referenced if KBSND=0.  If KBAND=1, then AE(1) is the   
            (1,2) and (2,1) element, SE(2) is the (2,3) and (3,2)   
            element, etc.   

    U       (input) COMPLEX array, dimension (LDU, N)   
            The unitary matrix in the decomposition.   

    LDU     (input) INTEGER   
            The leading dimension of U.  LDU must be at least N.   

    WORK    (workspace) COMPLEX array, dimension (N**2)   

    RWORK   (workspace) REAL array, dimension (N)   

    RESULT  (output) REAL array, dimension (2)   
            The values computed by the two tests described above.  The   
            values are currently limited to 1/ulp, to avoid overflow.   
            RESULT(1) is always modified.   

    =====================================================================   


       1)      Constants   

       Parameter adjustments */
    --ad;
    --ae;
    --sd;
    --se;
    u_dim1 = *ldu;
    u_offset = 1 + u_dim1 * 1;
    u -= u_offset;
    --work;
    --rwork;
    --result;

    /* Function Body */
    result[1] = 0.f;
    result[2] = 0.f;
    if (*n <= 0) {
	return 0;
    }

    unfl = slamch_("Safe minimum");
    ulp = slamch_("Precision");

/*     Do Test 1   

       Copy A & Compute its 1-Norm: */

    claset_("Full", n, n, &c_b1, &c_b1, &work[1], n);

    anorm = 0.f;
    temp1 = 0.f;

    i__1 = *n - 1;
    for (j = 1; j <= i__1; ++j) {
	i__2 = (*n + 1) * (j - 1) + 1;
	i__3 = j;
	work[i__2].r = ad[i__3], work[i__2].i = 0.f;
	i__2 = (*n + 1) * (j - 1) + 2;
	i__3 = j;
	work[i__2].r = ae[i__3], work[i__2].i = 0.f;
	temp2 = (r__1 = ae[j], dabs(r__1));
/* Computing MAX */
	r__2 = anorm, r__3 = (r__1 = ad[j], dabs(r__1)) + temp1 + temp2;
	anorm = dmax(r__2,r__3);
	temp1 = temp2;
/* L10: */
    }

/* Computing 2nd power */
    i__2 = *n;
    i__1 = i__2 * i__2;
    i__3 = *n;
    work[i__1].r = ad[i__3], work[i__1].i = 0.f;
/* Computing MAX */
    r__2 = anorm, r__3 = (r__1 = ad[*n], dabs(r__1)) + temp1, r__2 = max(r__2,
	    r__3);
    anorm = dmax(r__2,unfl);

/*     Norm of A - USU* */

    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	r__1 = -sd[j];
	cher_("L", n, &r__1, &u_ref(1, j), &c__1, &work[1], n);
/* L20: */
    }

    if (*n > 1 && *kband == 1) {
	i__1 = *n - 1;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = j;
	    q__2.r = se[i__2], q__2.i = 0.f;
	    q__1.r = -q__2.r, q__1.i = -q__2.i;
	    cher2_("L", n, &q__1, &u_ref(1, j), &c__1, &u_ref(1, j + 1), &
		    c__1, &work[1], n);
/* L30: */
	}
    }

    wnorm = clanhe_("1", "L", n, &work[1], n, &rwork[1])
	    ;

    if (anorm > wnorm) {
	result[1] = wnorm / anorm / (*n * ulp);
    } else {
	if (anorm < 1.f) {
/* Computing MIN */
	    r__1 = wnorm, r__2 = *n * anorm;
	    result[1] = dmin(r__1,r__2) / anorm / (*n * ulp);
	} else {
/* Computing MIN */
	    r__1 = wnorm / anorm, r__2 = (real) (*n);
	    result[1] = dmin(r__1,r__2) / (*n * ulp);
	}
    }

/*     Do Test 2   

       Compute  UU* - I */

    cgemm_("N", "C", n, n, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu, &
	    c_b1, &work[1], n);

    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	i__2 = (*n + 1) * (j - 1) + 1;
	i__3 = (*n + 1) * (j - 1) + 1;
	q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i + 0.f;
	work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L40: */
    }

/* Computing MIN */
    r__1 = (real) (*n), r__2 = clange_("1", n, n, &work[1], n, &rwork[1]);
    result[2] = dmin(r__1,r__2) / (*n * ulp);

    return 0;

/*     End of CSTT21 */

} /* cstt21_ */
Exemplo n.º 10
0
/* Subroutine */ int cpot01_(char *uplo, integer *n, complex *a, integer *lda, 
	 complex *afac, integer *ldafac, real *rwork, real *resid)
{
    /* System generated locals */
    integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3, i__4, 
	    i__5;
    real r__1;
    complex q__1;

    /* Local variables */
    integer i__, j, k;
    complex tc;
    real tr, eps;
    real anorm;


/*  -- LAPACK test routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  CPOT01 reconstructs a Hermitian positive definite matrix  A  from */
/*  its L*L' or U'*U factorization and computes the residual */
/*     norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
/*     norm( U'*U - A ) / ( N * norm(A) * EPS ), */
/*  where EPS is the machine epsilon, L' is the conjugate transpose of L, */
/*  and U' is the conjugate transpose of U. */

/*  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 and columns of the matrix A.  N >= 0. */

/*  A       (input) COMPLEX array, dimension (LDA,N) */
/*          The original Hermitian matrix A. */

/*  LDA     (input) INTEGER */
/*          The leading dimension of the array A.  LDA >= max(1,N) */

/*  AFAC    (input/output) COMPLEX array, dimension (LDAFAC,N) */
/*          On entry, the factor L or U from the L*L' or U'*U */
/*          factorization of A. */
/*          Overwritten with the reconstructed matrix, and then with the */
/*          difference L*L' - A (or U'*U - A). */

/*  LDAFAC  (input) INTEGER */
/*          The leading dimension of the array AFAC.  LDAFAC >= max(1,N). */

/*  RWORK   (workspace) REAL array, dimension (N) */

/*  RESID   (output) REAL */
/*          If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
/*          If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */

/*  ===================================================================== */

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Quick exit if N = 0. */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    afac_dim1 = *ldafac;
    afac_offset = 1 + afac_dim1;
    afac -= afac_offset;
    --rwork;

    /* Function Body */
    if (*n <= 0) {
	*resid = 0.f;
	return 0;
    }

/*     Exit with RESID = 1/EPS if ANORM = 0. */

    eps = slamch_("Epsilon");
    anorm = clanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
    if (anorm <= 0.f) {
	*resid = 1.f / eps;
	return 0;
    }

/*     Check the imaginary parts of the diagonal elements and return with */
/*     an error code if any are nonzero. */

    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	if (r_imag(&afac[j + j * afac_dim1]) != 0.f) {
	    *resid = 1.f / eps;
	    return 0;
	}
/* L10: */
    }

/*     Compute the product U'*U, overwriting U. */

    if (lsame_(uplo, "U")) {
	for (k = *n; k >= 1; --k) {

/*           Compute the (K,K) element of the result. */

	    cdotc_(&q__1, &k, &afac[k * afac_dim1 + 1], &c__1, &afac[k * 
		    afac_dim1 + 1], &c__1);
	    tr = q__1.r;
	    i__1 = k + k * afac_dim1;
	    afac[i__1].r = tr, afac[i__1].i = 0.f;

/*           Compute the rest of column K. */

	    i__1 = k - 1;
	    ctrmv_("Upper", "Conjugate", "Non-unit", &i__1, &afac[afac_offset]
, ldafac, &afac[k * afac_dim1 + 1], &c__1);

/* L20: */
	}

/*     Compute the product L*L', overwriting L. */

    } else {
	for (k = *n; k >= 1; --k) {

/*           Add a multiple of column K of the factor L to each of */
/*           columns K+1 through N. */

	    if (k + 1 <= *n) {
		i__1 = *n - k;
		cher_("Lower", &i__1, &c_b15, &afac[k + 1 + k * afac_dim1], &
			c__1, &afac[k + 1 + (k + 1) * afac_dim1], ldafac);
	    }

/*           Scale column K by the diagonal element. */

	    i__1 = k + k * afac_dim1;
	    tc.r = afac[i__1].r, tc.i = afac[i__1].i;
	    i__1 = *n - k + 1;
	    cscal_(&i__1, &tc, &afac[k + k * afac_dim1], &c__1);

/* L30: */
	}
    }

/*     Compute the difference  L*L' - A (or U'*U - A). */

    if (lsame_(uplo, "U")) {
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = j - 1;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		i__3 = i__ + j * afac_dim1;
		i__4 = i__ + j * afac_dim1;
		i__5 = i__ + j * a_dim1;
		q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
			i__5].i;
		afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
/* L40: */
	    }
	    i__2 = j + j * afac_dim1;
	    i__3 = j + j * afac_dim1;
	    i__4 = j + j * a_dim1;
	    r__1 = a[i__4].r;
	    q__1.r = afac[i__3].r - r__1, q__1.i = afac[i__3].i;
	    afac[i__2].r = q__1.r, afac[i__2].i = q__1.i;
/* L50: */
	}
    } else {
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = j + j * afac_dim1;
	    i__3 = j + j * afac_dim1;
	    i__4 = j + j * a_dim1;
	    r__1 = a[i__4].r;
	    q__1.r = afac[i__3].r - r__1, q__1.i = afac[i__3].i;
	    afac[i__2].r = q__1.r, afac[i__2].i = q__1.i;
	    i__2 = *n;
	    for (i__ = j + 1; i__ <= i__2; ++i__) {
		i__3 = i__ + j * afac_dim1;
		i__4 = i__ + j * afac_dim1;
		i__5 = i__ + j * a_dim1;
		q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
			i__5].i;
		afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
/* L60: */
	    }
/* L70: */
	}
    }

/*     Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */

    *resid = clanhe_("1", uplo, n, &afac[afac_offset], ldafac, &rwork[1]);

    *resid = *resid / (real) (*n) / anorm / eps;

    return 0;

/*     End of CPOT01 */

} /* cpot01_ */
Exemplo n.º 11
0
/* Subroutine */ int chet21_(integer *itype, char *uplo, integer *n, integer *
	kband, complex *a, integer *lda, real *d__, real *e, complex *u, 
	integer *ldu, complex *v, integer *ldv, complex *tau, complex *work, 
	real *rwork, real *result)
{
    /* System generated locals */
    integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2, 
	    i__3, i__4, i__5, i__6;
    real r__1, r__2;
    complex q__1, q__2, q__3;

    /* Local variables */
    integer j, jr;
    real ulp;
    extern /* Subroutine */ int cher_(char *, integer *, real *, complex *, 
	    integer *, complex *, integer *);
    integer jcol;
    real unfl;
    integer jrow;
    extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *, integer *), 
	    cgemm_(char *, char *, integer *, integer *, integer *, complex *, 
	     complex *, integer *, complex *, integer *, complex *, complex *, 
	     integer *);
    extern logical lsame_(char *, char *);
    integer iinfo;
    real anorm;
    char cuplo[1];
    complex vsave;
    logical lower;
    real wnorm;
    extern /* Subroutine */ int cunm2l_(char *, char *, integer *, integer *, 
	    integer *, complex *, integer *, complex *, complex *, integer *, 
	    complex *, integer *), cunm2r_(char *, char *, 
	    integer *, integer *, integer *, complex *, integer *, complex *, 
	    complex *, integer *, complex *, integer *);
    extern doublereal clange_(char *, integer *, integer *, complex *, 
	    integer *, real *), clanhe_(char *, char *, integer *, 
	    complex *, integer *, real *), slamch_(char *);
    extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex 
	    *, integer *, complex *, integer *), claset_(char *, 
	    integer *, integer *, complex *, complex *, complex *, integer *), clarfy_(char *, integer *, complex *, integer *, complex 
	    *, complex *, integer *, complex *);


/*  -- LAPACK test routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  CHET21 generally checks a decomposition of the form */

/*     A = U S U* */

/*  where * means conjugate transpose, A is hermitian, U is unitary, and */
/*  S is diagonal (if KBAND=0) or (real) symmetric tridiagonal (if */
/*  KBAND=1). */

/*  If ITYPE=1, then U is represented as a dense matrix; otherwise U is */
/*  expressed as a product of Householder transformations, whose vectors */
/*  are stored in the array "V" and whose scaling constants are in "TAU". */
/*  We shall use the letter "V" to refer to the product of Householder */
/*  transformations (which should be equal to U). */

/*  Specifically, if ITYPE=1, then: */

/*     RESULT(1) = | A - U S U* | / ( |A| n ulp ) *and* */
/*     RESULT(2) = | I - UU* | / ( n ulp ) */

/*  If ITYPE=2, then: */

/*     RESULT(1) = | A - V S V* | / ( |A| n ulp ) */

/*  If ITYPE=3, then: */

/*     RESULT(1) = | I - UV* | / ( n ulp ) */

/*  For ITYPE > 1, the transformation U is expressed as a product */
/*  V = H(1)...H(n-2),  where H(j) = I  -  tau(j) v(j) v(j)*  and each */
/*  vector v(j) has its first j elements 0 and the remaining n-j elements */
/*  stored in V(j+1:n,j). */

/*  Arguments */
/*  ========= */

/*  ITYPE   (input) INTEGER */
/*          Specifies the type of tests to be performed. */
/*          1: U expressed as a dense unitary matrix: */
/*             RESULT(1) = | A - U S U* | / ( |A| n ulp )   *and* */
/*             RESULT(2) = | I - UU* | / ( n ulp ) */

/*          2: U expressed as a product V of Housholder transformations: */
/*             RESULT(1) = | A - V S V* | / ( |A| n ulp ) */

/*          3: U expressed both as a dense unitary matrix and */
/*             as a product of Housholder transformations: */
/*             RESULT(1) = | I - UV* | / ( n ulp ) */

/*  UPLO    (input) CHARACTER */
/*          If UPLO='U', the upper triangle of A and V will be used and */
/*          the (strictly) lower triangle will not be referenced. */
/*          If UPLO='L', the lower triangle of A and V will be used and */
/*          the (strictly) upper triangle will not be referenced. */

/*  N       (input) INTEGER */
/*          The size of the matrix.  If it is zero, CHET21 does nothing. */
/*          It must be at least zero. */

/*  KBAND   (input) INTEGER */
/*          The bandwidth of the matrix.  It may only be zero or one. */
/*          If zero, then S is diagonal, and E is not referenced.  If */
/*          one, then S is symmetric tri-diagonal. */

/*  A       (input) COMPLEX array, dimension (LDA, N) */
/*          The original (unfactored) matrix.  It is assumed to be */
/*          hermitian, and only the upper (UPLO='U') or only the lower */
/*          (UPLO='L') will be referenced. */

/*  LDA     (input) INTEGER */
/*          The leading dimension of A.  It must be at least 1 */
/*          and at least N. */

/*  D       (input) REAL array, dimension (N) */
/*          The diagonal of the (symmetric tri-) diagonal matrix. */

/*  E       (input) REAL array, dimension (N-1) */
/*          The off-diagonal of the (symmetric tri-) diagonal matrix. */
/*          E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and */
/*          (3,2) element, etc. */
/*          Not referenced if KBAND=0. */

/*  U       (input) COMPLEX array, dimension (LDU, N) */
/*          If ITYPE=1 or 3, this contains the unitary matrix in */
/*          the decomposition, expressed as a dense matrix.  If ITYPE=2, */
/*          then it is not referenced. */

/*  LDU     (input) INTEGER */
/*          The leading dimension of U.  LDU must be at least N and */
/*          at least 1. */

/*  V       (input) COMPLEX array, dimension (LDV, N) */
/*          If ITYPE=2 or 3, the columns of this array contain the */
/*          Householder vectors used to describe the unitary matrix */
/*          in the decomposition.  If UPLO='L', then the vectors are in */
/*          the lower triangle, if UPLO='U', then in the upper */
/*          triangle. */
/*          *NOTE* If ITYPE=2 or 3, V is modified and restored.  The */
/*          subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U') */
/*          is set to one, and later reset to its original value, during */
/*          the course of the calculation. */
/*          If ITYPE=1, then it is neither referenced nor modified. */

/*  LDV     (input) INTEGER */
/*          The leading dimension of V.  LDV must be at least N and */
/*          at least 1. */

/*  TAU     (input) COMPLEX array, dimension (N) */
/*          If ITYPE >= 2, then TAU(j) is the scalar factor of */
/*          v(j) v(j)* in the Householder transformation H(j) of */
/*          the product  U = H(1)...H(n-2) */
/*          If ITYPE < 2, then TAU is not referenced. */

/*  WORK    (workspace) COMPLEX array, dimension (2*N**2) */

/*  RWORK   (workspace) REAL array, dimension (N) */

/*  RESULT  (output) REAL array, dimension (2) */
/*          The values computed by the two tests described above.  The */
/*          values are currently limited to 1/ulp, to avoid overflow. */
/*          RESULT(1) is always modified.  RESULT(2) is modified only */
/*          if ITYPE=1. */

/*  ===================================================================== */

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    --d__;
    --e;
    u_dim1 = *ldu;
    u_offset = 1 + u_dim1;
    u -= u_offset;
    v_dim1 = *ldv;
    v_offset = 1 + v_dim1;
    v -= v_offset;
    --tau;
    --work;
    --rwork;
    --result;

    /* Function Body */
    result[1] = 0.f;
    if (*itype == 1) {
	result[2] = 0.f;
    }
    if (*n <= 0) {
	return 0;
    }

    if (lsame_(uplo, "U")) {
	lower = FALSE_;
	*(unsigned char *)cuplo = 'U';
    } else {
	lower = TRUE_;
	*(unsigned char *)cuplo = 'L';
    }

    unfl = slamch_("Safe minimum");
    ulp = slamch_("Epsilon") * slamch_("Base");

/*     Some Error Checks */

    if (*itype < 1 || *itype > 3) {
	result[1] = 10.f / ulp;
	return 0;
    }

/*     Do Test 1 */

/*     Norm of A: */

    if (*itype == 3) {
	anorm = 1.f;
    } else {
/* Computing MAX */
	r__1 = clanhe_("1", cuplo, n, &a[a_offset], lda, &rwork[1]);
	anorm = dmax(r__1,unfl);
    }

/*     Compute error matrix: */

    if (*itype == 1) {

/*        ITYPE=1: error = A - U S U* */

	claset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
	clacpy_(cuplo, n, n, &a[a_offset], lda, &work[1], n);

	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    r__1 = -d__[j];
	    cher_(cuplo, n, &r__1, &u[j * u_dim1 + 1], &c__1, &work[1], n);
/* L10: */
	}

	if (*n > 1 && *kband == 1) {
	    i__1 = *n - 1;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = j;
		q__2.r = e[i__2], q__2.i = 0.f;
		q__1.r = -q__2.r, q__1.i = -q__2.i;
		cher2_(cuplo, n, &q__1, &u[j * u_dim1 + 1], &c__1, &u[(j - 1) 
			* u_dim1 + 1], &c__1, &work[1], n);
/* L20: */
	    }
	}
	wnorm = clanhe_("1", cuplo, n, &work[1], n, &rwork[1]);

    } else if (*itype == 2) {

/*        ITYPE=2: error = V S V* - A */

	claset_("Full", n, n, &c_b1, &c_b1, &work[1], n);

	if (lower) {
/* Computing 2nd power */
	    i__2 = *n;
	    i__1 = i__2 * i__2;
	    i__3 = *n;
	    work[i__1].r = d__[i__3], work[i__1].i = 0.f;
	    for (j = *n - 1; j >= 1; --j) {
		if (*kband == 1) {
		    i__1 = (*n + 1) * (j - 1) + 2;
		    i__2 = j;
		    q__2.r = 1.f - tau[i__2].r, q__2.i = 0.f - tau[i__2].i;
		    i__3 = j;
		    q__1.r = e[i__3] * q__2.r, q__1.i = e[i__3] * q__2.i;
		    work[i__1].r = q__1.r, work[i__1].i = q__1.i;
		    i__1 = *n;
		    for (jr = j + 2; jr <= i__1; ++jr) {
			i__2 = (j - 1) * *n + jr;
			i__3 = j;
			q__3.r = -tau[i__3].r, q__3.i = -tau[i__3].i;
			i__4 = j;
			q__2.r = e[i__4] * q__3.r, q__2.i = e[i__4] * q__3.i;
			i__5 = jr + j * v_dim1;
			q__1.r = q__2.r * v[i__5].r - q__2.i * v[i__5].i, 
				q__1.i = q__2.r * v[i__5].i + q__2.i * v[i__5]
				.r;
			work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L30: */
		    }
		}

		i__1 = j + 1 + j * v_dim1;
		vsave.r = v[i__1].r, vsave.i = v[i__1].i;
		i__1 = j + 1 + j * v_dim1;
		v[i__1].r = 1.f, v[i__1].i = 0.f;
		i__1 = *n - j;
/* Computing 2nd power */
		i__2 = *n;
		clarfy_("L", &i__1, &v[j + 1 + j * v_dim1], &c__1, &tau[j], &
			work[(*n + 1) * j + 1], n, &work[i__2 * i__2 + 1]);
		i__1 = j + 1 + j * v_dim1;
		v[i__1].r = vsave.r, v[i__1].i = vsave.i;
		i__1 = (*n + 1) * (j - 1) + 1;
		i__2 = j;
		work[i__1].r = d__[i__2], work[i__1].i = 0.f;
/* L40: */
	    }
	} else {
	    work[1].r = d__[1], work[1].i = 0.f;
	    i__1 = *n - 1;
	    for (j = 1; j <= i__1; ++j) {
		if (*kband == 1) {
		    i__2 = (*n + 1) * j;
		    i__3 = j;
		    q__2.r = 1.f - tau[i__3].r, q__2.i = 0.f - tau[i__3].i;
		    i__4 = j;
		    q__1.r = e[i__4] * q__2.r, q__1.i = e[i__4] * q__2.i;
		    work[i__2].r = q__1.r, work[i__2].i = q__1.i;
		    i__2 = j - 1;
		    for (jr = 1; jr <= i__2; ++jr) {
			i__3 = j * *n + jr;
			i__4 = j;
			q__3.r = -tau[i__4].r, q__3.i = -tau[i__4].i;
			i__5 = j;
			q__2.r = e[i__5] * q__3.r, q__2.i = e[i__5] * q__3.i;
			i__6 = jr + (j + 1) * v_dim1;
			q__1.r = q__2.r * v[i__6].r - q__2.i * v[i__6].i, 
				q__1.i = q__2.r * v[i__6].i + q__2.i * v[i__6]
				.r;
			work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L50: */
		    }
		}

		i__2 = j + (j + 1) * v_dim1;
		vsave.r = v[i__2].r, vsave.i = v[i__2].i;
		i__2 = j + (j + 1) * v_dim1;
		v[i__2].r = 1.f, v[i__2].i = 0.f;
/* Computing 2nd power */
		i__2 = *n;
		clarfy_("U", &j, &v[(j + 1) * v_dim1 + 1], &c__1, &tau[j], &
			work[1], n, &work[i__2 * i__2 + 1]);
		i__2 = j + (j + 1) * v_dim1;
		v[i__2].r = vsave.r, v[i__2].i = vsave.i;
		i__2 = (*n + 1) * j + 1;
		i__3 = j + 1;
		work[i__2].r = d__[i__3], work[i__2].i = 0.f;
/* L60: */
	    }
	}

	i__1 = *n;
	for (jcol = 1; jcol <= i__1; ++jcol) {
	    if (lower) {
		i__2 = *n;
		for (jrow = jcol; jrow <= i__2; ++jrow) {
		    i__3 = jrow + *n * (jcol - 1);
		    i__4 = jrow + *n * (jcol - 1);
		    i__5 = jrow + jcol * a_dim1;
		    q__1.r = work[i__4].r - a[i__5].r, q__1.i = work[i__4].i 
			    - a[i__5].i;
		    work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L70: */
		}
	    } else {
		i__2 = jcol;
		for (jrow = 1; jrow <= i__2; ++jrow) {
		    i__3 = jrow + *n * (jcol - 1);
		    i__4 = jrow + *n * (jcol - 1);
		    i__5 = jrow + jcol * a_dim1;
		    q__1.r = work[i__4].r - a[i__5].r, q__1.i = work[i__4].i 
			    - a[i__5].i;
		    work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L80: */
		}
	    }
/* L90: */
	}
	wnorm = clanhe_("1", cuplo, n, &work[1], n, &rwork[1]);

    } else if (*itype == 3) {

/*        ITYPE=3: error = U V* - I */

	if (*n < 2) {
	    return 0;
	}
	clacpy_(" ", n, n, &u[u_offset], ldu, &work[1], n);
	if (lower) {
	    i__1 = *n - 1;
	    i__2 = *n - 1;
/* Computing 2nd power */
	    i__3 = *n;
	    cunm2r_("R", "C", n, &i__1, &i__2, &v[v_dim1 + 2], ldv, &tau[1], &
		    work[*n + 1], n, &work[i__3 * i__3 + 1], &iinfo);
	} else {
	    i__1 = *n - 1;
	    i__2 = *n - 1;
/* Computing 2nd power */
	    i__3 = *n;
	    cunm2l_("R", "C", n, &i__1, &i__2, &v[(v_dim1 << 1) + 1], ldv, &
		    tau[1], &work[1], n, &work[i__3 * i__3 + 1], &iinfo);
	}
	if (iinfo != 0) {
	    result[1] = 10.f / ulp;
	    return 0;
	}

	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = (*n + 1) * (j - 1) + 1;
	    i__3 = (*n + 1) * (j - 1) + 1;
	    q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i - 0.f;
	    work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L100: */
	}

	wnorm = clange_("1", n, n, &work[1], n, &rwork[1]);
    }

    if (anorm > wnorm) {
	result[1] = wnorm / anorm / (*n * ulp);
    } else {
	if (anorm < 1.f) {
/* Computing MIN */
	    r__1 = wnorm, r__2 = *n * anorm;
	    result[1] = dmin(r__1,r__2) / anorm / (*n * ulp);
	} else {
/* Computing MIN */
	    r__1 = wnorm / anorm, r__2 = (real) (*n);
	    result[1] = dmin(r__1,r__2) / (*n * ulp);
	}
    }

/*     Do Test 2 */

/*     Compute  UU* - I */

    if (*itype == 1) {
	cgemm_("N", "C", n, n, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu, 
		 &c_b1, &work[1], n);

	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = (*n + 1) * (j - 1) + 1;
	    i__3 = (*n + 1) * (j - 1) + 1;
	    q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i - 0.f;
	    work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L110: */
	}

/* Computing MIN */
	r__1 = clange_("1", n, n, &work[1], n, &rwork[1]), r__2 = (
		real) (*n);
	result[2] = dmin(r__1,r__2) / (*n * ulp);
    }

    return 0;

/*     End of CHET21 */

} /* chet21_ */