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;
}
int
f2c_dspr(char* uplo, integer* N,
doublereal* alpha,
doublereal* X, integer* incX,
doublereal* Ap)
{
dspr_(uplo, N, alpha, X, incX, Ap);
return 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 */
}
/*< 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_ */
/* 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_ */
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_ */
/* 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_ */
void
dspr(char uplo, int n, double alpha, double *x, int incx, double *ap )
{
dspr_( &uplo, &n, &alpha, x, &incx, ap );
}
/* 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_ */
/* 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_ */
/* 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_ */
/* 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_ */
/* 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_ */