#include "blaswrap.h" #include "f2c.h" doublereal dlansp_(char *norm, char *uplo, integer *n, doublereal *ap, doublereal *work) { /* -- LAPACK auxiliary routine (version 3.1) -- Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. November 2006 Purpose ======= DLANSP returns the value of the one norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric matrix A, supplied in packed form. Description =========== DLANSP returns the value DLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm' ( ( norm1(A), NORM = '1', 'O' or 'o' ( ( normI(A), NORM = 'I' or 'i' ( ( normF(A), NORM = 'F', 'f', 'E' or 'e' where norm1 denotes the one norm of a matrix (maximum column sum), normI denotes the infinity norm of a matrix (maximum row sum) and normF denotes the Frobenius norm of a matrix (square root of sum of squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. Arguments ========= NORM (input) CHARACTER*1 Specifies the value to be returned in DLANSP as described above. UPLO (input) CHARACTER*1 Specifies whether the upper or lower triangular part of the symmetric matrix A is supplied. = 'U': Upper triangular part of A is supplied = 'L': Lower triangular part of A is supplied N (input) INTEGER The order of the matrix A. N >= 0. When N = 0, DLANSP is set to zero. AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) 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. WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, WORK is not referenced. ===================================================================== Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; /* System generated locals */ integer i__1, i__2; doublereal ret_val, d__1, d__2, d__3; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static integer i__, j, k; static doublereal sum, absa, scale; extern logical lsame_(char *, char *); static doublereal value; extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, doublereal *, doublereal *); --work; --ap; /* Function Body */ if (*n == 0) { value = 0.; } else if (lsame_(norm, "M")) { /* Find max(abs(A(i,j))). */ value = 0.; if (lsame_(uplo, "U")) { k = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = k + j - 1; for (i__ = k; i__ <= i__2; ++i__) { /* Computing MAX */ d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1)); value = max(d__2,d__3); /* L10: */ } k += j; /* L20: */ } } else { k = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = k + *n - j; for (i__ = k; i__ <= i__2; ++i__) { /* Computing MAX */ d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1)); value = max(d__2,d__3); /* L30: */ } k = k + *n - j + 1; /* L40: */ } } } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { /* Find normI(A) ( = norm1(A), since A is symmetric). */ value = 0.; k = 1; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = 0.; i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { absa = (d__1 = ap[k], abs(d__1)); sum += absa; work[i__] += absa; ++k; /* L50: */ } work[j] = sum + (d__1 = ap[k], abs(d__1)); ++k; /* L60: */ } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ d__1 = value, d__2 = work[i__]; value = max(d__1,d__2); /* L70: */ } } else { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = 0.; /* L80: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { sum = work[j] + (d__1 = ap[k], abs(d__1)); ++k; i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { absa = (d__1 = ap[k], abs(d__1)); sum += absa; work[i__] += absa; ++k; /* L90: */ } value = max(value,sum); /* L100: */ } } } else if (lsame_(norm, "F") || lsame_(norm, "E")) { /* Find normF(A). */ scale = 0.; sum = 1.; k = 2; if (lsame_(uplo, "U")) { i__1 = *n; for (j = 2; j <= i__1; ++j) { i__2 = j - 1; dlassq_(&i__2, &ap[k], &c__1, &scale, &sum); k += j; /* L110: */ } } else { i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { i__2 = *n - j; dlassq_(&i__2, &ap[k], &c__1, &scale, &sum); k = k + *n - j + 1; /* L120: */ } } sum *= 2; k = 1; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (ap[k] != 0.) { absa = (d__1 = ap[k], abs(d__1)); if (scale < absa) { /* Computing 2nd power */ d__1 = scale / absa; sum = sum * (d__1 * d__1) + 1.; scale = absa; } else { /* Computing 2nd power */ d__1 = absa / scale; sum += d__1 * d__1; } } if (lsame_(uplo, "U")) { k = k + i__ + 1; } else { k = k + *n - i__ + 1; } /* L130: */ } value = scale * sqrt(sum); } ret_val = value; return ret_val; /* End of DLANSP */ } /* dlansp_ */