void cblas_dspr(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
                const integer N, const double alpha, const double *X,
                const integer incX, double *Ap)
{
   char UL;
#ifdef F77_CHAR
   F77_CHAR F77_UL;
#else
   #define F77_UL &UL
#endif

   #define F77_N N
   #define F77_incX incX
   extern integer CBLAS_CallFromC;
   extern integer RowMajorStrg;
   RowMajorStrg = 0;
   CBLAS_CallFromC = 1;
   if (order == CblasColMajor)
   {
      if (Uplo == CblasLower) UL = 'L';
      else if (Uplo == CblasUpper) UL = 'U';
      else 
      {
         cblas_xerbla(2, "cblas_dspr","Illegal Uplo setting, %d\n",Uplo );
         CBLAS_CallFromC = 0;
         RowMajorStrg = 0;
         return;
      }
      #ifdef F77_CHAR
         F77_UL = C2F_CHAR(&UL);
      #endif

      dspr_(F77_UL, &F77_N, &alpha, X, &F77_incX, Ap);

   }  else if (order == CblasRowMajor) 
   {
      RowMajorStrg = 1;
      if (Uplo == CblasLower) UL = 'U';
      else if (Uplo == CblasUpper) UL = 'L';
      else 
      {
         cblas_xerbla(2, "cblas_dspr","Illegal Uplo setting, %d\n",Uplo );
         CBLAS_CallFromC = 0;
         RowMajorStrg = 0;
         return;
      }
      #ifdef F77_CHAR
         F77_UL = C2F_CHAR(&UL);
      #endif  
      dspr_(F77_UL, &F77_N, &alpha, X, &F77_incX, Ap); 
   } else cblas_xerbla(1, "cblas_dspr", "Illegal Order setting, %d\n", order);
   CBLAS_CallFromC = 0;
   RowMajorStrg = 0;
   return;
}
Beispiel #2
0
int
f2c_dspr(char* uplo, integer* N,
         doublereal* alpha,
         doublereal* X, integer* incX,
         doublereal* Ap)
{
    dspr_(uplo, N, alpha, X, incX, Ap);
    return 0;
}
Beispiel #3
0
/* Subroutine */
int dpptri_(char *uplo, integer *n, doublereal *ap, integer * info)
{
    /* System generated locals */
    integer i__1, i__2;
    /* Local variables */
    integer j, jc, jj;
    doublereal ajj;
    integer jjn;
    extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *);
    extern /* Subroutine */
    int dspr_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *), dscal_(integer *, doublereal *, doublereal *, integer *);
    extern logical lsame_(char *, char *);
    extern /* Subroutine */
    int dtpmv_(char *, char *, char *, integer *, doublereal *, doublereal *, integer *);
    logical upper;
    extern /* Subroutine */
    int xerbla_(char *, integer *), dtptri_( char *, char *, integer *, doublereal *, 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 .. */
    /* .. */
    /* .. Executable Statements .. */
    /* Test the input parameters. */
    /* Parameter adjustments */
    --ap;
    /* Function Body */
    *info = 0;
    upper = lsame_(uplo, "U");
    if (! upper && ! lsame_(uplo, "L"))
    {
        *info = -1;
    }
    else if (*n < 0)
    {
        *info = -2;
    }
    if (*info != 0)
    {
        i__1 = -(*info);
        xerbla_("DPPTRI", &i__1);
        return 0;
    }
    /* Quick return if possible */
    if (*n == 0)
    {
        return 0;
    }
    /* Invert the triangular Cholesky factor U or L. */
    dtptri_(uplo, "Non-unit", n, &ap[1], info);
    if (*info > 0)
    {
        return 0;
    }
    if (upper)
    {
        /* Compute the product inv(U) * inv(U)**T. */
        jj = 0;
        i__1 = *n;
        for (j = 1;
                j <= i__1;
                ++j)
        {
            jc = jj + 1;
            jj += j;
            if (j > 1)
            {
                i__2 = j - 1;
                dspr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1]);
            }
            ajj = ap[jj];
            dscal_(&j, &ajj, &ap[jc], &c__1);
            /* L10: */
        }
    }
    else
    {
        /* Compute the product inv(L)**T * inv(L). */
        jj = 1;
        i__1 = *n;
        for (j = 1;
                j <= i__1;
                ++j)
        {
            jjn = jj + *n - j + 1;
            i__2 = *n - j + 1;
            ap[jj] = ddot_(&i__2, &ap[jj], &c__1, &ap[jj], &c__1);
            if (j < *n)
            {
                i__2 = *n - j;
                dtpmv_("Lower", "Transpose", "Non-unit", &i__2, &ap[jjn], &ap[ jj + 1], &c__1);
            }
            jj = jjn;
            /* L20: */
        }
    }
    return 0;
    /* End of DPPTRI */
}
Beispiel #4
0
/*<       SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO ) >*/
/* Subroutine */ int dsptrf_(char *uplo, integer *n, doublereal *ap, integer *ipiv, 
integer *info, ftnlen uplo_len)
{
    /* System generated locals */
    integer i__1;
    doublereal d__1, d__2, d__3;

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

    /* Local variables */
    doublereal c__;
    integer j, k;
    doublereal s, t, r1, r2;
    integer kc, kk, kp, kx, knc, kpc=0, npp, imax=0, jmax;
    extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, 
	    doublereal *, integer *, doublereal *, doublereal *), dspr_(char *
	    , integer *, doublereal *, doublereal *, integer *, doublereal *, 
	    ftnlen);
    doublereal alpha;
    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
	    integer *);
    extern logical lsame_(const char *, const char *, ftnlen, ftnlen);
    extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, 
	    doublereal *, integer *);
    integer kstep;
    logical upper;
    extern /* Subroutine */ int dlaev2_(doublereal *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *);
    doublereal absakk;
    extern integer idamax_(integer *, doublereal *, integer *);
    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
    doublereal colmax, rowmax;
    (void)uplo_len;

/*  -- LAPACK routine (version 2.0) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/*     Courant Institute, Argonne National Lab, and Rice University */
/*     March 31, 1993 */

/*     .. Scalar Arguments .. */
/*<       CHARACTER          UPLO >*/
/*<       INTEGER            INFO, N >*/
/*     .. */
/*     .. Array Arguments .. */
/*<       INTEGER            IPIV( * ) >*/
/*<       DOUBLE PRECISION   AP( * ) >*/
/*     .. */

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

/*  DSPTRF computes the factorization of a real symmetric matrix A stored */
/*  in packed format using the Bunch-Kaufman diagonal pivoting method: */

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

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

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

/*  UPLO    (input) CHARACTER*1 */
/*          = 'U':  Upper triangle of A is stored; */
/*          = 'L':  Lower triangle of A is stored. */

/*  N       (input) INTEGER */
/*          The order of the matrix A.  N >= 0. */

/*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/*          On entry, the upper or lower triangle of the symmetric matrix */
/*          A, packed columnwise in a linear array.  The j-th column of A */
/*          is stored in the array AP as follows: */
/*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */

/*          On exit, the block diagonal matrix D and the multipliers used */
/*          to obtain the factor U or L, stored as a packed triangular */
/*          matrix overwriting A (see below for further details). */

/*  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 = -i, the i-th argument had an illegal value */
/*          > 0: if INFO = i, D(i,i) 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 */
/*  =============== */

/*  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 .. */
/*<       DOUBLE PRECISION   ZERO, ONE >*/
/*<       PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 ) >*/
/*<       DOUBLE PRECISION   EIGHT, SEVTEN >*/
/*<       PARAMETER          ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) >*/
/*     .. */
/*     .. Local Scalars .. */
/*<       LOGICAL            UPPER >*/
/*<    >*/
/*<       DOUBLE PRECISION   ABSAKK, ALPHA, C, COLMAX, R1, R2, ROWMAX, S, T >*/
/*     .. */
/*     .. External Functions .. */
/*<       LOGICAL            LSAME >*/
/*<       INTEGER            IDAMAX >*/
/*<       EXTERNAL           LSAME, IDAMAX >*/
/*     .. */
/*     .. External Subroutines .. */
/*<       EXTERNAL           DLAEV2, DROT, DSCAL, DSPR, DSWAP, XERBLA >*/
/*     .. */
/*     .. Intrinsic Functions .. */
/*<       INTRINSIC          ABS, MAX, SQRT >*/
/*     .. */
/*     .. Executable Statements .. */

/*     Test the input parameters. */

/*<       INFO = 0 >*/
    /* Parameter adjustments */
    --ipiv;
    --ap;

    /* Function Body */
    *info = 0;
/*<       UPPER = LSAME( UPLO, 'U' ) >*/
    upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
/*<       IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN >*/
    if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
/*<          INFO = -1 >*/
	*info = -1;
/*<       ELSE IF( N.LT.0 ) THEN >*/
    } else if (*n < 0) {
/*<          INFO = -2 >*/
	*info = -2;
/*<       END IF >*/
    }
/*<       IF( INFO.NE.0 ) THEN >*/
    if (*info != 0) {
/*<          CALL XERBLA( 'DSPTRF', -INFO ) >*/
	i__1 = -(*info);
	xerbla_("DSPTRF", &i__1, (ftnlen)6);
/*<          RETURN >*/
	return 0;
/*<       END IF >*/
    }

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

/*<       ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT >*/
    alpha = (sqrt(17.) + 1.) / 8.;

/*<       IF( UPPER ) THEN >*/
    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 >*/
	k = *n;
/*<          KC = ( N-1 )*N / 2 + 1 >*/
	kc = (*n - 1) * *n / 2 + 1;
/*<    10    CONTINUE >*/
L10:
/*<          KNC = KC >*/
	knc = kc;

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

/*<    >*/
	if (k < 1) {
	    goto L70;
	}
/*<          KSTEP = 1 >*/
	kstep = 1;

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

/*<          ABSAKK = ABS( AP( KC+K-1 ) ) >*/
	absakk = (d__1 = ap[kc + k - 1], abs(d__1));

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

/*<          IF( K.GT.1 ) THEN >*/
	if (k > 1) {
/*<             IMAX = IDAMAX( K-1, AP( KC ), 1 ) >*/
	    i__1 = k - 1;
	    imax = idamax_(&i__1, &ap[kc], &c__1);
/*<             COLMAX = ABS( AP( KC+IMAX-1 ) ) >*/
	    colmax = (d__1 = ap[kc + imax - 1], abs(d__1));
/*<          ELSE >*/
	} else {
/*<             COLMAX = ZERO >*/
	    colmax = 0.;
/*<          END IF >*/
	}

/*<          IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN >*/
	if (max(absakk,colmax) == 0.) {

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

/*<    >*/
	    if (*info == 0) {
		*info = k;
	    }
/*<             KP = K >*/
	    kp = k;
/*<          ELSE >*/
	} else {
/*<             IF( ABSAKK.GE.ALPHA*COLMAX ) THEN >*/
	    if (absakk >= alpha * colmax) {

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

/*<                KP = K >*/
		kp = k;
/*<             ELSE >*/
	    } else {

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

/*<                ROWMAX = ZERO >*/
		rowmax = 0.;
/*<                JMAX = IMAX >*/
		jmax = imax;
/*<                KX = IMAX*( IMAX+1 ) / 2 + IMAX >*/
		kx = imax * (imax + 1) / 2 + imax;
/*<                DO 20 J = IMAX + 1, K >*/
		i__1 = k;
		for (j = imax + 1; j <= i__1; ++j) {
/*<                   IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN >*/
		    if ((d__1 = ap[kx], abs(d__1)) > rowmax) {
/*<                      ROWMAX = ABS( AP( KX ) ) >*/
			rowmax = (d__1 = ap[kx], abs(d__1));
/*<                      JMAX = J >*/
			jmax = j;
/*<                   END IF >*/
		    }
/*<                   KX = KX + J >*/
		    kx += j;
/*<    20          CONTINUE >*/
/* L20: */
		}
/*<                KPC = ( IMAX-1 )*IMAX / 2 + 1 >*/
		kpc = (imax - 1) * imax / 2 + 1;
/*<                IF( IMAX.GT.1 ) THEN >*/
		if (imax > 1) {
/*<                   JMAX = IDAMAX( IMAX-1, AP( KPC ), 1 ) >*/
		    i__1 = imax - 1;
		    jmax = idamax_(&i__1, &ap[kpc], &c__1);
/*<                   ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-1 ) ) ) >*/
/* Computing MAX */
		    d__2 = rowmax, d__3 = (d__1 = ap[kpc + jmax - 1], abs(
			    d__1));
		    rowmax = max(d__2,d__3);
/*<                END IF >*/
		}

/*<                IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN >*/
		if (absakk >= alpha * colmax * (colmax / rowmax)) {

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

/*<                   KP = K >*/
		    kp = k;
/*<                ELSE IF( ABS( AP( KPC+IMAX-1 ) ).GE.ALPHA*ROWMAX ) THEN >*/
		} else if ((d__1 = ap[kpc + imax - 1], abs(d__1)) >= alpha * 
			rowmax) {

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

/*<                   KP = IMAX >*/
		    kp = imax;
/*<                ELSE >*/
		} else {

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

/*<                   KP = IMAX >*/
		    kp = imax;
/*<                   KSTEP = 2 >*/
		    kstep = 2;
/*<                END IF >*/
		}
/*<             END IF >*/
	    }

/*<             KK = K - KSTEP + 1 >*/
	    kk = k - kstep + 1;
/*<    >*/
	    if (kstep == 2) {
		knc = knc - k + 1;
	    }
/*<             IF( KP.NE.KK ) THEN >*/
	    if (kp != kk) {

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

/*<                CALL DSWAP( KP-1, AP( KNC ), 1, AP( KPC ), 1 ) >*/
		i__1 = kp - 1;
		dswap_(&i__1, &ap[knc], &c__1, &ap[kpc], &c__1);
/*<                KX = KPC + KP - 1 >*/
		kx = kpc + kp - 1;
/*<                DO 30 J = KP + 1, KK - 1 >*/
		i__1 = kk - 1;
		for (j = kp + 1; j <= i__1; ++j) {
/*<                   KX = KX + J - 1 >*/
		    kx = kx + j - 1;
/*<                   T = AP( KNC+J-1 ) >*/
		    t = ap[knc + j - 1];
/*<                   AP( KNC+J-1 ) = AP( KX ) >*/
		    ap[knc + j - 1] = ap[kx];
/*<                   AP( KX ) = T >*/
		    ap[kx] = t;
/*<    30          CONTINUE >*/
/* L30: */
		}
/*<                T = AP( KNC+KK-1 ) >*/
		t = ap[knc + kk - 1];
/*<                AP( KNC+KK-1 ) = AP( KPC+KP-1 ) >*/
		ap[knc + kk - 1] = ap[kpc + kp - 1];
/*<                AP( KPC+KP-1 ) = T >*/
		ap[kpc + kp - 1] = t;
/*<                IF( KSTEP.EQ.2 ) THEN >*/
		if (kstep == 2) {
/*<                   T = AP( KC+K-2 ) >*/
		    t = ap[kc + k - 2];
/*<                   AP( KC+K-2 ) = AP( KC+KP-1 ) >*/
		    ap[kc + k - 2] = ap[kc + kp - 1];
/*<                   AP( KC+KP-1 ) = T >*/
		    ap[kc + kp - 1] = t;
/*<                END IF >*/
		}
/*<             END IF >*/
	    }

/*           Update the leading submatrix */

/*<             IF( KSTEP.EQ.1 ) THEN >*/
	    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)' */

/*<                R1 = ONE / AP( KC+K-1 ) >*/
		r1 = 1. / ap[kc + k - 1];
/*<                CALL DSPR( UPLO, K-1, -R1, AP( KC ), 1, AP ) >*/
		i__1 = k - 1;
		d__1 = -r1;
		dspr_(uplo, &i__1, &d__1, &ap[kc], &c__1, &ap[1], (ftnlen)1);

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

/*<                CALL DSCAL( K-1, R1, AP( KC ), 1 ) >*/
		i__1 = k - 1;
		dscal_(&i__1, &r1, &ap[kc], &c__1);
/*<             ELSE >*/
	    } 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) )' */

/*              Convert this to two rank-1 updates by using the eigen- */
/*              decomposition of D(k) */

/*<    >*/
		dlaev2_(&ap[kc - 1], &ap[kc + k - 2], &ap[kc + k - 1], &r1, &
			r2, &c__, &s);
/*<                R1 = ONE / R1 >*/
		r1 = 1. / r1;
/*<                R2 = ONE / R2 >*/
		r2 = 1. / r2;
/*<                CALL DROT( K-2, AP( KNC ), 1, AP( KC ), 1, C, S ) >*/
		i__1 = k - 2;
		drot_(&i__1, &ap[knc], &c__1, &ap[kc], &c__1, &c__, &s);
/*<                CALL DSPR( UPLO, K-2, -R1, AP( KNC ), 1, AP ) >*/
		i__1 = k - 2;
		d__1 = -r1;
		dspr_(uplo, &i__1, &d__1, &ap[knc], &c__1, &ap[1], (ftnlen)1);
/*<                CALL DSPR( UPLO, K-2, -R2, AP( KC ), 1, AP ) >*/
		i__1 = k - 2;
		d__1 = -r2;
		dspr_(uplo, &i__1, &d__1, &ap[kc], &c__1, &ap[1], (ftnlen)1);

/*              Store U(k) and U(k-1) in columns k and k-1 */

/*<                CALL DSCAL( K-2, R1, AP( KNC ), 1 ) >*/
		i__1 = k - 2;
		dscal_(&i__1, &r1, &ap[knc], &c__1);
/*<                CALL DSCAL( K-2, R2, AP( KC ), 1 ) >*/
		i__1 = k - 2;
		dscal_(&i__1, &r2, &ap[kc], &c__1);
/*<                CALL DROT( K-2, AP( KNC ), 1, AP( KC ), 1, C, -S ) >*/
		i__1 = k - 2;
		d__1 = -s;
		drot_(&i__1, &ap[knc], &c__1, &ap[kc], &c__1, &c__, &d__1);
/*<             END IF >*/
	    }
/*<          END IF >*/
	}

/*        Store details of the interchanges in IPIV */

/*<          IF( KSTEP.EQ.1 ) THEN >*/
	if (kstep == 1) {
/*<             IPIV( K ) = KP >*/
	    ipiv[k] = kp;
/*<          ELSE >*/
	} else {
/*<             IPIV( K ) = -KP >*/
	    ipiv[k] = -kp;
/*<             IPIV( K-1 ) = -KP >*/
	    ipiv[k - 1] = -kp;
/*<          END IF >*/
	}

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

/*<          K = K - KSTEP >*/
	k -= kstep;
/*<          KC = KNC - K >*/
	kc = knc - k;
/*<          GO TO 10 >*/
	goto L10;

/*<       ELSE >*/
    } 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 >*/
	k = 1;
/*<          KC = 1 >*/
	kc = 1;
/*<          NPP = N*( N+1 ) / 2 >*/
	npp = *n * (*n + 1) / 2;
/*<    40    CONTINUE >*/
L40:
/*<          KNC = KC >*/
	knc = kc;

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

/*<    >*/
	if (k > *n) {
	    goto L70;
	}
/*<          KSTEP = 1 >*/
	kstep = 1;

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

/*<          ABSAKK = ABS( AP( KC ) ) >*/
	absakk = (d__1 = ap[kc], abs(d__1));

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

/*<          IF( K.LT.N ) THEN >*/
	if (k < *n) {
/*<             IMAX = K + IDAMAX( N-K, AP( KC+1 ), 1 ) >*/
	    i__1 = *n - k;
	    imax = k + idamax_(&i__1, &ap[kc + 1], &c__1);
/*<             COLMAX = ABS( AP( KC+IMAX-K ) ) >*/
	    colmax = (d__1 = ap[kc + imax - k], abs(d__1));
/*<          ELSE >*/
	} else {
/*<             COLMAX = ZERO >*/
	    colmax = 0.;
/*<          END IF >*/
	}

/*<          IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN >*/
	if (max(absakk,colmax) == 0.) {

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

/*<    >*/
	    if (*info == 0) {
		*info = k;
	    }
/*<             KP = K >*/
	    kp = k;
/*<          ELSE >*/
	} else {
/*<             IF( ABSAKK.GE.ALPHA*COLMAX ) THEN >*/
	    if (absakk >= alpha * colmax) {

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

/*<                KP = K >*/
		kp = k;
/*<             ELSE >*/
	    } else {

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

/*<                ROWMAX = ZERO >*/
		rowmax = 0.;
/*<                KX = KC + IMAX - K >*/
		kx = kc + imax - k;
/*<                DO 50 J = K, IMAX - 1 >*/
		i__1 = imax - 1;
		for (j = k; j <= i__1; ++j) {
/*<                   IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN >*/
		    if ((d__1 = ap[kx], abs(d__1)) > rowmax) {
/*<                      ROWMAX = ABS( AP( KX ) ) >*/
			rowmax = (d__1 = ap[kx], abs(d__1));
/*<                      JMAX = J >*/
			jmax = j;
/*<                   END IF >*/
		    }
/*<                   KX = KX + N - J >*/
		    kx = kx + *n - j;
/*<    50          CONTINUE >*/
/* L50: */
		}
/*<                KPC = NPP - ( N-IMAX+1 )*( N-IMAX+2 ) / 2 + 1 >*/
		kpc = npp - (*n - imax + 1) * (*n - imax + 2) / 2 + 1;
/*<                IF( IMAX.LT.N ) THEN >*/
		if (imax < *n) {
/*<                   JMAX = IMAX + IDAMAX( N-IMAX, AP( KPC+1 ), 1 ) >*/
		    i__1 = *n - imax;
		    jmax = imax + idamax_(&i__1, &ap[kpc + 1], &c__1);
/*<                   ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-IMAX ) ) ) >*/
/* Computing MAX */
		    d__2 = rowmax, d__3 = (d__1 = ap[kpc + jmax - imax], abs(
			    d__1));
		    rowmax = max(d__2,d__3);
/*<                END IF >*/
		}

/*<                IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN >*/
		if (absakk >= alpha * colmax * (colmax / rowmax)) {

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

/*<                   KP = K >*/
		    kp = k;
/*<                ELSE IF( ABS( AP( KPC ) ).GE.ALPHA*ROWMAX ) THEN >*/
		} else if ((d__1 = ap[kpc], abs(d__1)) >= alpha * rowmax) {

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

/*<                   KP = IMAX >*/
		    kp = imax;
/*<                ELSE >*/
		} else {

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

/*<                   KP = IMAX >*/
		    kp = imax;
/*<                   KSTEP = 2 >*/
		    kstep = 2;
/*<                END IF >*/
		}
/*<             END IF >*/
	    }

/*<             KK = K + KSTEP - 1 >*/
	    kk = k + kstep - 1;
/*<    >*/
	    if (kstep == 2) {
		knc = knc + *n - k + 1;
	    }
/*<             IF( KP.NE.KK ) THEN >*/
	    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;
		    dswap_(&i__1, &ap[knc + kp - kk + 1], &c__1, &ap[kpc + 1],
			     &c__1);
		}
/*<                KX = KNC + KP - KK >*/
		kx = knc + kp - kk;
/*<                DO 60 J = KK + 1, KP - 1 >*/
		i__1 = kp - 1;
		for (j = kk + 1; j <= i__1; ++j) {
/*<                   KX = KX + N - J + 1 >*/
		    kx = kx + *n - j + 1;
/*<                   T = AP( KNC+J-KK ) >*/
		    t = ap[knc + j - kk];
/*<                   AP( KNC+J-KK ) = AP( KX ) >*/
		    ap[knc + j - kk] = ap[kx];
/*<                   AP( KX ) = T >*/
		    ap[kx] = t;
/*<    60          CONTINUE >*/
/* L60: */
		}
/*<                T = AP( KNC ) >*/
		t = ap[knc];
/*<                AP( KNC ) = AP( KPC ) >*/
		ap[knc] = ap[kpc];
/*<                AP( KPC ) = T >*/
		ap[kpc] = t;
/*<                IF( KSTEP.EQ.2 ) THEN >*/
		if (kstep == 2) {
/*<                   T = AP( KC+1 ) >*/
		    t = ap[kc + 1];
/*<                   AP( KC+1 ) = AP( KC+KP-K ) >*/
		    ap[kc + 1] = ap[kc + kp - k];
/*<                   AP( KC+KP-K ) = T >*/
		    ap[kc + kp - k] = t;
/*<                END IF >*/
		}
/*<             END IF >*/
	    }

/*           Update the trailing submatrix */

/*<             IF( KSTEP.EQ.1 ) THEN >*/
	    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.LT.N ) THEN >*/
		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)' */

/*<                   R1 = ONE / AP( KC ) >*/
		    r1 = 1. / ap[kc];
/*<    >*/
		    i__1 = *n - k;
		    d__1 = -r1;
		    dspr_(uplo, &i__1, &d__1, &ap[kc + 1], &c__1, &ap[kc + *n 
			    - k + 1], (ftnlen)1);

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

/*<                   CALL DSCAL( N-K, R1, AP( KC+1 ), 1 ) >*/
		    i__1 = *n - k;
		    dscal_(&i__1, &r1, &ap[kc + 1], &c__1);
/*<                END IF >*/
		}
/*<             ELSE >*/
	    } else {

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

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

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

/*<                IF( K.LT.N-1 ) THEN >*/
		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) )' */

/*                 Convert this to two rank-1 updates by using the eigen- */
/*                 decomposition of D(k) */

/*<    >*/
		    dlaev2_(&ap[kc], &ap[kc + 1], &ap[knc], &r1, &r2, &c__, &
			    s);
/*<                   R1 = ONE / R1 >*/
		    r1 = 1. / r1;
/*<                   R2 = ONE / R2 >*/
		    r2 = 1. / r2;
/*<    >*/
		    i__1 = *n - k - 1;
		    drot_(&i__1, &ap[kc + 2], &c__1, &ap[knc + 1], &c__1, &
			    c__, &s);
/*<    >*/
		    i__1 = *n - k - 1;
		    d__1 = -r1;
		    dspr_(uplo, &i__1, &d__1, &ap[kc + 2], &c__1, &ap[knc + *
			    n - k], (ftnlen)1);
/*<    >*/
		    i__1 = *n - k - 1;
		    d__1 = -r2;
		    dspr_(uplo, &i__1, &d__1, &ap[knc + 1], &c__1, &ap[knc + *
			    n - k], (ftnlen)1);

/*                 Store L(k) and L(k+1) in columns k and k+1 */

/*<                   CALL DSCAL( N-K-1, R1, AP( KC+2 ), 1 ) >*/
		    i__1 = *n - k - 1;
		    dscal_(&i__1, &r1, &ap[kc + 2], &c__1);
/*<                   CALL DSCAL( N-K-1, R2, AP( KNC+1 ), 1 ) >*/
		    i__1 = *n - k - 1;
		    dscal_(&i__1, &r2, &ap[knc + 1], &c__1);
/*<    >*/
		    i__1 = *n - k - 1;
		    d__1 = -s;
		    drot_(&i__1, &ap[kc + 2], &c__1, &ap[knc + 1], &c__1, &
			    c__, &d__1);
/*<                END IF >*/
		}
/*<             END IF >*/
	    }
/*<          END IF >*/
	}

/*        Store details of the interchanges in IPIV */

/*<          IF( KSTEP.EQ.1 ) THEN >*/
	if (kstep == 1) {
/*<             IPIV( K ) = KP >*/
	    ipiv[k] = kp;
/*<          ELSE >*/
	} else {
/*<             IPIV( K ) = -KP >*/
	    ipiv[k] = -kp;
/*<             IPIV( K+1 ) = -KP >*/
	    ipiv[k + 1] = -kp;
/*<          END IF >*/
	}

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

/*<          K = K + KSTEP >*/
	k += kstep;
/*<          KC = KNC + N - K + 2 >*/
	kc = knc + *n - k + 2;
/*<          GO TO 40 >*/
	goto L40;

/*<       END IF >*/
    }

/*<    70 CONTINUE >*/
L70:
/*<       RETURN >*/
    return 0;

/*     End of DSPTRF */

/*<       END >*/
} /* dsptrf_ */
Beispiel #5
0
/* Subroutine */ int dpptri_(char *uplo, integer *n, doublereal *ap, integer *
	info)
{
    /* System generated locals */
    integer i__1, i__2;

    /* Local variables */
    integer j, jc, jj;
    doublereal ajj;
    integer jjn;
    logical upper;

/*  -- LAPACK routine (version 3.2) -- */
/*     November 2006 */

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

/*  DPPTRI computes the inverse of a real symmetric positive definite */
/*  matrix A using the Cholesky factorization A = U**T*U or A = L*L**T */
/*  computed by DPPTRF. */

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

/*  UPLO    (input) CHARACTER*1 */
/*          = 'U':  Upper triangular factor is stored in AP; */
/*          = 'L':  Lower triangular factor is stored in AP. */

/*  N       (input) INTEGER */
/*          The order of the matrix A.  N >= 0. */

/*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/*          On entry, the triangular factor U or L from the Cholesky */
/*          factorization A = U**T*U or A = L*L**T, packed columnwise as */
/*          a linear array.  The j-th column of U or L is stored in the */
/*          array AP as follows: */
/*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */
/*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */

/*          On exit, the upper or lower triangle of the (symmetric) */
/*          inverse of A, overwriting the input factor U or L. */

/*  INFO    (output) INTEGER */
/*          = 0:  successful exit */
/*          < 0:  if INFO = -i, the i-th argument had an illegal value */
/*          > 0:  if INFO = i, the (i,i) element of the factor U or L is */
/*                zero, and the inverse could not be computed. */

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

/*     Test the input parameters. */

    /* Parameter adjustments */
    --ap;

    /* Function Body */
    *info = 0;
    upper = lsame_(uplo, "U");
    if (! upper && ! lsame_(uplo, "L")) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DPPTRI", &i__1);
	return 0;
    }

/*     Quick return if possible */

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

/*     Invert the triangular Cholesky factor U or L. */

    dtptri_(uplo, "Non-unit", n, &ap[1], info);
    if (*info > 0) {
	return 0;
    }

    if (upper) {

/*        Compute the product inv(U) * inv(U)'. */

	jj = 0;
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    jc = jj + 1;
	    jj += j;
	    if (j > 1) {
		i__2 = j - 1;
		dspr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1]);
	    }
	    ajj = ap[jj];
	    dscal_(&j, &ajj, &ap[jc], &c__1);
	}

    } else {

/*        Compute the product inv(L)' * inv(L). */

	jj = 1;
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    jjn = jj + *n - j + 1;
	    i__2 = *n - j + 1;
	    ap[jj] = ddot_(&i__2, &ap[jj], &c__1, &ap[jj], &c__1);
	    if (j < *n) {
		i__2 = *n - j;
		dtpmv_("Lower", "Transpose", "Non-unit", &i__2, &ap[jjn], &ap[
			jj + 1], &c__1);
	    }
	    jj = jjn;
	}
    }

    return 0;

/*     End of DPPTRI */

} /* dpptri_ */
Beispiel #6
0
 int dsptrf_(char *uplo, int *n, double *ap, int *
	ipiv, int *info)
{
    /* System generated locals */
    int i__1, i__2;
    double d__1, d__2, d__3;

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

    /* Local variables */
    int i__, j, k;
    double t, r1, d11, d12, d21, d22;
    int kc, kk, kp;
    double wk;
    int kx, knc, kpc, npp;
    double wkm1, wkp1;
    int imax, jmax;
    extern  int dspr_(char *, int *, double *, 
	    double *, int *, double *);
    double alpha;
    extern  int dscal_(int *, double *, double *, 
	    int *);
    extern int lsame_(char *, char *);
    extern  int dswap_(int *, double *, int *, 
	    double *, int *);
    int kstep;
    int upper;
    double absakk;
    extern int idamax_(int *, double *, int *);
    extern  int xerbla_(char *, int *);
    double colmax, rowmax;


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

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

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

/*  DSPTRF computes the factorization of a float symmetric matrix A stored */
/*  in packed format using the Bunch-Kaufman diagonal pivoting method: */

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

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

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

/*  UPLO    (input) CHARACTER*1 */
/*          = 'U':  Upper triangle of A is stored; */
/*          = 'L':  Lower triangle of A is stored. */

/*  N       (input) INTEGER */
/*          The order of the matrix A.  N >= 0. */

/*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/*          On entry, the upper or lower triangle of the symmetric matrix */
/*          A, packed columnwise in a linear array.  The j-th column of A */
/*          is stored in the array AP as follows: */
/*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */

/*          On exit, the block diagonal matrix D and the multipliers used */
/*          to obtain the factor U or L, stored as a packed triangular */
/*          matrix overwriting A (see below for further details). */

/*  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 = -i, the i-th argument had an illegal value */
/*          > 0: if INFO = i, D(i,i) 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 */
/*  =============== */

/*  5-96 - Based on modifications by J. Lewis, Boeing Computer Services */
/*         Company */

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

/*     Test the input parameters. */

    /* Parameter adjustments */
    --ipiv;
    --ap;

    /* Function Body */
    *info = 0;
    upper = lsame_(uplo, "U");
    if (! upper && ! lsame_(uplo, "L")) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DSPTRF", &i__1);
	return 0;
    }

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

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

    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;
	kc = (*n - 1) * *n / 2 + 1;
L10:
	knc = kc;

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

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

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

	absakk = (d__1 = ap[kc + k - 1], ABS(d__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 = idamax_(&i__1, &ap[kc], &c__1);
	    colmax = (d__1 = ap[kc + imax - 1], ABS(d__1));
	} else {
	    colmax = 0.;
	}

	if (MAX(absakk,colmax) == 0.) {

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

	    if (*info == 0) {
		*info = k;
	    }
	    kp = k;
	} 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 */

		rowmax = 0.;
		jmax = imax;
		kx = imax * (imax + 1) / 2 + imax;
		i__1 = k;
		for (j = imax + 1; j <= i__1; ++j) {
		    if ((d__1 = ap[kx], ABS(d__1)) > rowmax) {
			rowmax = (d__1 = ap[kx], ABS(d__1));
			jmax = j;
		    }
		    kx += j;
/* L20: */
		}
		kpc = (imax - 1) * imax / 2 + 1;
		if (imax > 1) {
		    i__1 = imax - 1;
		    jmax = idamax_(&i__1, &ap[kpc], &c__1);
/* Computing MAX */
		    d__2 = rowmax, d__3 = (d__1 = ap[kpc + jmax - 1], ABS(
			    d__1));
		    rowmax = MAX(d__2,d__3);
		}

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

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

		    kp = k;
		} else if ((d__1 = ap[kpc + imax - 1], ABS(d__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 (kstep == 2) {
		knc = knc - k + 1;
	    }
	    if (kp != kk) {

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

		i__1 = kp - 1;
		dswap_(&i__1, &ap[knc], &c__1, &ap[kpc], &c__1);
		kx = kpc + kp - 1;
		i__1 = kk - 1;
		for (j = kp + 1; j <= i__1; ++j) {
		    kx = kx + j - 1;
		    t = ap[knc + j - 1];
		    ap[knc + j - 1] = ap[kx];
		    ap[kx] = t;
/* L30: */
		}
		t = ap[knc + kk - 1];
		ap[knc + kk - 1] = ap[kpc + kp - 1];
		ap[kpc + kp - 1] = t;
		if (kstep == 2) {
		    t = ap[kc + k - 2];
		    ap[kc + k - 2] = ap[kc + kp - 1];
		    ap[kc + kp - 1] = t;
		}
	    }

/*           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)' */

		r1 = 1. / ap[kc + k - 1];
		i__1 = k - 1;
		d__1 = -r1;
		dspr_(uplo, &i__1, &d__1, &ap[kc], &c__1, &ap[1]);

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

		i__1 = k - 1;
		dscal_(&i__1, &r1, &ap[kc], &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) {

		    d12 = ap[k - 1 + (k - 1) * k / 2];
		    d22 = ap[k - 1 + (k - 2) * (k - 1) / 2] / d12;
		    d11 = ap[k + (k - 1) * k / 2] / d12;
		    t = 1. / (d11 * d22 - 1.);
		    d12 = t / d12;

		    for (j = k - 2; j >= 1; --j) {
			wkm1 = d12 * (d11 * ap[j + (k - 2) * (k - 1) / 2] - 
				ap[j + (k - 1) * k / 2]);
			wk = d12 * (d22 * ap[j + (k - 1) * k / 2] - ap[j + (k 
				- 2) * (k - 1) / 2]);
			for (i__ = j; i__ >= 1; --i__) {
			    ap[i__ + (j - 1) * j / 2] = ap[i__ + (j - 1) * j /
				     2] - ap[i__ + (k - 1) * k / 2] * wk - ap[
				    i__ + (k - 2) * (k - 1) / 2] * wkm1;
/* L40: */
			}
			ap[j + (k - 1) * k / 2] = wk;
			ap[j + (k - 2) * (k - 1) / 2] = wkm1;
/* L50: */
		    }

		}

	    }
	}

/*        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;
	kc = knc - k;
	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;
	kc = 1;
	npp = *n * (*n + 1) / 2;
L60:
	knc = kc;

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

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

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

	absakk = (d__1 = ap[kc], ABS(d__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 + idamax_(&i__1, &ap[kc + 1], &c__1);
	    colmax = (d__1 = ap[kc + imax - k], ABS(d__1));
	} else {
	    colmax = 0.;
	}

	if (MAX(absakk,colmax) == 0.) {

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

	    if (*info == 0) {
		*info = k;
	    }
	    kp = k;
	} 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 */

		rowmax = 0.;
		kx = kc + imax - k;
		i__1 = imax - 1;
		for (j = k; j <= i__1; ++j) {
		    if ((d__1 = ap[kx], ABS(d__1)) > rowmax) {
			rowmax = (d__1 = ap[kx], ABS(d__1));
			jmax = j;
		    }
		    kx = kx + *n - j;
/* L70: */
		}
		kpc = npp - (*n - imax + 1) * (*n - imax + 2) / 2 + 1;
		if (imax < *n) {
		    i__1 = *n - imax;
		    jmax = imax + idamax_(&i__1, &ap[kpc + 1], &c__1);
/* Computing MAX */
		    d__2 = rowmax, d__3 = (d__1 = ap[kpc + jmax - imax], ABS(
			    d__1));
		    rowmax = MAX(d__2,d__3);
		}

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

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

		    kp = k;
		} else if ((d__1 = ap[kpc], ABS(d__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 (kstep == 2) {
		knc = knc + *n - k + 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;
		    dswap_(&i__1, &ap[knc + kp - kk + 1], &c__1, &ap[kpc + 1], 
			     &c__1);
		}
		kx = knc + kp - kk;
		i__1 = kp - 1;
		for (j = kk + 1; j <= i__1; ++j) {
		    kx = kx + *n - j + 1;
		    t = ap[knc + j - kk];
		    ap[knc + j - kk] = ap[kx];
		    ap[kx] = t;
/* L80: */
		}
		t = ap[knc];
		ap[knc] = ap[kpc];
		ap[kpc] = t;
		if (kstep == 2) {
		    t = ap[kc + 1];
		    ap[kc + 1] = ap[kc + kp - k];
		    ap[kc + kp - k] = t;
		}
	    }

/*           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)' */

		    r1 = 1. / ap[kc];
		    i__1 = *n - k;
		    d__1 = -r1;
		    dspr_(uplo, &i__1, &d__1, &ap[kc + 1], &c__1, &ap[kc + *n 
			    - k + 1]);

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

		    i__1 = *n - k;
		    dscal_(&i__1, &r1, &ap[kc + 1], &c__1);
		}
	    } else {

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

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

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

		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) )' */

		    d21 = ap[k + 1 + (k - 1) * ((*n << 1) - k) / 2];
		    d11 = ap[k + 1 + k * ((*n << 1) - k - 1) / 2] / d21;
		    d22 = ap[k + (k - 1) * ((*n << 1) - k) / 2] / d21;
		    t = 1. / (d11 * d22 - 1.);
		    d21 = t / d21;

		    i__1 = *n;
		    for (j = k + 2; j <= i__1; ++j) {
			wk = d21 * (d11 * ap[j + (k - 1) * ((*n << 1) - k) / 
				2] - ap[j + k * ((*n << 1) - k - 1) / 2]);
			wkp1 = d21 * (d22 * ap[j + k * ((*n << 1) - k - 1) / 
				2] - ap[j + (k - 1) * ((*n << 1) - k) / 2]);

			i__2 = *n;
			for (i__ = j; i__ <= i__2; ++i__) {
			    ap[i__ + (j - 1) * ((*n << 1) - j) / 2] = ap[i__ 
				    + (j - 1) * ((*n << 1) - j) / 2] - ap[i__ 
				    + (k - 1) * ((*n << 1) - k) / 2] * wk - 
				    ap[i__ + k * ((*n << 1) - k - 1) / 2] * 
				    wkp1;
/* L90: */
			}

			ap[j + (k - 1) * ((*n << 1) - k) / 2] = wk;
			ap[j + k * ((*n << 1) - k - 1) / 2] = wkp1;

/* L100: */
		    }
		}
	    }
	}

/*        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;
	kc = knc + *n - k + 2;
	goto L60;

    }

L110:
    return 0;

/*     End of DSPTRF */

} /* dsptrf_ */
Beispiel #7
0
/* Subroutine */ int dppt01_(char *uplo, integer *n, doublereal *a, 
	doublereal *afac, doublereal *rwork, doublereal *resid)
{
    /* System generated locals */
    integer i__1;

    /* Local variables */
    extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, 
	    integer *);
    extern /* Subroutine */ int dspr_(char *, integer *, doublereal *, 
	    doublereal *, integer *, doublereal *);
    static integer i__, k;
    static doublereal t;
    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
	    integer *);
    extern logical lsame_(char *, char *);
    static doublereal anorm;
    extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *, 
	    doublereal *, doublereal *, integer *);
    static integer kc;
    extern doublereal dlamch_(char *), dlansp_(char *, char *, 
	    integer *, doublereal *, doublereal *);
    static doublereal eps;
    static integer npp;


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


    Purpose   
    =======   

    DPPT01 reconstructs a symmetric positive definite packed 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.   

    Arguments   
    ==========   

    UPLO    (input) CHARACTER*1   
            Specifies whether the upper or lower triangular part of the   
            symmetric 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) DOUBLE PRECISION array, dimension (N*(N+1)/2)   
            The original symmetric matrix A, stored as a packed   
            triangular matrix.   

    AFAC    (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)   
            On entry, the factor L or U from the L*L' or U'*U   
            factorization of A, stored as a packed triangular matrix.   
            Overwritten with the reconstructed matrix, and then with the   
            difference L*L' - A (or U'*U - A).   

    RWORK   (workspace) DOUBLE PRECISION array, dimension (N)   

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

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


       Quick exit if N = 0   

       Parameter adjustments */
    --rwork;
    --afac;
    --a;

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

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

    eps = dlamch_("Epsilon");
    anorm = dlansp_("1", uplo, n, &a[1], &rwork[1]);
    if (anorm <= 0.) {
	*resid = 1. / eps;
	return 0;
    }

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

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

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

	    t = ddot_(&k, &afac[kc], &c__1, &afac[kc], &c__1);
	    afac[kc + k - 1] = t;

/*           Compute the rest of column K. */

	    if (k > 1) {
		i__1 = k - 1;
		dtpmv_("Upper", "Transpose", "Non-unit", &i__1, &afac[1], &
			afac[kc], &c__1);
		kc -= k - 1;
	    }
/* L10: */
	}

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

    } else {
	kc = *n * (*n + 1) / 2;
	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 < *n) {
		i__1 = *n - k;
		dspr_("Lower", &i__1, &c_b14, &afac[kc + 1], &c__1, &afac[kc 
			+ *n - k + 1]);
	    }

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

	    t = afac[kc];
	    i__1 = *n - k + 1;
	    dscal_(&i__1, &t, &afac[kc], &c__1);

	    kc -= *n - k + 2;
/* L20: */
	}
    }

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

    npp = *n * (*n + 1) / 2;
    i__1 = npp;
    for (i__ = 1; i__ <= i__1; ++i__) {
	afac[i__] -= a[i__];
/* L30: */
    }

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

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

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

    return 0;

/*     End of DPPT01 */

} /* dppt01_ */
Beispiel #8
0
void
dspr(char uplo, int n, double alpha, double *x, int incx, double *ap )
{
   dspr_( &uplo, &n, &alpha, x, &incx, ap );
}
Beispiel #9
0
/* Subroutine */ int dpptrf_(char *uplo, integer *n, doublereal *ap, integer *
	info)
{
/*  -- LAPACK routine (version 3.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       March 31, 1993   


    Purpose   
    =======   

    DPPTRF computes the Cholesky factorization of a real symmetric   
    positive definite matrix A stored in packed format.   

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

    Arguments   
    =========   

    UPLO    (input) CHARACTER*1   
            = 'U':  Upper triangle of A is stored;   
            = 'L':  Lower triangle of A is stored.   

    N       (input) INTEGER   
            The order of the matrix A.  N >= 0.   

    AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)   
            On entry, the upper or lower triangle of the symmetric matrix   
            A, packed columnwise in a linear array.  The j-th column of A   
            is stored in the array AP as follows:   
            if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;   
            if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.   
            See below for further details.   

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

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

    Further Details   
    ======= =======   

    The packed storage scheme is illustrated by the following example   
    when N = 4, UPLO = 'U':   

    Two-dimensional storage of the symmetric matrix A:   

       a11 a12 a13 a14   
           a22 a23 a24   
               a33 a34     (aij = aji)   
                   a44   

    Packed storage of the upper triangle of A:   

    AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]   

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


       Test the input parameters.   

       Parameter adjustments */
    /* Table of constant values */
    static integer c__1 = 1;
    static doublereal c_b16 = -1.;
    
    /* System generated locals */
    integer i__1, i__2;
    doublereal d__1;
    /* Builtin functions */
    double sqrt(doublereal);
    /* Local variables */
    extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, 
	    integer *);
    extern /* Subroutine */ int dspr_(char *, integer *, doublereal *, 
	    doublereal *, integer *, doublereal *);
    static integer j;
    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
	    integer *);
    extern logical lsame_(char *, char *);
    static logical upper;
    extern /* Subroutine */ int dtpsv_(char *, char *, char *, integer *, 
	    doublereal *, doublereal *, integer *);
    static integer jc, jj;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    static doublereal ajj;


    --ap;

    /* Function Body */
    *info = 0;
    upper = lsame_(uplo, "U");
    if (! upper && ! lsame_(uplo, "L")) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DPPTRF", &i__1);
	return 0;
    }

/*     Quick return if possible */

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

    if (upper) {

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

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

/*           Compute elements 1:J-1 of column J. */

	    if (j > 1) {
		i__2 = j - 1;
		dtpsv_("Upper", "Transpose", "Non-unit", &i__2, &ap[1], &ap[
			jc], &c__1);
	    }

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

	    i__2 = j - 1;
	    ajj = ap[jj] - ddot_(&i__2, &ap[jc], &c__1, &ap[jc], &c__1);
	    if (ajj <= 0.) {
		ap[jj] = ajj;
		goto L30;
	    }
	    ap[jj] = sqrt(ajj);
/* L10: */
	}
    } else {

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

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

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

	    ajj = ap[jj];
	    if (ajj <= 0.) {
		ap[jj] = ajj;
		goto L30;
	    }
	    ajj = sqrt(ajj);
	    ap[jj] = ajj;

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

	    if (j < *n) {
		i__2 = *n - j;
		d__1 = 1. / ajj;
		dscal_(&i__2, &d__1, &ap[jj + 1], &c__1);
		i__2 = *n - j;
		dspr_("Lower", &i__2, &c_b16, &ap[jj + 1], &c__1, &ap[jj + *n 
			- j + 1]);
		jj = jj + *n - j + 1;
	    }
/* L20: */
	}
    }
    goto L40;

L30:
    *info = j;

L40:
    return 0;

/*     End of DPPTRF */

} /* dpptrf_ */
Beispiel #10
0
/* Subroutine */ int dppt01_(char *uplo, integer *n, doublereal *a, 
	doublereal *afac, doublereal *rwork, doublereal *resid)
{
    /* System generated locals */
    integer i__1;

    /* Local variables */
    integer i__, k;
    doublereal t;
    integer kc;
    doublereal eps;
    integer npp;
    doublereal anorm;


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

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

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

/*  DPPT01 reconstructs a symmetric positive definite packed 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. */

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

/*  UPLO    (input) CHARACTER*1 */
/*          Specifies whether the upper or lower triangular part of the */
/*          symmetric 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) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/*          The original symmetric matrix A, stored as a packed */
/*          triangular matrix. */

/*  AFAC    (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/*          On entry, the factor L or U from the L*L' or U'*U */
/*          factorization of A, stored as a packed triangular matrix. */
/*          Overwritten with the reconstructed matrix, and then with the */
/*          difference L*L' - A (or U'*U - A). */

/*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N) */

/*  RESID   (output) DOUBLE PRECISION */
/*          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 */
    --rwork;
    --afac;
    --a;

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

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

    eps = dlamch_("Epsilon");
    anorm = dlansp_("1", uplo, n, &a[1], &rwork[1]);
    if (anorm <= 0.) {
	*resid = 1. / eps;
	return 0;
    }

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

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

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

	    t = ddot_(&k, &afac[kc], &c__1, &afac[kc], &c__1);
	    afac[kc + k - 1] = t;

/*           Compute the rest of column K. */

	    if (k > 1) {
		i__1 = k - 1;
		dtpmv_("Upper", "Transpose", "Non-unit", &i__1, &afac[1], &
			afac[kc], &c__1);
		kc -= k - 1;
	    }
/* L10: */
	}

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

    } else {
	kc = *n * (*n + 1) / 2;
	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 < *n) {
		i__1 = *n - k;
		dspr_("Lower", &i__1, &c_b14, &afac[kc + 1], &c__1, &afac[kc 
			+ *n - k + 1]);
	    }

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

	    t = afac[kc];
	    i__1 = *n - k + 1;
	    dscal_(&i__1, &t, &afac[kc], &c__1);

	    kc -= *n - k + 2;
/* L20: */
	}
    }

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

    npp = *n * (*n + 1) / 2;
    i__1 = npp;
    for (i__ = 1; i__ <= i__1; ++i__) {
	afac[i__] -= a[i__];
/* L30: */
    }

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

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

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

    return 0;

/*     End of DPPT01 */

} /* dppt01_ */
Beispiel #11
0
/* Subroutine */ int dsbt21_(char *uplo, integer *n, integer *ka, integer *ks, 
	 doublereal *a, integer *lda, doublereal *d__, doublereal *e, 
	doublereal *u, integer *ldu, doublereal *work, doublereal *result)
{
    /* System generated locals */
    integer a_dim1, a_offset, u_dim1, u_offset, i__1, i__2, i__3, i__4;
    doublereal d__1, d__2;

    /* Local variables */
    integer j, jc, jr, lw, ika;
    doublereal ulp, unfl;
    extern /* Subroutine */ int dspr_(char *, integer *, doublereal *, 
	    doublereal *, integer *, doublereal *), dspr2_(char *, 
	    integer *, doublereal *, doublereal *, integer *, doublereal *, 
	    integer *, doublereal *), dgemm_(char *, char *, integer *
, integer *, integer *, doublereal *, doublereal *, integer *, 
	    doublereal *, integer *, doublereal *, doublereal *, integer *);
    extern logical lsame_(char *, char *);
    doublereal anorm;
    char cuplo[1];
    logical lower;
    doublereal wnorm;
    extern doublereal dlamch_(char *), dlange_(char *, integer *, 
	    integer *, doublereal *, integer *, doublereal *), 
	    dlansb_(char *, char *, integer *, integer *, doublereal *, 
	    integer *, doublereal *), dlansp_(char *, char *, 
	    integer *, doublereal *, doublereal *);


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

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

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

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

/*          A = U S U' */

/*  where ' means transpose, A is symmetric banded, U is */
/*  orthogonal, and S is diagonal (if KS=0) or symmetric */
/*  tridiagonal (if KS=1). */

/*  Specifically: */

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

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

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

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

/*  KA      (input) INTEGER */
/*          The bandwidth of the matrix A.  It must be at least zero.  If */
/*          it is larger than N-1, then max( 0, N-1 ) will be used. */

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

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

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

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

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

/*  U       (input) DOUBLE PRECISION array, dimension (LDU, N) */
/*          The orthogonal matrix in the decomposition, expressed as a */
/*          dense matrix (i.e., not as a product of Householder */
/*          transformations, Givens transformations, etc.) */

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

/*  WORK    (workspace) DOUBLE PRECISION array, dimension (N**2+N) */

/*  RESULT  (output) DOUBLE PRECISION array, dimension (2) */
/*          The values computed by the two tests described above.  The */
/*          values are currently limited to 1/ulp, to avoid overflow. */

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

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

/*     Constants */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    --d__;
    --e;
    u_dim1 = *ldu;
    u_offset = 1 + u_dim1;
    u -= u_offset;
    --work;
    --result;

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

/* Computing MAX */
/* Computing MIN */
    i__3 = *n - 1;
    i__1 = 0, i__2 = min(i__3,*ka);
    ika = max(i__1,i__2);
    lw = *n * (*n + 1) / 2;

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

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

/*     Some Error Checks */

/*     Do Test 1 */

/*     Norm of A: */

/* Computing MAX */
    d__1 = dlansb_("1", cuplo, n, &ika, &a[a_offset], lda, &work[1]);
    anorm = max(d__1,unfl);

/*     Compute error matrix:    Error = A - U S U' */

/*     Copy A from SB to SP storage format. */

    j = 0;
    i__1 = *n;
    for (jc = 1; jc <= i__1; ++jc) {
	if (lower) {
/* Computing MIN */
	    i__3 = ika + 1, i__4 = *n + 1 - jc;
	    i__2 = min(i__3,i__4);
	    for (jr = 1; jr <= i__2; ++jr) {
		++j;
		work[j] = a[jr + jc * a_dim1];
/* L10: */
	    }
	    i__2 = *n + 1 - jc;
	    for (jr = ika + 2; jr <= i__2; ++jr) {
		++j;
		work[j] = 0.;
/* L20: */
	    }
	} else {
	    i__2 = jc;
	    for (jr = ika + 2; jr <= i__2; ++jr) {
		++j;
		work[j] = 0.;
/* L30: */
	    }
/* Computing MIN */
	    i__2 = ika, i__3 = jc - 1;
	    for (jr = min(i__2,i__3); jr >= 0; --jr) {
		++j;
		work[j] = a[ika + 1 - jr + jc * a_dim1];
/* L40: */
	    }
	}
/* L50: */
    }

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

    if (*n > 1 && *ks == 1) {
	i__1 = *n - 1;
	for (j = 1; j <= i__1; ++j) {
	    d__1 = -e[j];
	    dspr2_(cuplo, n, &d__1, &u[j * u_dim1 + 1], &c__1, &u[(j + 1) * 
		    u_dim1 + 1], &c__1, &work[1]);
/* L70: */
	}
    }
    wnorm = dlansp_("1", cuplo, n, &work[1], &work[lw + 1]);

    if (anorm > wnorm) {
	result[1] = wnorm / anorm / (*n * ulp);
    } else {
	if (anorm < 1.) {
/* Computing MIN */
	    d__1 = wnorm, d__2 = *n * anorm;
	    result[1] = min(d__1,d__2) / anorm / (*n * ulp);
	} else {
/* Computing MIN */
	    d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
	    result[1] = min(d__1,d__2) / (*n * ulp);
	}
    }

/*     Do Test 2 */

/*     Compute  UU' - I */

    dgemm_("N", "C", n, n, n, &c_b22, &u[u_offset], ldu, &u[u_offset], ldu, &
	    c_b23, &work[1], n);

    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	work[(*n + 1) * (j - 1) + 1] += -1.;
/* L80: */
    }

/* Computing MIN */
/* Computing 2nd power */
    i__1 = *n;
    d__1 = dlange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]),
	     d__2 = (doublereal) (*n);
    result[2] = min(d__1,d__2) / (*n * ulp);

    return 0;

/*     End of DSBT21 */

} /* dsbt21_ */
Beispiel #12
0
/* Subroutine */ int dpptrf_(char *uplo, integer *n, doublereal *ap, integer *
	info)
{
    /* System generated locals */
    integer i__1, i__2;
    doublereal d__1;

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

    /* Local variables */
    integer j, jc, jj;
    doublereal ajj;
    extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, 
	    integer *);
    extern /* Subroutine */ int dspr_(char *, integer *, doublereal *, 
	    doublereal *, integer *, doublereal *), dscal_(integer *, 
	    doublereal *, doublereal *, integer *);
    extern logical lsame_(char *, char *);
    logical upper;
    extern /* Subroutine */ int dtpsv_(char *, char *, char *, integer *, 
	    doublereal *, doublereal *, integer *), 
	    xerbla_(char *, integer *);


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

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

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

/*  DPPTRF computes the Cholesky factorization of a real symmetric */
/*  positive definite matrix A stored in packed format. */

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

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

/*  UPLO    (input) CHARACTER*1 */
/*          = 'U':  Upper triangle of A is stored; */
/*          = 'L':  Lower triangle of A is stored. */

/*  N       (input) INTEGER */
/*          The order of the matrix A.  N >= 0. */

/*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/*          On entry, the upper or lower triangle of the symmetric matrix */
/*          A, packed columnwise in a linear array.  The j-th column of A */
/*          is stored in the array AP as follows: */
/*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/*          See below for further details. */

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

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

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

/*  The packed storage scheme is illustrated by the following example */
/*  when N = 4, UPLO = 'U': */

/*  Two-dimensional storage of the symmetric matrix A: */

/*     a11 a12 a13 a14 */
/*         a22 a23 a24 */
/*             a33 a34     (aij = aji) */
/*                 a44 */

/*  Packed storage of the upper triangle of A: */

/*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */

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

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

/*     Test the input parameters. */

    /* Parameter adjustments */
    --ap;

    /* Function Body */
    *info = 0;
    upper = lsame_(uplo, "U");
    if (! upper && ! lsame_(uplo, "L")) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DPPTRF", &i__1);
	return 0;
    }

/*     Quick return if possible */

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

    if (upper) {

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

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

/*           Compute elements 1:J-1 of column J. */

	    if (j > 1) {
		i__2 = j - 1;
		dtpsv_("Upper", "Transpose", "Non-unit", &i__2, &ap[1], &ap[
			jc], &c__1);
	    }

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

	    i__2 = j - 1;
	    ajj = ap[jj] - ddot_(&i__2, &ap[jc], &c__1, &ap[jc], &c__1);
	    if (ajj <= 0.) {
		ap[jj] = ajj;
		goto L30;
	    }
	    ap[jj] = sqrt(ajj);
/* L10: */
	}
    } else {

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

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

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

	    ajj = ap[jj];
	    if (ajj <= 0.) {
		ap[jj] = ajj;
		goto L30;
	    }
	    ajj = sqrt(ajj);
	    ap[jj] = ajj;

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

	    if (j < *n) {
		i__2 = *n - j;
		d__1 = 1. / ajj;
		dscal_(&i__2, &d__1, &ap[jj + 1], &c__1);
		i__2 = *n - j;
		dspr_("Lower", &i__2, &c_b16, &ap[jj + 1], &c__1, &ap[jj + *n 
			- j + 1]);
		jj = jj + *n - j + 1;
	    }
/* L20: */
	}
    }
    goto L40;

L30:
    *info = j;

L40:
    return 0;

/*     End of DPPTRF */

} /* dpptrf_ */
Beispiel #13
0
/* Subroutine */ int dspt21_(integer *itype, char *uplo, integer *n, integer *
	kband, doublereal *ap, doublereal *d__, doublereal *e, doublereal *u, 
	integer *ldu, doublereal *vp, doublereal *tau, doublereal *work, 
	doublereal *result)
{
    /* System generated locals */
    integer u_dim1, u_offset, i__1, i__2;
    doublereal d__1, d__2;

    /* Local variables */
    integer j, jp, jr, jp1, lap;
    doublereal ulp;
    extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, 
	    integer *);
    doublereal unfl, temp;
    extern /* Subroutine */ int dspr_(char *, integer *, doublereal *, 
	    doublereal *, integer *, doublereal *), dspr2_(char *, 
	    integer *, doublereal *, doublereal *, integer *, doublereal *, 
	    integer *, doublereal *), dgemm_(char *, char *, integer *
, integer *, integer *, doublereal *, doublereal *, integer *, 
	    doublereal *, integer *, doublereal *, doublereal *, integer *);
    extern logical lsame_(char *, char *);
    integer iinfo;
    doublereal anorm;
    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
	    doublereal *, integer *);
    char cuplo[1];
    doublereal vsave;
    extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, 
	    integer *, doublereal *, integer *);
    logical lower;
    extern /* Subroutine */ int dspmv_(char *, integer *, doublereal *, 
	    doublereal *, doublereal *, integer *, doublereal *, doublereal *, 
	     integer *);
    doublereal wnorm;
    extern doublereal dlamch_(char *), dlange_(char *, integer *, 
	    integer *, doublereal *, integer *, doublereal *);
    extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, integer *), 
	    dlaset_(char *, integer *, integer *, doublereal *, doublereal *, 
	    doublereal *, integer *);
    extern doublereal dlansp_(char *, char *, integer *, doublereal *, 
	    doublereal *);
    extern /* Subroutine */ int dopmtr_(char *, char *, char *, integer *, 
	    integer *, doublereal *, doublereal *, doublereal *, integer *, 
	    doublereal *, integer *);


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

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

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

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

/*          A = U S U' */

/*  where ' means transpose, A is symmetric (stored in packed format), U */
/*  is orthogonal, and S is diagonal (if KBAND=0) or symmetric */
/*  tridiagonal (if KBAND=1).  If ITYPE=1, then U is represented as a */
/*  dense matrix, otherwise the 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 - VU' | / ( n ulp ) */

/*  Packed storage means that, for example, if UPLO='U', then the columns */
/*  of the upper triangle of A are stored one after another, so that */
/*  A(1,j+1) immediately follows A(j,j) in the array AP.  Similarly, if */
/*  UPLO='L', then the columns of the lower triangle of A are stored one */
/*  after another in AP, so that A(j+1,j+1) immediately follows A(n,j) */
/*  in the array AP.  This means that A(i,j) is stored in: */

/*     AP( i + j*(j-1)/2 )                 if UPLO='U' */

/*     AP( i + (2*n-j)*(j-1)/2 )           if UPLO='L' */

/*  The array VP bears the same relation to the matrix V that A does to */
/*  AP. */

/*  For ITYPE > 1, the transformation U is expressed as a product */
/*  of Householder transformations: */

/*     If UPLO='U', then  V = H(n-1)...H(1),  where */

/*         H(j) = I  -  tau(j) v(j) v(j)' */

/*     and the first j-1 elements of v(j) are stored in V(1:j-1,j+1), */
/*     (i.e., VP( j*(j+1)/2 + 1 : j*(j+1)/2 + j-1 ) ), */
/*     the j-th element is 1, and the last n-j elements are 0. */

/*     If UPLO='L', then  V = H(1)...H(n-1),  where */

/*         H(j) = I  -  tau(j) v(j) v(j)' */

/*     and the first j elements of v(j) are 0, the (j+1)-st is 1, and the */
/*     (j+2)-nd through n-th elements are stored in V(j+2:n,j) (i.e., */
/*     in VP( (2*n-j)*(j-1)/2 + j+2 : (2*n-j)*(j-1)/2 + n ) .) */

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

/*  ITYPE   (input) INTEGER */
/*          Specifies the type of tests to be performed. */
/*          1: U expressed as a dense orthogonal 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 orthogonal matrix and */
/*             as a product of Housholder transformations: */
/*             RESULT(1) = | I - VU' | / ( n ulp ) */

/*  UPLO    (input) CHARACTER */
/*          If UPLO='U', AP and VP are considered to contain the upper */
/*          triangle of A and V. */
/*          If UPLO='L', AP and VP are considered to contain the lower */
/*          triangle of A and V. */

/*  N       (input) INTEGER */
/*          The size of the matrix.  If it is zero, DSPT21 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. */

/*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/*          The original (unfactored) matrix.  It is assumed to be */
/*          symmetric, and contains the columns of just the upper */
/*          triangle (UPLO='U') or only the lower triangle (UPLO='L'), */
/*          packed one after another. */

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

/*  E       (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDU, N) */
/*          If ITYPE=1 or 3, this contains the orthogonal 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. */

/*  VP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/*          If ITYPE=2 or 3, the columns of this array contain the */
/*          Householder vectors used to describe the orthogonal matrix */
/*          in the decomposition, as described in purpose. */
/*          *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. */

/*  TAU     (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (N**2+N) */
/*          Workspace. */

/*  RESULT  (output) DOUBLE PRECISION 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 .. */

/*     1)      Constants */

    /* Parameter adjustments */
    --ap;
    --d__;
    --e;
    u_dim1 = *ldu;
    u_offset = 1 + u_dim1;
    u -= u_offset;
    --vp;
    --tau;
    --work;
    --result;

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

    lap = *n * (*n + 1) / 2;

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

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

/*     Some Error Checks */

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

/*     Do Test 1 */

/*     Norm of A: */

    if (*itype == 3) {
	anorm = 1.;
    } else {
/* Computing MAX */
	d__1 = dlansp_("1", cuplo, n, &ap[1], &work[1]);
	anorm = max(d__1,unfl);
    }

/*     Compute error matrix: */

    if (*itype == 1) {

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

	dlaset_("Full", n, n, &c_b10, &c_b10, &work[1], n);
	dcopy_(&lap, &ap[1], &c__1, &work[1], &c__1);

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

	if (*n > 1 && *kband == 1) {
	    i__1 = *n - 1;
	    for (j = 1; j <= i__1; ++j) {
		d__1 = -e[j];
		dspr2_(cuplo, n, &d__1, &u[j * u_dim1 + 1], &c__1, &u[(j + 1) 
			* u_dim1 + 1], &c__1, &work[1]);
/* L20: */
	    }
	}
/* Computing 2nd power */
	i__1 = *n;
	wnorm = dlansp_("1", cuplo, n, &work[1], &work[i__1 * i__1 + 1]);

    } else if (*itype == 2) {

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

	dlaset_("Full", n, n, &c_b10, &c_b10, &work[1], n);

	if (lower) {
	    work[lap] = d__[*n];
	    for (j = *n - 1; j >= 1; --j) {
		jp = ((*n << 1) - j) * (j - 1) / 2;
		jp1 = jp + *n - j;
		if (*kband == 1) {
		    work[jp + j + 1] = (1. - tau[j]) * e[j];
		    i__1 = *n;
		    for (jr = j + 2; jr <= i__1; ++jr) {
			work[jp + jr] = -tau[j] * e[j] * vp[jp + jr];
/* L30: */
		    }
		}

		if (tau[j] != 0.) {
		    vsave = vp[jp + j + 1];
		    vp[jp + j + 1] = 1.;
		    i__1 = *n - j;
		    dspmv_("L", &i__1, &c_b26, &work[jp1 + j + 1], &vp[jp + j 
			    + 1], &c__1, &c_b10, &work[lap + 1], &c__1);
		    i__1 = *n - j;
		    temp = tau[j] * -.5 * ddot_(&i__1, &work[lap + 1], &c__1, 
			    &vp[jp + j + 1], &c__1);
		    i__1 = *n - j;
		    daxpy_(&i__1, &temp, &vp[jp + j + 1], &c__1, &work[lap + 
			    1], &c__1);
		    i__1 = *n - j;
		    d__1 = -tau[j];
		    dspr2_("L", &i__1, &d__1, &vp[jp + j + 1], &c__1, &work[
			    lap + 1], &c__1, &work[jp1 + j + 1]);
		    vp[jp + j + 1] = vsave;
		}
		work[jp + j] = d__[j];
/* L40: */
	    }
	} else {
	    work[1] = d__[1];
	    i__1 = *n - 1;
	    for (j = 1; j <= i__1; ++j) {
		jp = j * (j - 1) / 2;
		jp1 = jp + j;
		if (*kband == 1) {
		    work[jp1 + j] = (1. - tau[j]) * e[j];
		    i__2 = j - 1;
		    for (jr = 1; jr <= i__2; ++jr) {
			work[jp1 + jr] = -tau[j] * e[j] * vp[jp1 + jr];
/* L50: */
		    }
		}

		if (tau[j] != 0.) {
		    vsave = vp[jp1 + j];
		    vp[jp1 + j] = 1.;
		    dspmv_("U", &j, &c_b26, &work[1], &vp[jp1 + 1], &c__1, &
			    c_b10, &work[lap + 1], &c__1);
		    temp = tau[j] * -.5 * ddot_(&j, &work[lap + 1], &c__1, &
			    vp[jp1 + 1], &c__1);
		    daxpy_(&j, &temp, &vp[jp1 + 1], &c__1, &work[lap + 1], &
			    c__1);
		    d__1 = -tau[j];
		    dspr2_("U", &j, &d__1, &vp[jp1 + 1], &c__1, &work[lap + 1]
, &c__1, &work[1]);
		    vp[jp1 + j] = vsave;
		}
		work[jp1 + j + 1] = d__[j + 1];
/* L60: */
	    }
	}

	i__1 = lap;
	for (j = 1; j <= i__1; ++j) {
	    work[j] -= ap[j];
/* L70: */
	}
	wnorm = dlansp_("1", cuplo, n, &work[1], &work[lap + 1]);

    } else if (*itype == 3) {

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

	if (*n < 2) {
	    return 0;
	}
	dlacpy_(" ", n, n, &u[u_offset], ldu, &work[1], n);
/* Computing 2nd power */
	i__1 = *n;
	dopmtr_("R", cuplo, "T", n, n, &vp[1], &tau[1], &work[1], n, &work[
		i__1 * i__1 + 1], &iinfo);
	if (iinfo != 0) {
	    result[1] = 10. / ulp;
	    return 0;
	}

	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    work[(*n + 1) * (j - 1) + 1] += -1.;
/* L80: */
	}

/* Computing 2nd power */
	i__1 = *n;
	wnorm = dlange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]);
    }

    if (anorm > wnorm) {
	result[1] = wnorm / anorm / (*n * ulp);
    } else {
	if (anorm < 1.) {
/* Computing MIN */
	    d__1 = wnorm, d__2 = *n * anorm;
	    result[1] = min(d__1,d__2) / anorm / (*n * ulp);
	} else {
/* Computing MIN */
	    d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
	    result[1] = min(d__1,d__2) / (*n * ulp);
	}
    }

/*     Do Test 2 */

/*     Compute  UU' - I */

    if (*itype == 1) {
	dgemm_("N", "C", n, n, n, &c_b26, &u[u_offset], ldu, &u[u_offset], 
		ldu, &c_b10, &work[1], n);

	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    work[(*n + 1) * (j - 1) + 1] += -1.;
/* L90: */
	}

/* Computing MIN */
/* Computing 2nd power */
	i__1 = *n;
	d__1 = dlange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]), d__2 = (doublereal) (*n);
	result[2] = min(d__1,d__2) / (*n * ulp);
    }

    return 0;

/*     End of DSPT21 */

} /* dspt21_ */