* ======================================================================
* NIST Guide to Available Math Software.
* Fullsource for module ZHPEV from package LAPACK.
* Retrieved from NETLIB on Sun Jun 14 17:57:20 1998.
* ======================================================================
SUBROUTINE ZHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK,
$ INFO )
*
* -- LAPACK driver 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 JOBZ, UPLO
INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION RWORK( * ), W( * )
COMPLEX*16 AP( * ), WORK( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* ZHPEV computes all the eigenvalues and, optionally, eigenvectors of a
* complex Hermitian matrix in packed storage.
*
* Arguments
* =========
*
* JOBZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only;
* = 'V': Compute eigenvalues and eigenvectors.
*
* 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) COMPLEX*16 array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the Hermitian 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)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*
* On exit, AP is overwritten by values generated during the
* reduction to tridiagonal form. If UPLO = 'U', the diagonal
* and first superdiagonal of the tridiagonal matrix T overwrite
* the corresponding elements of A, and if UPLO = 'L', the
* diagonal and first subdiagonal of T overwrite the
* corresponding elements of A.
*
* W (output) DOUBLE PRECISION array, dimension (N)
* If INFO = 0, the eigenvalues in ascending order.
*
* Z (output) COMPLEX*16 array, dimension (LDZ, N)
* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
* eigenvectors of the matrix A, with the i-th column of Z
* holding the eigenvector associated with W(i).
* If JOBZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* JOBZ = 'V', LDZ >= max(1,N).
*
* WORK (workspace) COMPLEX*16 array, dimension (max(1, 2*N-1))
*
* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))
*
* INFO (output) INTEGER
* = 0: successful exit.
* < 0: if INFO = -i, the i-th argument had an illegal value.
* > 0: if INFO = i, the algorithm failed to converge; i
* off-diagonal elements of an intermediate tridiagonal
* form did not converge to zero.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL WANTZ
INTEGER IINFO, IMAX, INDE, INDRWK, INDTAU, INDWRK,
$ ISCALE
DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, ZLANHP
EXTERNAL LSAME, DLAMCH, ZLANHP
* ..
* .. External Subroutines ..
EXTERNAL DSCAL, DSTERF, XERBLA, ZDSCAL, ZHPTRD, ZSTEQR,
$ ZUPGTR
* ..
* .. Intrinsic Functions ..
INTRINSIC SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
WANTZ = LSAME( JOBZ, 'V' )
*
INFO = 0
IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
INFO = -1
ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) )
$ THEN
INFO = -2
ELSE IF( N.LT.0 ) THEN
INFO = -3
ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
INFO = -7
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHPEV ', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
W( 1 ) = AP( 1 )
RWORK( 1 ) = 1
IF( WANTZ )
$ Z( 1, 1 ) = ONE
RETURN
END IF
*
* Get machine constants.
*
SAFMIN = DLAMCH( 'Safe minimum' )
EPS = DLAMCH( 'Precision' )
SMLNUM = SAFMIN / EPS
BIGNUM = ONE / SMLNUM
RMIN = SQRT( SMLNUM )
RMAX = SQRT( BIGNUM )
*
* Scale matrix to allowable range, if necessary.
*
ANRM = ZLANHP( 'M', UPLO, N, AP, RWORK )
ISCALE = 0
IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
ISCALE = 1
SIGMA = RMIN / ANRM
ELSE IF( ANRM.GT.RMAX ) THEN
ISCALE = 1
SIGMA = RMAX / ANRM
END IF
IF( ISCALE.EQ.1 ) THEN
CALL ZDSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
END IF
*
* Call ZHPTRD to reduce Hermitian packed matrix to tridiagonal form.
*
INDE = 1
INDTAU = 1
CALL ZHPTRD( UPLO, N, AP, W, RWORK( INDE ), WORK( INDTAU ),
$ IINFO )
*
* For eigenvalues only, call DSTERF. For eigenvectors, first call
* ZUPGTR to generate the orthogonal matrix, then call ZSTEQR.
*
IF( .NOT.WANTZ ) THEN
CALL DSTERF( N, W, RWORK( INDE ), INFO )
ELSE
INDWRK = INDTAU + N
CALL ZUPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
$ WORK( INDWRK ), IINFO )
INDRWK = INDE + N
CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), Z, LDZ,
$ RWORK( INDRWK ), INFO )
END IF
*
* If matrix was scaled, then rescale eigenvalues appropriately.
*
IF( ISCALE.EQ.1 ) THEN
IF( INFO.EQ.0 ) THEN
IMAX = N
ELSE
IMAX = INFO - 1
END IF
CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
END IF
*
RETURN
*
* End of ZHPEV
*
END
SUBROUTINE ZHPTRD( UPLO, N, AP, D, E, TAU, INFO )
*
* -- LAPACK routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
COMPLEX*16 AP( * ), TAU( * )
* ..
*
* Purpose
* =======
*
* ZHPTRD reduces a complex Hermitian matrix A stored in packed form to
* real symmetric tridiagonal form T by a unitary similarity
* transformation: Q**H * A * Q = T.
*
* 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) COMPLEX*16 array, dimension (N*(N+1)/2)
* On entry, the upper or lower triangle of the Hermitian 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)*(2*n-j)/2) = A(i,j) for j<=i<=n.
* On exit, if UPLO = 'U', the diagonal and first superdiagonal
* of A are overwritten by the corresponding elements of the
* tridiagonal matrix T, and the elements above the first
* superdiagonal, with the array TAU, represent the unitary
* matrix Q as a product of elementary reflectors; if UPLO
* = 'L', the diagonal and first subdiagonal of A are over-
* written by the corresponding elements of the tridiagonal
* matrix T, and the elements below the first subdiagonal, with
* the array TAU, represent the unitary matrix Q as a product
* of elementary reflectors. See Further Details.
*
* D (output) DOUBLE PRECISION array, dimension (N)
* The diagonal elements of the tridiagonal matrix T:
* D(i) = A(i,i).
*
* E (output) DOUBLE PRECISION array, dimension (N-1)
* The off-diagonal elements of the tridiagonal matrix T:
* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
*
* TAU (output) COMPLEX*16 array, dimension (N-1)
* The scalar factors of the elementary reflectors (see Further
* Details).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* Further Details
* ===============
*
* If UPLO = 'U', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(n-1) . . . H(2) H(1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a complex scalar, and v is a complex vector with
* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
* overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
*
* If UPLO = 'L', the matrix Q is represented as a product of elementary
* reflectors
*
* Q = H(1) H(2) . . . H(n-1).
*
* Each H(i) has the form
*
* H(i) = I - tau * v * v'
*
* where tau is a complex scalar, and v is a complex vector with
* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
* overwriting A(i+2:n,i), and tau is stored in TAU(i).
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO, HALF
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ),
$ HALF = ( 0.5D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, I1, I1I1, II
COMPLEX*16 ALPHA, TAUI
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZAXPY, ZHPMV, ZHPR2, ZLARFG
* ..
* .. External Functions ..
LOGICAL LSAME
COMPLEX*16 ZDOTC
EXTERNAL LSAME, ZDOTC
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZHPTRD', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Reduce the upper triangle of A.
* I1 is the index in AP of A(1,I+1).
*
I1 = N*( N-1 ) / 2 + 1
AP( I1+N-1 ) = DBLE( AP( I1+N-1 ) )
DO 10 I = N - 1, 1, -1
*
* Generate elementary reflector H(i) = I - tau * v * v'
* to annihilate A(1:i-1,i+1)
*
ALPHA = AP( I1+I-1 )
CALL ZLARFG( I, ALPHA, AP( I1 ), 1, TAUI )
E( I ) = ALPHA
*
IF( TAUI.NE.ZERO ) THEN
*
* Apply H(i) from both sides to A(1:i,1:i)
*
AP( I1+I-1 ) = ONE
*
* Compute y := tau * A * v storing y in TAU(1:i)
*
CALL ZHPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU,
$ 1 )
*
* Compute w := y - 1/2 * tau * (y'*v) * v
*
ALPHA = -HALF*TAUI*ZDOTC( I, TAU, 1, AP( I1 ), 1 )
CALL ZAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w' - w * v'
*
CALL ZHPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP )
*
END IF
AP( I1+I-1 ) = E( I )
D( I+1 ) = AP( I1+I )
TAU( I ) = TAUI
I1 = I1 - I
10 CONTINUE
D( 1 ) = AP( 1 )
ELSE
*
* Reduce the lower triangle of A. II is the index in AP of
* A(i,i) and I1I1 is the index of A(i+1,i+1).
*
II = 1
AP( 1 ) = DBLE( AP( 1 ) )
DO 20 I = 1, N - 1
I1I1 = II + N - I + 1
*
* Generate elementary reflector H(i) = I - tau * v * v'
* to annihilate A(i+2:n,i)
*
ALPHA = AP( II+1 )
CALL ZLARFG( N-I, ALPHA, AP( II+2 ), 1, TAUI )
E( I ) = ALPHA
*
IF( TAUI.NE.ZERO ) THEN
*
* Apply H(i) from both sides to A(i+1:n,i+1:n)
*
AP( II+1 ) = ONE
*
* Compute y := tau * A * v storing y in TAU(i:n-1)
*
CALL ZHPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1,
$ ZERO, TAU( I ), 1 )
*
* Compute w := y - 1/2 * tau * (y'*v) * v
*
ALPHA = -HALF*TAUI*ZDOTC( N-I, TAU( I ), 1, AP( II+1 ),
$ 1 )
CALL ZAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I ), 1 )
*
* Apply the transformation as a rank-2 update:
* A := A - v * w' - w * v'
*
CALL ZHPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1,
$ AP( I1I1 ) )
*
END IF
AP( II+1 ) = E( I )
D( I ) = AP( II )
TAU( I ) = TAUI
II = I1I1
20 CONTINUE
D( N ) = AP( II )
END IF
*
RETURN
*
* End of ZHPTRD
*
END
DOUBLE COMPLEX FUNCTION ZLADIV( X, Y )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. Scalar Arguments ..
COMPLEX*16 X, Y
* ..
*
* Purpose
* =======
*
* ZLADIV := X / Y, where X and Y are complex. The computation of X / Y
* will not overflow on an intermediary step unless the results
* overflows.
*
* Arguments
* =========
*
* X (input) COMPLEX*16
* Y (input) COMPLEX*16
* The complex scalars X and Y.
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION ZI, ZR
* ..
* .. External Subroutines ..
EXTERNAL DLADIV
* ..
* .. Intrinsic Functions ..
INTRINSIC DBLE, DCMPLX, DIMAG
* ..
* .. Executable Statements ..
*
CALL DLADIV( DBLE( X ), DIMAG( X ), DBLE( Y ), DIMAG( Y ), ZR,
$ ZI )
ZLADIV = DCMPLX( ZR, ZI )
*
RETURN
*
* End of ZLADIV
*
END
DOUBLE PRECISION FUNCTION ZLANHP( NORM, UPLO, N, AP, WORK )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. Scalar Arguments ..
CHARACTER NORM, UPLO
INTEGER N
* ..
* .. Array Arguments ..
DOUBLE PRECISION WORK( * )
COMPLEX*16 AP( * )
* ..
*
* Purpose
* =======
*
* ZLANHP returns the value of the one norm, or the Frobenius norm, or
* the infinity norm, or the element of largest absolute value of a
* complex hermitian matrix A, supplied in packed form.
*
* Description
* ===========
*
* ZLANHP returns the value
*
* ZLANHP = ( 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 matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in ZLANHP as described
* above.
*
* UPLO (input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
* hermitian 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, ZLANHP is
* set to zero.
*
* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
* The upper or lower triangle of the hermitian 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.
* Note that the imaginary parts of the diagonal elements need
* not be set and are assumed to be zero.
*
* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK),
* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
* WORK is not referenced.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, K
DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL ZLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, SQRT
* ..
* .. Executable Statements ..
*
IF( N.EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
IF( LSAME( UPLO, 'U' ) ) THEN
K = 0
DO 20 J = 1, N
DO 10 I = K + 1, K + J - 1
VALUE = MAX( VALUE, ABS( AP( I ) ) )
10 CONTINUE
K = K + J
VALUE = MAX( VALUE, ABS( DBLE( AP( K ) ) ) )
20 CONTINUE
ELSE
K = 1
DO 40 J = 1, N
VALUE = MAX( VALUE, ABS( DBLE( AP( K ) ) ) )
DO 30 I = K + 1, K + N - J
VALUE = MAX( VALUE, ABS( AP( I ) ) )
30 CONTINUE
K = K + N - J + 1
40 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
$ ( NORM.EQ.'1' ) ) THEN
*
* Find normI(A) ( = norm1(A), since A is hermitian).
*
VALUE = ZERO
K = 1
IF( LSAME( UPLO, 'U' ) ) THEN
DO 60 J = 1, N
SUM = ZERO
DO 50 I = 1, J - 1
ABSA = ABS( AP( K ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
K = K + 1
50 CONTINUE
WORK( J ) = SUM + ABS( DBLE( AP( K ) ) )
K = K + 1
60 CONTINUE
DO 70 I = 1, N
VALUE = MAX( VALUE, WORK( I ) )
70 CONTINUE
ELSE
DO 80 I = 1, N
WORK( I ) = ZERO
80 CONTINUE
DO 100 J = 1, N
SUM = WORK( J ) + ABS( DBLE( AP( K ) ) )
K = K + 1
DO 90 I = J + 1, N
ABSA = ABS( AP( K ) )
SUM = SUM + ABSA
WORK( I ) = WORK( I ) + ABSA
K = K + 1
90 CONTINUE
VALUE = MAX( VALUE, SUM )
100 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
K = 2
IF( LSAME( UPLO, 'U' ) ) THEN
DO 110 J = 2, N
CALL ZLASSQ( J-1, AP( K ), 1, SCALE, SUM )
K = K + J
110 CONTINUE
ELSE
DO 120 J = 1, N - 1
CALL ZLASSQ( N-J, AP( K ), 1, SCALE, SUM )
K = K + N - J + 1
120 CONTINUE
END IF
SUM = 2*SUM
K = 1
DO 130 I = 1, N
IF( DBLE( AP( K ) ).NE.ZERO ) THEN
ABSA = ABS( DBLE( AP( K ) ) )
IF( SCALE.LT.ABSA ) THEN
SUM = ONE + SUM*( SCALE / ABSA )**2
SCALE = ABSA
ELSE
SUM = SUM + ( ABSA / SCALE )**2
END IF
END IF
IF( LSAME( UPLO, 'U' ) ) THEN
K = K + I + 1
ELSE
K = K + N - I + 1
END IF
130 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
ZLANHP = VALUE
RETURN
*
* End of ZLANHP
*
END
SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
CHARACTER SIDE
INTEGER INCV, LDC, M, N
COMPLEX*16 TAU
* ..
* .. Array Arguments ..
COMPLEX*16 C( LDC, * ), V( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* ZLARF applies a complex elementary reflector H to a complex M-by-N
* matrix C, from either the left or the right. H is represented in the
* form
*
* H = I - tau * v * v'
*
* where tau is a complex scalar and v is a complex vector.
*
* If tau = 0, then H is taken to be the unit matrix.
*
* To apply H' (the conjugate transpose of H), supply conjg(tau) instead
* tau.
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* = 'L': form H * C
* = 'R': form C * H
*
* M (input) INTEGER
* The number of rows of the matrix C.
*
* N (input) INTEGER
* The number of columns of the matrix C.
*
* V (input) COMPLEX*16 array, dimension
* (1 + (M-1)*abs(INCV)) if SIDE = 'L'
* or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
* The vector v in the representation of H. V is not used if
* TAU = 0.
*
* INCV (input) INTEGER
* The increment between elements of v. INCV <> 0.
*
* TAU (input) COMPLEX*16
* The value tau in the representation of H.
*
* C (input/output) COMPLEX*16 array, dimension (LDC,N)
* On entry, the M-by-N matrix C.
* On exit, C is overwritten by the matrix H * C if SIDE = 'L',
* or C * H if SIDE = 'R'.
*
* LDC (input) INTEGER
* The leading dimension of the array C. LDC >= max(1,M).
*
* WORK (workspace) COMPLEX*16 array, dimension
* (N) if SIDE = 'L'
* or (M) if SIDE = 'R'
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. External Subroutines ..
EXTERNAL ZGEMV, ZGERC
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Executable Statements ..
*
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form H * C
*
IF( TAU.NE.ZERO ) THEN
*
* w := C' * v
*
CALL ZGEMV( 'Conjugate transpose', M, N, ONE, C, LDC, V,
$ INCV, ZERO, WORK, 1 )
*
* C := C - v * w'
*
CALL ZGERC( M, N, -TAU, V, INCV, WORK, 1, C, LDC )
END IF
ELSE
*
* Form C * H
*
IF( TAU.NE.ZERO ) THEN
*
* w := C * v
*
CALL ZGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV,
$ ZERO, WORK, 1 )
*
* C := C - w * v'
*
CALL ZGERC( M, N, -TAU, WORK, 1, V, INCV, C, LDC )
END IF
END IF
RETURN
*
* End of ZLARF
*
END
SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER INCX, N
COMPLEX*16 ALPHA, TAU
* ..
* .. Array Arguments ..
COMPLEX*16 X( * )
* ..
*
* Purpose
* =======
*
* ZLARFG generates a complex elementary reflector H of order n, such
* that
*
* H' * ( alpha ) = ( beta ), H' * H = I.
* ( x ) ( 0 )
*
* where alpha and beta are scalars, with beta real, and x is an
* (n-1)-element complex vector. H is represented in the form
*
* H = I - tau * ( 1 ) * ( 1 v' ) ,
* ( v )
*
* where tau is a complex scalar and v is a complex (n-1)-element
* vector. Note that H is not hermitian.
*
* If the elements of x are all zero and alpha is real, then tau = 0
* and H is taken to be the unit matrix.
*
* Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the elementary reflector.
*
* ALPHA (input/output) COMPLEX*16
* On entry, the value alpha.
* On exit, it is overwritten with the value beta.
*
* X (input/output) COMPLEX*16 array, dimension
* (1+(N-2)*abs(INCX))
* On entry, the vector x.
* On exit, it is overwritten with the vector v.
*
* INCX (input) INTEGER
* The increment between elements of X. INCX > 0.
*
* TAU (output) COMPLEX*16
* The value tau.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER J, KNT
DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLAPY3, DZNRM2
COMPLEX*16 ZLADIV
EXTERNAL DLAMCH, DLAPY3, DZNRM2, ZLADIV
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DCMPLX, DIMAG, SIGN
* ..
* .. External Subroutines ..
EXTERNAL ZDSCAL, ZSCAL
* ..
* .. Executable Statements ..
*
IF( N.LE.0 ) THEN
TAU = ZERO
RETURN
END IF
*
XNORM = DZNRM2( N-1, X, INCX )
ALPHR = DBLE( ALPHA )
ALPHI = DIMAG( ALPHA )
*
IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN
*
* H = I
*
TAU = ZERO
ELSE
*
* general case
*
BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
RSAFMN = ONE / SAFMIN
*
IF( ABS( BETA ).LT.SAFMIN ) THEN
*
* XNORM, BETA may be inaccurate; scale X and recompute them
*
KNT = 0
10 CONTINUE
KNT = KNT + 1
CALL ZDSCAL( N-1, RSAFMN, X, INCX )
BETA = BETA*RSAFMN
ALPHI = ALPHI*RSAFMN
ALPHR = ALPHR*RSAFMN
IF( ABS( BETA ).LT.SAFMIN )
$ GO TO 10
*
* New BETA is at most 1, at least SAFMIN
*
XNORM = DZNRM2( N-1, X, INCX )
ALPHA = DCMPLX( ALPHR, ALPHI )
BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA )
CALL ZSCAL( N-1, ALPHA, X, INCX )
*
* If ALPHA is subnormal, it may lose relative accuracy
*
ALPHA = BETA
DO 20 J = 1, KNT
ALPHA = ALPHA*SAFMIN
20 CONTINUE
ELSE
TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA )
CALL ZSCAL( N-1, ALPHA, X, INCX )
ALPHA = BETA
END IF
END IF
*
RETURN
*
* End of ZLARFG
*
END
SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, M, N
COMPLEX*16 ALPHA, BETA
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
* ..
*
* Purpose
* =======
*
* ZLASET initializes a 2-D array A to BETA on the diagonal and
* ALPHA on the offdiagonals.
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* Specifies the part of the matrix A to be set.
* = 'U': Upper triangular part is set. The lower triangle
* is unchanged.
* = 'L': Lower triangular part is set. The upper triangle
* is unchanged.
* Otherwise: All of the matrix A is set.
*
* M (input) INTEGER
* On entry, M specifies the number of rows of A.
*
* N (input) INTEGER
* On entry, N specifies the number of columns of A.
*
* ALPHA (input) COMPLEX*16
* All the offdiagonal array elements are set to ALPHA.
*
* BETA (input) COMPLEX*16
* All the diagonal array elements are set to BETA.
*
* A (input/output) COMPLEX*16 array, dimension (LDA,N)
* On entry, the m by n matrix A.
* On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j;
* A(i,i) = BETA , 1 <= i <= min(m,n)
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Set the diagonal to BETA and the strictly upper triangular
* part of the array to ALPHA.
*
DO 20 J = 2, N
DO 10 I = 1, MIN( J-1, M )
A( I, J ) = ALPHA
10 CONTINUE
20 CONTINUE
DO 30 I = 1, MIN( N, M )
A( I, I ) = BETA
30 CONTINUE
*
ELSE IF( LSAME( UPLO, 'L' ) ) THEN
*
* Set the diagonal to BETA and the strictly lower triangular
* part of the array to ALPHA.
*
DO 50 J = 1, MIN( M, N )
DO 40 I = J + 1, M
A( I, J ) = ALPHA
40 CONTINUE
50 CONTINUE
DO 60 I = 1, MIN( N, M )
A( I, I ) = BETA
60 CONTINUE
*
ELSE
*
* Set the array to BETA on the diagonal and ALPHA on the
* offdiagonal.
*
DO 80 J = 1, N
DO 70 I = 1, M
A( I, J ) = ALPHA
70 CONTINUE
80 CONTINUE
DO 90 I = 1, MIN( M, N )
A( I, I ) = BETA
90 CONTINUE
END IF
*
RETURN
*
* End of ZLASET
*
END
SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. Scalar Arguments ..
CHARACTER DIRECT, PIVOT, SIDE
INTEGER LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( * ), S( * )
COMPLEX*16 A( LDA, * )
* ..
*
* Purpose
* =======
*
* ZLASR performs the transformation
*
* A := P*A, when SIDE = 'L' or 'l' ( Left-hand side )
*
* A := A*P', when SIDE = 'R' or 'r' ( Right-hand side )
*
* where A is an m by n complex matrix and P is an orthogonal matrix,
* consisting of a sequence of plane rotations determined by the
* parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l'
* and z = n when SIDE = 'R' or 'r' ):
*
* When DIRECT = 'F' or 'f' ( Forward sequence ) then
*
* P = P( z - 1 )*...*P( 2 )*P( 1 ),
*
* and when DIRECT = 'B' or 'b' ( Backward sequence ) then
*
* P = P( 1 )*P( 2 )*...*P( z - 1 ),
*
* where P( k ) is a plane rotation matrix for the following planes:
*
* when PIVOT = 'V' or 'v' ( Variable pivot ),
* the plane ( k, k + 1 )
*
* when PIVOT = 'T' or 't' ( Top pivot ),
* the plane ( 1, k + 1 )
*
* when PIVOT = 'B' or 'b' ( Bottom pivot ),
* the plane ( k, z )
*
* c( k ) and s( k ) must contain the cosine and sine that define the
* matrix P( k ). The two by two plane rotation part of the matrix
* P( k ), R( k ), is assumed to be of the form
*
* R( k ) = ( c( k ) s( k ) ).
* ( -s( k ) c( k ) )
*
* Arguments
* =========
*
* SIDE (input) CHARACTER*1
* Specifies whether the plane rotation matrix P is applied to
* A on the left or the right.
* = 'L': Left, compute A := P*A
* = 'R': Right, compute A:= A*P'
*
* DIRECT (input) CHARACTER*1
* Specifies whether P is a forward or backward sequence of
* plane rotations.
* = 'F': Forward, P = P( z - 1 )*...*P( 2 )*P( 1 )
* = 'B': Backward, P = P( 1 )*P( 2 )*...*P( z - 1 )
*
* PIVOT (input) CHARACTER*1
* Specifies the plane for which P(k) is a plane rotation
* matrix.
* = 'V': Variable pivot, the plane (k,k+1)
* = 'T': Top pivot, the plane (1,k+1)
* = 'B': Bottom pivot, the plane (k,z)
*
* M (input) INTEGER
* The number of rows of the matrix A. If m <= 1, an immediate
* return is effected.
*
* N (input) INTEGER
* The number of columns of the matrix A. If n <= 1, an
* immediate return is effected.
*
* C, S (input) DOUBLE PRECISION arrays, dimension
* (M-1) if SIDE = 'L'
* (N-1) if SIDE = 'R'
* c(k) and s(k) contain the cosine and sine that define the
* matrix P(k). The two by two plane rotation part of the
* matrix P(k), R(k), is assumed to be of the form
* R( k ) = ( c( k ) s( k ) ).
* ( -s( k ) c( k ) )
*
* A (input/output) COMPLEX*16 array, dimension (LDA,N)
* The m by n matrix A. On exit, A is overwritten by P*A if
* SIDE = 'R' or by A*P' if SIDE = 'L'.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J
DOUBLE PRECISION CTEMP, STEMP
COMPLEX*16 TEMP
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
* Test the input parameters
*
INFO = 0
IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN
INFO = 1
ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT,
$ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN
INFO = 2
ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) )
$ THEN
INFO = 3
ELSE IF( M.LT.0 ) THEN
INFO = 4
ELSE IF( N.LT.0 ) THEN
INFO = 5
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = 9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZLASR ', INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
$ RETURN
IF( LSAME( SIDE, 'L' ) ) THEN
*
* Form P * A
*
IF( LSAME( PIVOT, 'V' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 20 J = 1, M - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 10 I = 1, N
TEMP = A( J+1, I )
A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
10 CONTINUE
END IF
20 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 40 J = M - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 30 I = 1, N
TEMP = A( J+1, I )
A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
30 CONTINUE
END IF
40 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 60 J = 2, M
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 50 I = 1, N
TEMP = A( J, I )
A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
50 CONTINUE
END IF
60 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 80 J = M, 2, -1
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 70 I = 1, N
TEMP = A( J, I )
A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
70 CONTINUE
END IF
80 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 100 J = 1, M - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 90 I = 1, N
TEMP = A( J, I )
A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
90 CONTINUE
END IF
100 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 120 J = M - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 110 I = 1, N
TEMP = A( J, I )
A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
110 CONTINUE
END IF
120 CONTINUE
END IF
END IF
ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
* Form A * P'
*
IF( LSAME( PIVOT, 'V' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 140 J = 1, N - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 130 I = 1, M
TEMP = A( I, J+1 )
A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
130 CONTINUE
END IF
140 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 160 J = N - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 150 I = 1, M
TEMP = A( I, J+1 )
A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
150 CONTINUE
END IF
160 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 180 J = 2, N
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 170 I = 1, M
TEMP = A( I, J )
A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
170 CONTINUE
END IF
180 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 200 J = N, 2, -1
CTEMP = C( J-1 )
STEMP = S( J-1 )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 190 I = 1, M
TEMP = A( I, J )
A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
190 CONTINUE
END IF
200 CONTINUE
END IF
ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
IF( LSAME( DIRECT, 'F' ) ) THEN
DO 220 J = 1, N - 1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 210 I = 1, M
TEMP = A( I, J )
A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
210 CONTINUE
END IF
220 CONTINUE
ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
DO 240 J = N - 1, 1, -1
CTEMP = C( J )
STEMP = S( J )
IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
DO 230 I = 1, M
TEMP = A( I, J )
A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
230 CONTINUE
END IF
240 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of ZLASR
*
END
SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. Scalar Arguments ..
INTEGER INCX, N
DOUBLE PRECISION SCALE, SUMSQ
* ..
* .. Array Arguments ..
COMPLEX*16 X( * )
* ..
*
* Purpose
* =======
*
* ZLASSQ returns the values scl and ssq such that
*
* ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
*
* where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is
* assumed to be at least unity and the value of ssq will then satisfy
*
* 1.0 .le. ssq .le. ( sumsq + 2*n ).
*
* scale is assumed to be non-negative and scl returns the value
*
* scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ),
* i
*
* scale and sumsq must be supplied in SCALE and SUMSQ respectively.
* SCALE and SUMSQ are overwritten by scl and ssq respectively.
*
* The routine makes only one pass through the vector X.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of elements to be used from the vector X.
*
* X (input) DOUBLE PRECISION
* The vector x as described above.
* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
*
* INCX (input) INTEGER
* The increment between successive values of the vector X.
* INCX > 0.
*
* SCALE (input/output) DOUBLE PRECISION
* On entry, the value scale in the equation above.
* On exit, SCALE is overwritten with the value scl .
*
* SUMSQ (input/output) DOUBLE PRECISION
* On entry, the value sumsq in the equation above.
* On exit, SUMSQ is overwritten with the value ssq .
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER IX
DOUBLE PRECISION TEMP1
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, DIMAG
* ..
* .. Executable Statements ..
*
IF( N.GT.0 ) THEN
DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
IF( DBLE( X( IX ) ).NE.ZERO ) THEN
TEMP1 = ABS( DBLE( X( IX ) ) )
IF( SCALE.LT.TEMP1 ) THEN
SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2
SCALE = TEMP1
ELSE
SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2
END IF
END IF
IF( DIMAG( X( IX ) ).NE.ZERO ) THEN
TEMP1 = ABS( DIMAG( X( IX ) ) )
IF( SCALE.LT.TEMP1 ) THEN
SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2
SCALE = TEMP1
ELSE
SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2
END IF
END IF
10 CONTINUE
END IF
*
RETURN
*
* End of ZLASSQ
*
END
SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
* -- LAPACK routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
CHARACTER COMPZ
INTEGER INFO, LDZ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * ), WORK( * )
COMPLEX*16 Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a
* symmetric tridiagonal matrix using the implicit QL or QR method.
* The eigenvectors of a full or band complex Hermitian matrix can also
* be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this
* matrix to tridiagonal form.
*
* Arguments
* =========
*
* COMPZ (input) CHARACTER*1
* = 'N': Compute eigenvalues only.
* = 'V': Compute eigenvalues and eigenvectors of the original
* Hermitian matrix. On entry, Z must contain the
* unitary matrix used to reduce the original matrix
* to tridiagonal form.
* = 'I': Compute eigenvalues and eigenvectors of the
* tridiagonal matrix. Z is initialized to the identity
* matrix.
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the diagonal elements of the tridiagonal matrix.
* On exit, if INFO = 0, the eigenvalues in ascending order.
*
* E (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix.
* On exit, E has been destroyed.
*
* Z (input/output) COMPLEX*16 array, dimension (LDZ, N)
* On entry, if COMPZ = 'V', then Z contains the unitary
* matrix used in the reduction to tridiagonal form.
* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
* orthonormal eigenvectors of the original Hermitian matrix,
* and if COMPZ = 'I', Z contains the orthonormal eigenvectors
* of the symmetric tridiagonal matrix.
* If COMPZ = 'N', then Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= 1, and if
* eigenvectors are desired, then LDZ >= max(1,N).
*
* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))
* If COMPZ = 'N', then WORK is not referenced.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: the algorithm has failed to find all the eigenvalues in
* a total of 30*N iterations; if INFO = i, then i
* elements of E have not converged to zero; on exit, D
* and E contain the elements of a symmetric tridiagonal
* matrix which is unitarily similar to the original
* matrix.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, THREE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ THREE = 3.0D0 )
COMPLEX*16 CZERO, CONE
PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ),
$ CONE = ( 1.0D0, 0.0D0 ) )
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
* ..
* .. Local Scalars ..
INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,
$ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,
$ NM1, NMAXIT
DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
$ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANST, DLAPY2
EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASRT, XERBLA,
$ ZLASET, ZLASR, ZSWAP
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
IF( LSAME( COMPZ, 'N' ) ) THEN
ICOMPZ = 0
ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
ICOMPZ = 1
ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
ICOMPZ = 2
ELSE
ICOMPZ = -1
END IF
IF( ICOMPZ.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
$ N ) ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZSTEQR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( N.EQ.1 ) THEN
IF( ICOMPZ.EQ.2 )
$ Z( 1, 1 ) = CONE
RETURN
END IF
*
* Determine the unit roundoff and over/underflow thresholds.
*
EPS = DLAMCH( 'E' )
EPS2 = EPS**2
SAFMIN = DLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
SSFMAX = SQRT( SAFMAX ) / THREE
SSFMIN = SQRT( SAFMIN ) / EPS2
*
* Compute the eigenvalues and eigenvectors of the tridiagonal
* matrix.
*
IF( ICOMPZ.EQ.2 )
$ CALL ZLASET( 'F', N, N, CZERO, CONE, Z, LDZ )
*
NMAXIT = N*MAXIT
JTOT = 0
*
* Determine where the matrix splits and choose QL or QR iteration
* for each block, according to whether top or bottom diagonal
* element is smaller.
*
L1 = 1
NM1 = N - 1
*
10 CONTINUE
IF( L1.GT.N )
$ GO TO 160
IF( L1.GT.1 )
$ E( L1-1 ) = ZERO
IF( L1.LE.NM1 ) THEN
DO 20 M = L1, NM1
TST = ABS( E( M ) )
IF( TST.EQ.ZERO )
$ GO TO 30
IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+
$ 1 ) ) ) )*EPS ) THEN
E( M ) = ZERO
GO TO 30
END IF
20 CONTINUE
END IF
M = N
*
30 CONTINUE
L = L1
LSV = L
LEND = M
LENDSV = LEND
L1 = M + 1
IF( LEND.EQ.L )
$ GO TO 10
*
* Scale submatrix in rows and columns L to LEND
*
ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) )
ISCALE = 0
IF( ANORM.EQ.ZERO )
$ GO TO 10
IF( ANORM.GT.SSFMAX ) THEN
ISCALE = 1
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
$ INFO )
ELSE IF( ANORM.LT.SSFMIN ) THEN
ISCALE = 2
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
$ INFO )
END IF
*
* Choose between QL and QR iteration
*
IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
LEND = LSV
L = LENDSV
END IF
*
IF( LEND.GT.L ) THEN
*
* QL Iteration
*
* Look for small subdiagonal element.
*
40 CONTINUE
IF( L.NE.LEND ) THEN
LENDM1 = LEND - 1
DO 50 M = L, LENDM1
TST = ABS( E( M ) )**2
IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+
$ SAFMIN )GO TO 60
50 CONTINUE
END IF
*
M = LEND
*
60 CONTINUE
IF( M.LT.LEND )
$ E( M ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 80
*
* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L+1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
WORK( L ) = C
WORK( N-1+L ) = S
CALL ZLASR( 'R', 'V', 'B', N, 2, WORK( L ),
$ WORK( N-1+L ), Z( 1, L ), LDZ )
ELSE
CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 )
END IF
D( L ) = RT1
D( L+1 ) = RT2
E( L ) = ZERO
L = L + 2
IF( L.LE.LEND )
$ GO TO 40
GO TO 140
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 140
JTOT = JTOT + 1
*
* Form shift.
*
G = ( D( L+1 )-P ) / ( TWO*E( L ) )
R = DLAPY2( G, ONE )
G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )
*
S = ONE
C = ONE
P = ZERO
*
* Inner loop
*
MM1 = M - 1
DO 70 I = MM1, L, -1
F = S*E( I )
B = C*E( I )
CALL DLARTG( G, F, C, S, R )
IF( I.NE.M-1 )
$ E( I+1 ) = R
G = D( I+1 ) - P
R = ( D( I )-G )*S + TWO*C*B
P = S*R
D( I+1 ) = G + P
G = C*R - B
*
* If eigenvectors are desired, then save rotations.
*
IF( ICOMPZ.GT.0 ) THEN
WORK( I ) = C
WORK( N-1+I ) = -S
END IF
*
70 CONTINUE
*
* If eigenvectors are desired, then apply saved rotations.
*
IF( ICOMPZ.GT.0 ) THEN
MM = M - L + 1
CALL ZLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ),
$ Z( 1, L ), LDZ )
END IF
*
D( L ) = D( L ) - P
E( L ) = G
GO TO 40
*
* Eigenvalue found.
*
80 CONTINUE
D( L ) = P
*
L = L + 1
IF( L.LE.LEND )
$ GO TO 40
GO TO 140
*
ELSE
*
* QR Iteration
*
* Look for small superdiagonal element.
*
90 CONTINUE
IF( L.NE.LEND ) THEN
LENDP1 = LEND + 1
DO 100 M = L, LENDP1, -1
TST = ABS( E( M-1 ) )**2
IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+
$ SAFMIN )GO TO 110
100 CONTINUE
END IF
*
M = LEND
*
110 CONTINUE
IF( M.GT.LEND )
$ E( M-1 ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 130
*
* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
* to compute its eigensystem.
*
IF( M.EQ.L-1 ) THEN
IF( ICOMPZ.GT.0 ) THEN
CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
WORK( M ) = C
WORK( N-1+M ) = S
CALL ZLASR( 'R', 'V', 'F', N, 2, WORK( M ),
$ WORK( N-1+M ), Z( 1, L-1 ), LDZ )
ELSE
CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 )
END IF
D( L-1 ) = RT1
D( L ) = RT2
E( L-1 ) = ZERO
L = L - 2
IF( L.GE.LEND )
$ GO TO 90
GO TO 140
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 140
JTOT = JTOT + 1
*
* Form shift.
*
G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )
R = DLAPY2( G, ONE )
G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )
*
S = ONE
C = ONE
P = ZERO
*
* Inner loop
*
LM1 = L - 1
DO 120 I = M, LM1
F = S*E( I )
B = C*E( I )
CALL DLARTG( G, F, C, S, R )
IF( I.NE.M )
$ E( I-1 ) = R
G = D( I ) - P
R = ( D( I+1 )-G )*S + TWO*C*B
P = S*R
D( I ) = G + P
G = C*R - B
*
* If eigenvectors are desired, then save rotations.
*
IF( ICOMPZ.GT.0 ) THEN
WORK( I ) = C
WORK( N-1+I ) = S
END IF
*
120 CONTINUE
*
* If eigenvectors are desired, then apply saved rotations.
*
IF( ICOMPZ.GT.0 ) THEN
MM = L - M + 1
CALL ZLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ),
$ Z( 1, M ), LDZ )
END IF
*
D( L ) = D( L ) - P
E( LM1 ) = G
GO TO 90
*
* Eigenvalue found.
*
130 CONTINUE
D( L ) = P
*
L = L - 1
IF( L.GE.LEND )
$ GO TO 90
GO TO 140
*
END IF
*
* Undo scaling if necessary
*
140 CONTINUE
IF( ISCALE.EQ.1 ) THEN
CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ),
$ N, INFO )
ELSE IF( ISCALE.EQ.2 ) THEN
CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ),
$ N, INFO )
END IF
*
* Check for no convergence to an eigenvalue after a total
* of N*MAXIT iterations.
*
IF( JTOT.EQ.NMAXIT ) THEN
DO 150 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
150 CONTINUE
RETURN
END IF
GO TO 10
*
* Order eigenvalues and eigenvectors.
*
160 CONTINUE
IF( ICOMPZ.EQ.0 ) THEN
*
* Use Quick Sort
*
CALL DLASRT( 'I', N, D, INFO )
*
ELSE
*
* Use Selection Sort to minimize swaps of eigenvectors
*
DO 180 II = 2, N
I = II - 1
K = I
P = D( I )
DO 170 J = II, N
IF( D( J ).LT.P ) THEN
K = J
P = D( J )
END IF
170 CONTINUE
IF( K.NE.I ) THEN
D( K ) = D( I )
D( I ) = P
CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
END IF
180 CONTINUE
END IF
RETURN
*
* End of ZSTEQR
*
END
SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* ZUNG2L generates an m by n complex matrix Q with orthonormal columns,
* which is defined as the last n columns of a product of k elementary
* reflectors of order m
*
* Q = H(k) . . . H(2) H(1)
*
* as returned by ZGEQLF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q. M >= N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. N >= K >= 0.
*
* A (input/output) COMPLEX*16 array, dimension (LDA,N)
* On entry, the (n-k+i)-th column must contain the vector which
* defines the elementary reflector H(i), for i = 1,2,...,k, as
* returned by ZGEQLF in the last k columns of its array
* argument A.
* On exit, the m-by-n matrix Q.
*
* LDA (input) INTEGER
* The first dimension of the array A. LDA >= max(1,M).
*
* TAU (input) COMPLEX*16 array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by ZGEQLF.
*
* WORK (workspace) COMPLEX*16 array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument has an illegal value
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, II, J, L
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARF, ZSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNG2L', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
* Initialise columns 1:n-k to columns of the unit matrix
*
DO 20 J = 1, N - K
DO 10 L = 1, M
A( L, J ) = ZERO
10 CONTINUE
A( M-N+J, J ) = ONE
20 CONTINUE
*
DO 40 I = 1, K
II = N - K + I
*
* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
*
A( M-N+II, II ) = ONE
CALL ZLARF( 'L', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,
$ LDA, WORK )
CALL ZSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
A( M-N+II, II ) = ONE - TAU( I )
*
* Set A(m-k+i+1:m,n-k+i) to zero
*
DO 30 L = M - N + II + 1, M
A( L, II ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* End of ZUNG2L
*
END
SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* ZUNG2R generates an m by n complex matrix Q with orthonormal columns,
* which is defined as the first n columns of a product of k elementary
* reflectors of order m
*
* Q = H(1) H(2) . . . H(k)
*
* as returned by ZGEQRF.
*
* Arguments
* =========
*
* M (input) INTEGER
* The number of rows of the matrix Q. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix Q. M >= N >= 0.
*
* K (input) INTEGER
* The number of elementary reflectors whose product defines the
* matrix Q. N >= K >= 0.
*
* A (input/output) COMPLEX*16 array, dimension (LDA,N)
* On entry, the i-th column must contain the vector which
* defines the elementary reflector H(i), for i = 1,2,...,k, as
* returned by ZGEQRF in the first k columns of its array
* argument A.
* On exit, the m by n matrix Q.
*
* LDA (input) INTEGER
* The first dimension of the array A. LDA >= max(1,M).
*
* TAU (input) COMPLEX*16 array, dimension (K)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by ZGEQRF.
*
* WORK (workspace) COMPLEX*16 array, dimension (N)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument has an illegal value
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
$ ZERO = ( 0.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
INTEGER I, J, L
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZLARF, ZSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUNG2R', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
* Initialise columns k+1:n to columns of the unit matrix
*
DO 20 J = K + 1, N
DO 10 L = 1, M
A( L, J ) = ZERO
10 CONTINUE
A( J, J ) = ONE
20 CONTINUE
*
DO 40 I = K, 1, -1
*
* Apply H(i) to A(i:m,i:n) from the left
*
IF( I.LT.N ) THEN
A( I, I ) = ONE
CALL ZLARF( 'L', M-I+1, N-I, A( I, I ), 1, TAU( I ),
$ A( I, I+1 ), LDA, WORK )
END IF
IF( I.LT.M )
$ CALL ZSCAL( M-I, -TAU( I ), A( I+1, I ), 1 )
A( I, I ) = ONE - TAU( I )
*
* Set A(1:i-1,i) to zero
*
DO 30 L = 1, I - 1
A( L, I ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* End of ZUNG2R
*
END
SUBROUTINE ZUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
*
* -- LAPACK routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDQ, N
* ..
* .. Array Arguments ..
COMPLEX*16 AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
* ..
*
* Purpose
* =======
*
* ZUPGTR generates a complex unitary matrix Q which is defined as the
* product of n-1 elementary reflectors H(i) of order n, as returned by
* ZHPTRD using packed storage:
*
* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
*
* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
*
* Arguments
* =========
*
* UPLO (input) CHARACTER*1
* = 'U': Upper triangular packed storage used in previous
* call to ZHPTRD;
* = 'L': Lower triangular packed storage used in previous
* call to ZHPTRD.
*
* N (input) INTEGER
* The order of the matrix Q. N >= 0.
*
* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
* The vectors which define the elementary reflectors, as
* returned by ZHPTRD.
*
* TAU (input) COMPLEX*16 array, dimension (N-1)
* TAU(i) must contain the scalar factor of the elementary
* reflector H(i), as returned by ZHPTRD.
*
* Q (output) COMPLEX*16 array, dimension (LDQ,N)
* The N-by-N unitary matrix Q.
*
* LDQ (input) INTEGER
* The leading dimension of the array Q. LDQ >= max(1,N).
*
* WORK (workspace) COMPLEX*16 array, dimension (N-1)
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 CZERO, CONE
PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ),
$ CONE = ( 1.0D+0, 0.0D+0 ) )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IINFO, IJ, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, ZUNG2L, ZUNG2R
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
INFO = -6
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'ZUPGTR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
*
IF( UPPER ) THEN
*
* Q was determined by a call to ZHPTRD with UPLO = 'U'
*
* Unpack the vectors which define the elementary reflectors and
* set the last row and column of Q equal to those of the unit
* matrix
*
IJ = 2
DO 20 J = 1, N - 1
DO 10 I = 1, J - 1
Q( I, J ) = AP( IJ )
IJ = IJ + 1
10 CONTINUE
IJ = IJ + 2
Q( N, J ) = CZERO
20 CONTINUE
DO 30 I = 1, N - 1
Q( I, N ) = CZERO
30 CONTINUE
Q( N, N ) = CONE
*
* Generate Q(1:n-1,1:n-1)
*
CALL ZUNG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
*
ELSE
*
* Q was determined by a call to ZHPTRD with UPLO = 'L'.
*
* Unpack the vectors which define the elementary reflectors and
* set the first row and column of Q equal to those of the unit
* matrix
*
Q( 1, 1 ) = CONE
DO 40 I = 2, N
Q( I, 1 ) = CZERO
40 CONTINUE
IJ = 3
DO 60 J = 2, N
Q( 1, J ) = CZERO
DO 50 I = J + 1, N
Q( I, J ) = AP( IJ )
IJ = IJ + 1
50 CONTINUE
IJ = IJ + 2
60 CONTINUE
IF( N.GT.1 ) THEN
*
* Generate Q(2:n,2:n)
*
CALL ZUNG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK,
$ IINFO )
END IF
END IF
RETURN
*
* End of ZUPGTR
*
END
SUBROUTINE DLADIV( A, B, C, D, P, Q )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. Scalar Arguments ..
DOUBLE PRECISION A, B, C, D, P, Q
* ..
*
* Purpose
* =======
*
* DLADIV performs complex division in real arithmetic
*
* a + i*b
* p + i*q = ---------
* c + i*d
*
* The algorithm is due to Robert L. Smith and can be found
* in D. Knuth, The art of Computer Programming, Vol.2, p.195
*
* Arguments
* =========
*
* A (input) DOUBLE PRECISION
* B (input) DOUBLE PRECISION
* C (input) DOUBLE PRECISION
* D (input) DOUBLE PRECISION
* The scalars a, b, c, and d in the above expression.
*
* P (output) DOUBLE PRECISION
* Q (output) DOUBLE PRECISION
* The scalars p and q in the above expression.
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION E, F
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
IF( ABS( D ).LT.ABS( C ) ) THEN
E = D / C
F = C + D*E
P = ( A+B*E ) / F
Q = ( B-A*E ) / F
ELSE
E = C / D
F = D + C*E
P = ( B+A*E ) / F
Q = ( -A+B*E ) / F
END IF
*
RETURN
*
* End of DLADIV
*
END
SUBROUTINE DLAE2( A, B, C, RT1, RT2 )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. Scalar Arguments ..
DOUBLE PRECISION A, B, C, RT1, RT2
* ..
*
* Purpose
* =======
*
* DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix
* [ A B ]
* [ B C ].
* On return, RT1 is the eigenvalue of larger absolute value, and RT2
* is the eigenvalue of smaller absolute value.
*
* Arguments
* =========
*
* A (input) DOUBLE PRECISION
* The (1,1) element of the 2-by-2 matrix.
*
* B (input) DOUBLE PRECISION
* The (1,2) and (2,1) elements of the 2-by-2 matrix.
*
* C (input) DOUBLE PRECISION
* The (2,2) element of the 2-by-2 matrix.
*
* RT1 (output) DOUBLE PRECISION
* The eigenvalue of larger absolute value.
*
* RT2 (output) DOUBLE PRECISION
* The eigenvalue of smaller absolute value.
*
* Further Details
* ===============
*
* RT1 is accurate to a few ulps barring over/underflow.
*
* RT2 may be inaccurate if there is massive cancellation in the
* determinant A*C-B*B; higher precision or correctly rounded or
* correctly truncated arithmetic would be needed to compute RT2
* accurately in all cases.
*
* Overflow is possible only if RT1 is within a factor of 5 of overflow.
* Underflow is harmless if the input data is 0 or exceeds
* underflow_threshold / macheps.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D0 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = 0.5D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION AB, ACMN, ACMX, ADF, DF, RT, SM, TB
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
* Compute the eigenvalues
*
SM = A + C
DF = A - C
ADF = ABS( DF )
TB = B + B
AB = ABS( TB )
IF( ABS( A ).GT.ABS( C ) ) THEN
ACMX = A
ACMN = C
ELSE
ACMX = C
ACMN = A
END IF
IF( ADF.GT.AB ) THEN
RT = ADF*SQRT( ONE+( AB / ADF )**2 )
ELSE IF( ADF.LT.AB ) THEN
RT = AB*SQRT( ONE+( ADF / AB )**2 )
ELSE
*
* Includes case AB=ADF=0
*
RT = AB*SQRT( TWO )
END IF
IF( SM.LT.ZERO ) THEN
RT1 = HALF*( SM-RT )
*
* Order of execution important.
* To get fully accurate smaller eigenvalue,
* next line needs to be executed in higher precision.
*
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
ELSE IF( SM.GT.ZERO ) THEN
RT1 = HALF*( SM+RT )
*
* Order of execution important.
* To get fully accurate smaller eigenvalue,
* next line needs to be executed in higher precision.
*
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
ELSE
*
* Includes case RT1 = RT2 = 0
*
RT1 = HALF*RT
RT2 = -HALF*RT
END IF
RETURN
*
* End of DLAE2
*
END
SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. Scalar Arguments ..
DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1
* ..
*
* Purpose
* =======
*
* DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix
* [ A B ]
* [ B C ].
* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the
* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right
* eigenvector for RT1, giving the decomposition
*
* [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ]
* [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ].
*
* Arguments
* =========
*
* A (input) DOUBLE PRECISION
* The (1,1) element of the 2-by-2 matrix.
*
* B (input) DOUBLE PRECISION
* The (1,2) element and the conjugate of the (2,1) element of
* the 2-by-2 matrix.
*
* C (input) DOUBLE PRECISION
* The (2,2) element of the 2-by-2 matrix.
*
* RT1 (output) DOUBLE PRECISION
* The eigenvalue of larger absolute value.
*
* RT2 (output) DOUBLE PRECISION
* The eigenvalue of smaller absolute value.
*
* CS1 (output) DOUBLE PRECISION
* SN1 (output) DOUBLE PRECISION
* The vector (CS1, SN1) is a unit right eigenvector for RT1.
*
* Further Details
* ===============
*
* RT1 is accurate to a few ulps barring over/underflow.
*
* RT2 may be inaccurate if there is massive cancellation in the
* determinant A*C-B*B; higher precision or correctly rounded or
* correctly truncated arithmetic would be needed to compute RT2
* accurately in all cases.
*
* CS1 and SN1 are accurate to a few ulps barring over/underflow.
*
* Overflow is possible only if RT1 is within a factor of 5 of overflow.
* Underflow is harmless if the input data is 0 or exceeds
* underflow_threshold / macheps.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D0 )
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = 0.5D0 )
* ..
* .. Local Scalars ..
INTEGER SGN1, SGN2
DOUBLE PRECISION AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM,
$ TB, TN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
* Compute the eigenvalues
*
SM = A + C
DF = A - C
ADF = ABS( DF )
TB = B + B
AB = ABS( TB )
IF( ABS( A ).GT.ABS( C ) ) THEN
ACMX = A
ACMN = C
ELSE
ACMX = C
ACMN = A
END IF
IF( ADF.GT.AB ) THEN
RT = ADF*SQRT( ONE+( AB / ADF )**2 )
ELSE IF( ADF.LT.AB ) THEN
RT = AB*SQRT( ONE+( ADF / AB )**2 )
ELSE
*
* Includes case AB=ADF=0
*
RT = AB*SQRT( TWO )
END IF
IF( SM.LT.ZERO ) THEN
RT1 = HALF*( SM-RT )
SGN1 = -1
*
* Order of execution important.
* To get fully accurate smaller eigenvalue,
* next line needs to be executed in higher precision.
*
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
ELSE IF( SM.GT.ZERO ) THEN
RT1 = HALF*( SM+RT )
SGN1 = 1
*
* Order of execution important.
* To get fully accurate smaller eigenvalue,
* next line needs to be executed in higher precision.
*
RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
ELSE
*
* Includes case RT1 = RT2 = 0
*
RT1 = HALF*RT
RT2 = -HALF*RT
SGN1 = 1
END IF
*
* Compute the eigenvector
*
IF( DF.GE.ZERO ) THEN
CS = DF + RT
SGN2 = 1
ELSE
CS = DF - RT
SGN2 = -1
END IF
ACS = ABS( CS )
IF( ACS.GT.AB ) THEN
CT = -TB / CS
SN1 = ONE / SQRT( ONE+CT*CT )
CS1 = CT*SN1
ELSE
IF( AB.EQ.ZERO ) THEN
CS1 = ONE
SN1 = ZERO
ELSE
TN = -CS / TB
CS1 = ONE / SQRT( ONE+TN*TN )
SN1 = TN*CS1
END IF
END IF
IF( SGN1.EQ.SGN2 ) THEN
TN = CS1
CS1 = -SN1
SN1 = TN
END IF
RETURN
*
* End of DLAEV2
*
END
DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
* ..
*
* Purpose
* =======
*
* DLANST 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 tridiagonal matrix A.
*
* Description
* ===========
*
* DLANST returns the value
*
* DLANST = ( 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 matrix norm.
*
* Arguments
* =========
*
* NORM (input) CHARACTER*1
* Specifies the value to be returned in DLANST as described
* above.
*
* N (input) INTEGER
* The order of the matrix A. N >= 0. When N = 0, DLANST is
* set to zero.
*
* D (input) DOUBLE PRECISION array, dimension (N)
* The diagonal elements of A.
*
* E (input) DOUBLE PRECISION array, dimension (N-1)
* The (n-1) sub-diagonal or super-diagonal elements of A.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION ANORM, SCALE, SUM
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DLASSQ
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
IF( N.LE.0 ) THEN
ANORM = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
ANORM = ABS( D( N ) )
DO 10 I = 1, N - 1
ANORM = MAX( ANORM, ABS( D( I ) ) )
ANORM = MAX( ANORM, ABS( E( I ) ) )
10 CONTINUE
ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR.
$ LSAME( NORM, 'I' ) ) THEN
*
* Find norm1(A).
*
IF( N.EQ.1 ) THEN
ANORM = ABS( D( 1 ) )
ELSE
ANORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ),
$ ABS( E( N-1 ) )+ABS( D( N ) ) )
DO 20 I = 2, N - 1
ANORM = MAX( ANORM, ABS( D( I ) )+ABS( E( I ) )+
$ ABS( E( I-1 ) ) )
20 CONTINUE
END IF
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
IF( N.GT.1 ) THEN
CALL DLASSQ( N-1, E, 1, SCALE, SUM )
SUM = 2*SUM
END IF
CALL DLASSQ( N, D, 1, SCALE, SUM )
ANORM = SCALE*SQRT( SUM )
END IF
*
DLANST = ANORM
RETURN
*
* End of DLANST
*
END
DOUBLE PRECISION FUNCTION DLAPY2( X, Y )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. Scalar Arguments ..
DOUBLE PRECISION X, Y
* ..
*
* Purpose
* =======
*
* DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
* overflow.
*
* Arguments
* =========
*
* X (input) DOUBLE PRECISION
* Y (input) DOUBLE PRECISION
* X and Y specify the values x and y.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION W, XABS, YABS, Z
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
XABS = ABS( X )
YABS = ABS( Y )
W = MAX( XABS, YABS )
Z = MIN( XABS, YABS )
IF( Z.EQ.ZERO ) THEN
DLAPY2 = W
ELSE
DLAPY2 = W*SQRT( ONE+( Z / W )**2 )
END IF
RETURN
*
* End of DLAPY2
*
END
DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. Scalar Arguments ..
DOUBLE PRECISION X, Y, Z
* ..
*
* Purpose
* =======
*
* DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
* unnecessary overflow.
*
* Arguments
* =========
*
* X (input) DOUBLE PRECISION
* Y (input) DOUBLE PRECISION
* Z (input) DOUBLE PRECISION
* X, Y and Z specify the values x, y and z.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION W, XABS, YABS, ZABS
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
XABS = ABS( X )
YABS = ABS( Y )
ZABS = ABS( Z )
W = MAX( XABS, YABS, ZABS )
IF( W.EQ.ZERO ) THEN
DLAPY3 = ZERO
ELSE
DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+
$ ( ZABS / W )**2 )
END IF
RETURN
*
* End of DLAPY3
*
END
SUBROUTINE DLARTG( F, G, CS, SN, R )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
DOUBLE PRECISION CS, F, G, R, SN
* ..
*
* Purpose
* =======
*
* DLARTG generate a plane rotation so that
*
* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.
* [ -SN CS ] [ G ] [ 0 ]
*
* This is a slower, more accurate version of the BLAS1 routine DROTG,
* with the following other differences:
* F and G are unchanged on return.
* If G=0, then CS=1 and SN=0.
* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any
* floating point operations (saves work in DBDSQR when
* there are zeros on the diagonal).
*
* If F exceeds G in magnitude, CS will be positive.
*
* Arguments
* =========
*
* F (input) DOUBLE PRECISION
* The first component of vector to be rotated.
*
* G (input) DOUBLE PRECISION
* The second component of vector to be rotated.
*
* CS (output) DOUBLE PRECISION
* The cosine of the rotation.
*
* SN (output) DOUBLE PRECISION
* The sine of the rotation.
*
* R (output) DOUBLE PRECISION
* The nonzero component of the rotated vector.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D0 )
* ..
* .. Local Scalars ..
LOGICAL FIRST
INTEGER COUNT, I
DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, INT, LOG, MAX, SQRT
* ..
* .. Save statement ..
SAVE FIRST, SAFMX2, SAFMIN, SAFMN2
* ..
* .. Data statements ..
DATA FIRST / .TRUE. /
* ..
* .. Executable Statements ..
*
IF( FIRST ) THEN
FIRST = .FALSE.
SAFMIN = DLAMCH( 'S' )
EPS = DLAMCH( 'E' )
SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
$ LOG( DLAMCH( 'B' ) ) / TWO )
SAFMX2 = ONE / SAFMN2
END IF
IF( G.EQ.ZERO ) THEN
CS = ONE
SN = ZERO
R = F
ELSE IF( F.EQ.ZERO ) THEN
CS = ZERO
SN = ONE
R = G
ELSE
F1 = F
G1 = G
SCALE = MAX( ABS( F1 ), ABS( G1 ) )
IF( SCALE.GE.SAFMX2 ) THEN
COUNT = 0
10 CONTINUE
COUNT = COUNT + 1
F1 = F1*SAFMN2
G1 = G1*SAFMN2
SCALE = MAX( ABS( F1 ), ABS( G1 ) )
IF( SCALE.GE.SAFMX2 )
$ GO TO 10
R = SQRT( F1**2+G1**2 )
CS = F1 / R
SN = G1 / R
DO 20 I = 1, COUNT
R = R*SAFMX2
20 CONTINUE
ELSE IF( SCALE.LE.SAFMN2 ) THEN
COUNT = 0
30 CONTINUE
COUNT = COUNT + 1
F1 = F1*SAFMX2
G1 = G1*SAFMX2
SCALE = MAX( ABS( F1 ), ABS( G1 ) )
IF( SCALE.LE.SAFMN2 )
$ GO TO 30
R = SQRT( F1**2+G1**2 )
CS = F1 / R
SN = G1 / R
DO 40 I = 1, COUNT
R = R*SAFMN2
40 CONTINUE
ELSE
R = SQRT( F1**2+G1**2 )
CS = F1 / R
SN = G1 / R
END IF
IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN
CS = -CS
SN = -SN
R = -R
END IF
END IF
RETURN
*
* End of DLARTG
*
END
SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. Scalar Arguments ..
CHARACTER TYPE
INTEGER INFO, KL, KU, LDA, M, N
DOUBLE PRECISION CFROM, CTO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* Purpose
* =======
*
* DLASCL multiplies the M by N real matrix A by the real scalar
* CTO/CFROM. This is done without over/underflow as long as the final
* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
* A may be full, upper triangular, lower triangular, upper Hessenberg,
* or banded.
*
* Arguments
* =========
*
* TYPE (input) CHARACTER*1
* TYPE indices the storage type of the input matrix.
* = 'G': A is a full matrix.
* = 'L': A is a lower triangular matrix.
* = 'U': A is an upper triangular matrix.
* = 'H': A is an upper Hessenberg matrix.
* = 'B': A is a symmetric band matrix with lower bandwidth KL
* and upper bandwidth KU and with the only the lower
* half stored.
* = 'Q': A is a symmetric band matrix with lower bandwidth KL
* and upper bandwidth KU and with the only the upper
* half stored.
* = 'Z': A is a band matrix with lower bandwidth KL and upper
* bandwidth KU.
*
* KL (input) INTEGER
* The lower bandwidth of A. Referenced only if TYPE = 'B',
* 'Q' or 'Z'.
*
* KU (input) INTEGER
* The upper bandwidth of A. Referenced only if TYPE = 'B',
* 'Q' or 'Z'.
*
* CFROM (input) DOUBLE PRECISION
* CTO (input) DOUBLE PRECISION
* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
* without over/underflow if the final result CTO*A(I,J)/CFROM
* can be represented without over/underflow. CFROM must be
* nonzero.
*
* M (input) INTEGER
* The number of rows of the matrix A. M >= 0.
*
* N (input) INTEGER
* The number of columns of the matrix A. N >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,M)
* The matrix to be multiplied by CTO/CFROM. See TYPE for the
* storage type.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,M).
*
* INFO (output) INTEGER
* 0 - successful exit
* <0 - if INFO = -i, the i-th argument had an illegal value.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
LOGICAL DONE
INTEGER I, ITYPE, J, K1, K2, K3, K4
DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
*
IF( LSAME( TYPE, 'G' ) ) THEN
ITYPE = 0
ELSE IF( LSAME( TYPE, 'L' ) ) THEN
ITYPE = 1
ELSE IF( LSAME( TYPE, 'U' ) ) THEN
ITYPE = 2
ELSE IF( LSAME( TYPE, 'H' ) ) THEN
ITYPE = 3
ELSE IF( LSAME( TYPE, 'B' ) ) THEN
ITYPE = 4
ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
ITYPE = 5
ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
ITYPE = 6
ELSE
ITYPE = -1
END IF
*
IF( ITYPE.EQ.-1 ) THEN
INFO = -1
ELSE IF( CFROM.EQ.ZERO ) THEN
INFO = -4
ELSE IF( M.LT.0 ) THEN
INFO = -6
ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
$ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
INFO = -7
ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
INFO = -9
ELSE IF( ITYPE.GE.4 ) THEN
IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
INFO = -2
ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
$ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
$ THEN
INFO = -3
ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
$ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
$ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
INFO = -9
END IF
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASCL', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 .OR. M.EQ.0 )
$ RETURN
*
* Get machine parameters
*
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
*
CFROMC = CFROM
CTOC = CTO
*
10 CONTINUE
CFROM1 = CFROMC*SMLNUM
CTO1 = CTOC / BIGNUM
IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
MUL = SMLNUM
DONE = .FALSE.
CFROMC = CFROM1
ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
MUL = BIGNUM
DONE = .FALSE.
CTOC = CTO1
ELSE
MUL = CTOC / CFROMC
DONE = .TRUE.
END IF
*
IF( ITYPE.EQ.0 ) THEN
*
* Full matrix
*
DO 30 J = 1, N
DO 20 I = 1, M
A( I, J ) = A( I, J )*MUL
20 CONTINUE
30 CONTINUE
*
ELSE IF( ITYPE.EQ.1 ) THEN
*
* Lower triangular matrix
*
DO 50 J = 1, N
DO 40 I = J, M
A( I, J ) = A( I, J )*MUL
40 CONTINUE
50 CONTINUE
*
ELSE IF( ITYPE.EQ.2 ) THEN
*
* Upper triangular matrix
*
DO 70 J = 1, N
DO 60 I = 1, MIN( J, M )
A( I, J ) = A( I, J )*MUL
60 CONTINUE
70 CONTINUE
*
ELSE IF( ITYPE.EQ.3 ) THEN
*
* Upper Hessenberg matrix
*
DO 90 J = 1, N
DO 80 I = 1, MIN( J+1, M )
A( I, J ) = A( I, J )*MUL
80 CONTINUE
90 CONTINUE
*
ELSE IF( ITYPE.EQ.4 ) THEN
*
* Lower half of a symmetric band matrix
*
K3 = KL + 1
K4 = N + 1
DO 110 J = 1, N
DO 100 I = 1, MIN( K3, K4-J )
A( I, J ) = A( I, J )*MUL
100 CONTINUE
110 CONTINUE
*
ELSE IF( ITYPE.EQ.5 ) THEN
*
* Upper half of a symmetric band matrix
*
K1 = KU + 2
K3 = KU + 1
DO 130 J = 1, N
DO 120 I = MAX( K1-J, 1 ), K3
A( I, J ) = A( I, J )*MUL
120 CONTINUE
130 CONTINUE
*
ELSE IF( ITYPE.EQ.6 ) THEN
*
* Band matrix
*
K1 = KL + KU + 2
K2 = KL + 1
K3 = 2*KL + KU + 1
K4 = KL + KU + 1 + M
DO 150 J = 1, N
DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
A( I, J ) = A( I, J )*MUL
140 CONTINUE
150 CONTINUE
*
END IF
*
IF( .NOT.DONE )
$ GO TO 10
*
RETURN
*
* End of DLASCL
*
END
SUBROUTINE DLASRT( ID, N, D, INFO )
*
* -- LAPACK routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
CHARACTER ID
INTEGER INFO, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * )
* ..
*
* Purpose
* =======
*
* Sort the numbers in D in increasing order (if ID = 'I') or
* in decreasing order (if ID = 'D' ).
*
* Use Quick Sort, reverting to Insertion sort on arrays of
* size <= 20. Dimension of STACK limits N to about 2**32.
*
* Arguments
* =========
*
* ID (input) CHARACTER*1
* = 'I': sort D in increasing order;
* = 'D': sort D in decreasing order.
*
* N (input) INTEGER
* The length of the array D.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the array to be sorted.
* On exit, D has been sorted into increasing order
* (D(1) <= ... <= D(N) ) or into decreasing order
* (D(1) >= ... >= D(N) ), depending on ID.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
* =====================================================================
*
* .. Parameters ..
INTEGER SELECT
PARAMETER ( SELECT = 20 )
* ..
* .. Local Scalars ..
INTEGER DIR, ENDD, I, J, START, STKPNT
DOUBLE PRECISION D1, D2, D3, DMNMX, TMP
* ..
* .. Local Arrays ..
INTEGER STACK( 2, 32 )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
*
* Test the input paramters.
*
INFO = 0
DIR = -1
IF( LSAME( ID, 'D' ) ) THEN
DIR = 0
ELSE IF( LSAME( ID, 'I' ) ) THEN
DIR = 1
END IF
IF( DIR.EQ.-1 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLASRT', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.1 )
$ RETURN
*
STKPNT = 1
STACK( 1, 1 ) = 1
STACK( 2, 1 ) = N
10 CONTINUE
START = STACK( 1, STKPNT )
ENDD = STACK( 2, STKPNT )
STKPNT = STKPNT - 1
IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN
*
* Do Insertion sort on D( START:ENDD )
*
IF( DIR.EQ.0 ) THEN
*
* Sort into decreasing order
*
DO 30 I = START + 1, ENDD
DO 20 J = I, START + 1, -1
IF( D( J ).GT.D( J-1 ) ) THEN
DMNMX = D( J )
D( J ) = D( J-1 )
D( J-1 ) = DMNMX
ELSE
GO TO 30
END IF
20 CONTINUE
30 CONTINUE
*
ELSE
*
* Sort into increasing order
*
DO 50 I = START + 1, ENDD
DO 40 J = I, START + 1, -1
IF( D( J ).LT.D( J-1 ) ) THEN
DMNMX = D( J )
D( J ) = D( J-1 )
D( J-1 ) = DMNMX
ELSE
GO TO 50
END IF
40 CONTINUE
50 CONTINUE
*
END IF
*
ELSE IF( ENDD-START.GT.SELECT ) THEN
*
* Partition D( START:ENDD ) and stack parts, largest one first
*
* Choose partition entry as median of 3
*
D1 = D( START )
D2 = D( ENDD )
I = ( START+ENDD ) / 2
D3 = D( I )
IF( D1.LT.D2 ) THEN
IF( D3.LT.D1 ) THEN
DMNMX = D1
ELSE IF( D3.LT.D2 ) THEN
DMNMX = D3
ELSE
DMNMX = D2
END IF
ELSE
IF( D3.LT.D2 ) THEN
DMNMX = D2
ELSE IF( D3.LT.D1 ) THEN
DMNMX = D3
ELSE
DMNMX = D1
END IF
END IF
*
IF( DIR.EQ.0 ) THEN
*
* Sort into decreasing order
*
I = START - 1
J = ENDD + 1
60 CONTINUE
70 CONTINUE
J = J - 1
IF( D( J ).LT.DMNMX )
$ GO TO 70
80 CONTINUE
I = I + 1
IF( D( I ).GT.DMNMX )
$ GO TO 80
IF( I.LT.J ) THEN
TMP = D( I )
D( I ) = D( J )
D( J ) = TMP
GO TO 60
END IF
IF( J-START.GT.ENDD-J-1 ) THEN
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = START
STACK( 2, STKPNT ) = J
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = J + 1
STACK( 2, STKPNT ) = ENDD
ELSE
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = J + 1
STACK( 2, STKPNT ) = ENDD
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = START
STACK( 2, STKPNT ) = J
END IF
ELSE
*
* Sort into increasing order
*
I = START - 1
J = ENDD + 1
90 CONTINUE
100 CONTINUE
J = J - 1
IF( D( J ).GT.DMNMX )
$ GO TO 100
110 CONTINUE
I = I + 1
IF( D( I ).LT.DMNMX )
$ GO TO 110
IF( I.LT.J ) THEN
TMP = D( I )
D( I ) = D( J )
D( J ) = TMP
GO TO 90
END IF
IF( J-START.GT.ENDD-J-1 ) THEN
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = START
STACK( 2, STKPNT ) = J
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = J + 1
STACK( 2, STKPNT ) = ENDD
ELSE
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = J + 1
STACK( 2, STKPNT ) = ENDD
STKPNT = STKPNT + 1
STACK( 1, STKPNT ) = START
STACK( 2, STKPNT ) = J
END IF
END IF
END IF
IF( STKPNT.GT.0 )
$ GO TO 10
RETURN
*
* End of DLASRT
*
END
SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. Scalar Arguments ..
INTEGER INCX, N
DOUBLE PRECISION SCALE, SUMSQ
* ..
* .. Array Arguments ..
DOUBLE PRECISION X( * )
* ..
*
* Purpose
* =======
*
* DLASSQ returns the values scl and smsq such that
*
* ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
*
* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is
* assumed to be non-negative and scl returns the value
*
* scl = max( scale, abs( x( i ) ) ).
*
* scale and sumsq must be supplied in SCALE and SUMSQ and
* scl and smsq are overwritten on SCALE and SUMSQ respectively.
*
* The routine makes only one pass through the vector x.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of elements to be used from the vector X.
*
* X (input) DOUBLE PRECISION
* The vector for which a scaled sum of squares is computed.
* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
*
* INCX (input) INTEGER
* The increment between successive values of the vector X.
* INCX > 0.
*
* SCALE (input/output) DOUBLE PRECISION
* On entry, the value scale in the equation above.
* On exit, SCALE is overwritten with scl , the scaling factor
* for the sum of squares.
*
* SUMSQ (input/output) DOUBLE PRECISION
* On entry, the value sumsq in the equation above.
* On exit, SUMSQ is overwritten with smsq , the basic sum of
* squares from which scl has been factored out.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER IX
DOUBLE PRECISION ABSXI
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
IF( N.GT.0 ) THEN
DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
IF( X( IX ).NE.ZERO ) THEN
ABSXI = ABS( X( IX ) )
IF( SCALE.LT.ABSXI ) THEN
SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2
SCALE = ABSXI
ELSE
SUMSQ = SUMSQ + ( ABSXI / SCALE )**2
END IF
END IF
10 CONTINUE
END IF
RETURN
*
* End of DLASSQ
*
END
SUBROUTINE DSTERF( N, D, E, INFO )
*
* -- LAPACK routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
INTEGER INFO, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION D( * ), E( * )
* ..
*
* Purpose
* =======
*
* DSTERF computes all eigenvalues of a symmetric tridiagonal matrix
* using the Pal-Walker-Kahan variant of the QL or QR algorithm.
*
* Arguments
* =========
*
* N (input) INTEGER
* The order of the matrix. N >= 0.
*
* D (input/output) DOUBLE PRECISION array, dimension (N)
* On entry, the n diagonal elements of the tridiagonal matrix.
* On exit, if INFO = 0, the eigenvalues in ascending order.
*
* E (input/output) DOUBLE PRECISION array, dimension (N-1)
* On entry, the (n-1) subdiagonal elements of the tridiagonal
* matrix.
* On exit, E has been destroyed.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: the algorithm failed to find all of the eigenvalues in
* a total of 30*N iterations; if INFO = i, then i
* elements of E have not converged to zero.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO, THREE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
$ THREE = 3.0D0 )
INTEGER MAXIT
PARAMETER ( MAXIT = 30 )
* ..
* .. Local Scalars ..
INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDM1, LENDP1,
$ LENDSV, LM1, LSV, M, MM1, NM1, NMAXIT
DOUBLE PRECISION ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC,
$ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN,
$ SIGMA, SSFMAX, SSFMIN, TST
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANST, DLAPY2
EXTERNAL DLAMCH, DLANST, DLAPY2
* ..
* .. External Subroutines ..
EXTERNAL DLAE2, DLASCL, DLASRT, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
*
* Quick return if possible
*
IF( N.LT.0 ) THEN
INFO = -1
CALL XERBLA( 'DSTERF', -INFO )
RETURN
END IF
IF( N.LE.1 )
$ RETURN
*
* Determine the unit roundoff for this environment.
*
EPS = DLAMCH( 'E' )
EPS2 = EPS**2
SAFMIN = DLAMCH( 'S' )
SAFMAX = ONE / SAFMIN
SSFMAX = SQRT( SAFMAX ) / THREE
SSFMIN = SQRT( SAFMIN ) / EPS2
*
* Compute the eigenvalues of the tridiagonal matrix.
*
NMAXIT = N*MAXIT
SIGMA = ZERO
JTOT = 0
*
* Determine where the matrix splits and choose QL or QR iteration
* for each block, according to whether top or bottom diagonal
* element is smaller.
*
L1 = 1
NM1 = N - 1
*
10 CONTINUE
IF( L1.GT.N )
$ GO TO 170
IF( L1.GT.1 )
$ E( L1-1 ) = ZERO
IF( L1.LE.NM1 ) THEN
DO 20 M = L1, NM1
TST = ABS( E( M ) )
IF( TST.EQ.ZERO )
$ GO TO 30
IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+
$ 1 ) ) ) )*EPS ) THEN
E( M ) = ZERO
GO TO 30
END IF
20 CONTINUE
END IF
M = N
*
30 CONTINUE
L = L1
LSV = L
LEND = M
LENDSV = LEND
L1 = M + 1
IF( LEND.EQ.L )
$ GO TO 10
*
* Scale submatrix in rows and columns L to LEND
*
ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) )
ISCALE = 0
IF( ANORM.GT.SSFMAX ) THEN
ISCALE = 1
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
$ INFO )
ELSE IF( ANORM.LT.SSFMIN ) THEN
ISCALE = 2
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
$ INFO )
CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
$ INFO )
END IF
*
DO 40 I = L, LEND - 1
E( I ) = E( I )**2
40 CONTINUE
*
* Choose between QL and QR iteration
*
IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
LEND = LSV
L = LENDSV
END IF
*
IF( LEND.GE.L ) THEN
*
* QL Iteration
*
* Look for small subdiagonal element.
*
50 CONTINUE
IF( L.NE.LEND ) THEN
LENDM1 = LEND - 1
DO 60 M = L, LENDM1
TST = ABS( E( M ) )
IF( TST.LE.EPS2*ABS( D( M )*D( M+1 ) ) )
$ GO TO 70
60 CONTINUE
END IF
*
M = LEND
*
70 CONTINUE
IF( M.LT.LEND )
$ E( M ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 90
*
* If remaining matrix is 2 by 2, use DLAE2 to compute its
* eigenvalues.
*
IF( M.EQ.L+1 ) THEN
RTE = SQRT( E( L ) )
CALL DLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 )
D( L ) = RT1
D( L+1 ) = RT2
E( L ) = ZERO
L = L + 2
IF( L.LE.LEND )
$ GO TO 50
GO TO 150
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 150
JTOT = JTOT + 1
*
* Form shift.
*
RTE = SQRT( E( L ) )
SIGMA = ( D( L+1 )-P ) / ( TWO*RTE )
R = DLAPY2( SIGMA, ONE )
SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
*
C = ONE
S = ZERO
GAMMA = D( M ) - SIGMA
P = GAMMA*GAMMA
*
* Inner loop
*
MM1 = M - 1
DO 80 I = MM1, L, -1
BB = E( I )
R = P + BB
IF( I.NE.M-1 )
$ E( I+1 ) = S*R
OLDC = C
C = P / R
S = BB / R
OLDGAM = GAMMA
ALPHA = D( I )
GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
D( I+1 ) = OLDGAM + ( ALPHA-GAMMA )
IF( C.NE.ZERO ) THEN
P = ( GAMMA*GAMMA ) / C
ELSE
P = OLDC*BB
END IF
80 CONTINUE
*
E( L ) = S*P
D( L ) = SIGMA + GAMMA
GO TO 50
*
* Eigenvalue found.
*
90 CONTINUE
D( L ) = P
*
L = L + 1
IF( L.LE.LEND )
$ GO TO 50
GO TO 150
*
ELSE
*
* QR Iteration
*
* Look for small superdiagonal element.
*
100 CONTINUE
IF( L.NE.LEND ) THEN
LENDP1 = LEND + 1
DO 110 M = L, LENDP1, -1
TST = ABS( E( M-1 ) )
IF( TST.LE.EPS2*ABS( D( M )*D( M-1 ) ) )
$ GO TO 120
110 CONTINUE
END IF
*
M = LEND
*
120 CONTINUE
IF( M.GT.LEND )
$ E( M-1 ) = ZERO
P = D( L )
IF( M.EQ.L )
$ GO TO 140
*
* If remaining matrix is 2 by 2, use DLAE2 to compute its
* eigenvalues.
*
IF( M.EQ.L-1 ) THEN
RTE = SQRT( E( L-1 ) )
CALL DLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 )
D( L ) = RT1
D( L-1 ) = RT2
E( L-1 ) = ZERO
L = L - 2
IF( L.GE.LEND )
$ GO TO 100
GO TO 150
END IF
*
IF( JTOT.EQ.NMAXIT )
$ GO TO 150
JTOT = JTOT + 1
*
* Form shift.
*
RTE = SQRT( E( L-1 ) )
SIGMA = ( D( L-1 )-P ) / ( TWO*RTE )
R = DLAPY2( SIGMA, ONE )
SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
*
C = ONE
S = ZERO
GAMMA = D( M ) - SIGMA
P = GAMMA*GAMMA
*
* Inner loop
*
LM1 = L - 1
DO 130 I = M, LM1
BB = E( I )
R = P + BB
IF( I.NE.M )
$ E( I-1 ) = S*R
OLDC = C
C = P / R
S = BB / R
OLDGAM = GAMMA
ALPHA = D( I+1 )
GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
D( I ) = OLDGAM + ( ALPHA-GAMMA )
IF( C.NE.ZERO ) THEN
P = ( GAMMA*GAMMA ) / C
ELSE
P = OLDC*BB
END IF
130 CONTINUE
*
E( LM1 ) = S*P
D( L ) = SIGMA + GAMMA
GO TO 100
*
* Eigenvalue found.
*
140 CONTINUE
D( L ) = P
*
L = L - 1
IF( L.GE.LEND )
$ GO TO 100
GO TO 150
*
END IF
*
* Undo scaling if necessary
*
150 CONTINUE
IF( ISCALE.EQ.1 )
$ CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
IF( ISCALE.EQ.2 )
$ CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
$ D( LSV ), N, INFO )
*
* Check for no convergence to an eigenvalue after a total
* of N*MAXIT iterations.
*
IF( JTOT.EQ.NMAXIT ) THEN
DO 160 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
160 CONTINUE
RETURN
END IF
GO TO 10
*
* Sort eigenvalues in increasing order.
*
170 CONTINUE
CALL DLASRT( 'I', N, D, INFO )
*
RETURN
*
* End of DSTERF
*
END
DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. Scalar Arguments ..
CHARACTER CMACH
* ..
*
* Purpose
* =======
*
* DLAMCH determines double precision machine parameters.
*
* Arguments
* =========
*
* CMACH (input) CHARACTER*1
* Specifies the value to be returned by DLAMCH:
* = 'E' or 'e', DLAMCH := eps
* = 'S' or 's , DLAMCH := sfmin
* = 'B' or 'b', DLAMCH := base
* = 'P' or 'p', DLAMCH := eps*base
* = 'N' or 'n', DLAMCH := t
* = 'R' or 'r', DLAMCH := rnd
* = 'M' or 'm', DLAMCH := emin
* = 'U' or 'u', DLAMCH := rmin
* = 'L' or 'l', DLAMCH := emax
* = 'O' or 'o', DLAMCH := rmax
*
* where
*
* eps = relative machine precision
* sfmin = safe minimum, such that 1/sfmin does not overflow
* base = base of the machine
* prec = eps*base
* t = number of (base) digits in the mantissa
* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
* emin = minimum exponent before (gradual) underflow
* rmin = underflow threshold - base**(emin-1)
* emax = largest exponent before overflow
* rmax = overflow threshold - (base**emax)*(1-eps)
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL FIRST, LRND
INTEGER BETA, IMAX, IMIN, IT
DOUBLE PRECISION BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN,
$ RND, SFMIN, SMALL, T
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DLAMC2
* ..
* .. Save statement ..
SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN,
$ EMAX, RMAX, PREC
* ..
* .. Data statements ..
DATA FIRST / .TRUE. /
* ..
* .. Executable Statements ..
*
IF( FIRST ) THEN
FIRST = .FALSE.
CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX )
BASE = BETA
T = IT
IF( LRND ) THEN
RND = ONE
EPS = ( BASE**( 1-IT ) ) / 2
ELSE
RND = ZERO
EPS = BASE**( 1-IT )
END IF
PREC = EPS*BASE
EMIN = IMIN
EMAX = IMAX
SFMIN = RMIN
SMALL = ONE / RMAX
IF( SMALL.GE.SFMIN ) THEN
*
* Use SMALL plus a bit, to avoid the possibility of rounding
* causing overflow when computing 1/sfmin.
*
SFMIN = SMALL*( ONE+EPS )
END IF
END IF
*
IF( LSAME( CMACH, 'E' ) ) THEN
RMACH = EPS
ELSE IF( LSAME( CMACH, 'S' ) ) THEN
RMACH = SFMIN
ELSE IF( LSAME( CMACH, 'B' ) ) THEN
RMACH = BASE
ELSE IF( LSAME( CMACH, 'P' ) ) THEN
RMACH = PREC
ELSE IF( LSAME( CMACH, 'N' ) ) THEN
RMACH = T
ELSE IF( LSAME( CMACH, 'R' ) ) THEN
RMACH = RND
ELSE IF( LSAME( CMACH, 'M' ) ) THEN
RMACH = EMIN
ELSE IF( LSAME( CMACH, 'U' ) ) THEN
RMACH = RMIN
ELSE IF( LSAME( CMACH, 'L' ) ) THEN
RMACH = EMAX
ELSE IF( LSAME( CMACH, 'O' ) ) THEN
RMACH = RMAX
END IF
*
DLAMCH = RMACH
RETURN
*
* End of DLAMCH
*
END
*
************************************************************************
*
SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. Scalar Arguments ..
LOGICAL IEEE1, RND
INTEGER BETA, T
* ..
*
* Purpose
* =======
*
* DLAMC1 determines the machine parameters given by BETA, T, RND, and
* IEEE1.
*
* Arguments
* =========
*
* BETA (output) INTEGER
* The base of the machine.
*
* T (output) INTEGER
* The number of ( BETA ) digits in the mantissa.
*
* RND (output) LOGICAL
* Specifies whether proper rounding ( RND = .TRUE. ) or
* chopping ( RND = .FALSE. ) occurs in addition. This may not
* be a reliable guide to the way in which the machine performs
* its arithmetic.
*
* IEEE1 (output) LOGICAL
* Specifies whether rounding appears to be done in the IEEE
* 'round to nearest' style.
*
* Further Details
* ===============
*
* The routine is based on the routine ENVRON by Malcolm and
* incorporates suggestions by Gentleman and Marovich. See
*
* Malcolm M. A. (1972) Algorithms to reveal properties of
* floating-point arithmetic. Comms. of the ACM, 15, 949-951.
*
* Gentleman W. M. and Marovich S. B. (1974) More on algorithms
* that reveal properties of floating point arithmetic units.
* Comms. of the ACM, 17, 276-277.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL FIRST, LIEEE1, LRND
INTEGER LBETA, LT
DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMC3
EXTERNAL DLAMC3
* ..
* .. Save statement ..
SAVE FIRST, LIEEE1, LBETA, LRND, LT
* ..
* .. Data statements ..
DATA FIRST / .TRUE. /
* ..
* .. Executable Statements ..
*
IF( FIRST ) THEN
FIRST = .FALSE.
ONE = 1
*
* LBETA, LIEEE1, LT and LRND are the local values of BETA,
* IEEE1, T and RND.
*
* Throughout this routine we use the function DLAMC3 to ensure
* that relevant values are stored and not held in registers, or
* are not affected by optimizers.
*
* Compute a = 2.0**m with the smallest positive integer m such
* that
*
* fl( a + 1.0 ) = a.
*
A = 1
C = 1
*
*+ WHILE( C.EQ.ONE )LOOP
10 CONTINUE
IF( C.EQ.ONE ) THEN
A = 2*A
C = DLAMC3( A, ONE )
C = DLAMC3( C, -A )
GO TO 10
END IF
*+ END WHILE
*
* Now compute b = 2.0**m with the smallest positive integer m
* such that
*
* fl( a + b ) .gt. a.
*
B = 1
C = DLAMC3( A, B )
*
*+ WHILE( C.EQ.A )LOOP
20 CONTINUE
IF( C.EQ.A ) THEN
B = 2*B
C = DLAMC3( A, B )
GO TO 20
END IF
*+ END WHILE
*
* Now compute the base. a and c are neighbouring floating point
* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so
* their difference is beta. Adding 0.25 to c is to ensure that it
* is truncated to beta and not ( beta - 1 ).
*
QTR = ONE / 4
SAVEC = C
C = DLAMC3( C, -A )
LBETA = C + QTR
*
* Now determine whether rounding or chopping occurs, by adding a
* bit less than beta/2 and a bit more than beta/2 to a.
*
B = LBETA
F = DLAMC3( B / 2, -B / 100 )
C = DLAMC3( F, A )
IF( C.EQ.A ) THEN
LRND = .TRUE.
ELSE
LRND = .FALSE.
END IF
F = DLAMC3( B / 2, B / 100 )
C = DLAMC3( F, A )
IF( ( LRND ) .AND. ( C.EQ.A ) )
$ LRND = .FALSE.
*
* Try and decide whether rounding is done in the IEEE 'round to
* nearest' style. B/2 is half a unit in the last place of the two
* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit
* zero, and SAVEC is odd. Thus adding B/2 to A should not change
* A, but adding B/2 to SAVEC should change SAVEC.
*
T1 = DLAMC3( B / 2, A )
T2 = DLAMC3( B / 2, SAVEC )
LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND
*
* Now find the mantissa, t. It should be the integer part of
* log to the base beta of a, however it is safer to determine t
* by powering. So we find t as the smallest positive integer for
* which
*
* fl( beta**t + 1.0 ) = 1.0.
*
LT = 0
A = 1
C = 1
*
*+ WHILE( C.EQ.ONE )LOOP
30 CONTINUE
IF( C.EQ.ONE ) THEN
LT = LT + 1
A = A*LBETA
C = DLAMC3( A, ONE )
C = DLAMC3( C, -A )
GO TO 30
END IF
*+ END WHILE
*
END IF
*
BETA = LBETA
T = LT
RND = LRND
IEEE1 = LIEEE1
RETURN
*
* End of DLAMC1
*
END
*
************************************************************************
*
SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. Scalar Arguments ..
LOGICAL RND
INTEGER BETA, EMAX, EMIN, T
DOUBLE PRECISION EPS, RMAX, RMIN
* ..
*
* Purpose
* =======
*
* DLAMC2 determines the machine parameters specified in its argument
* list.
*
* Arguments
* =========
*
* BETA (output) INTEGER
* The base of the machine.
*
* T (output) INTEGER
* The number of ( BETA ) digits in the mantissa.
*
* RND (output) LOGICAL
* Specifies whether proper rounding ( RND = .TRUE. ) or
* chopping ( RND = .FALSE. ) occurs in addition. This may not
* be a reliable guide to the way in which the machine performs
* its arithmetic.
*
* EPS (output) DOUBLE PRECISION
* The smallest positive number such that
*
* fl( 1.0 - EPS ) .LT. 1.0,
*
* where fl denotes the computed value.
*
* EMIN (output) INTEGER
* The minimum exponent before (gradual) underflow occurs.
*
* RMIN (output) DOUBLE PRECISION
* The smallest normalized number for the machine, given by
* BASE**( EMIN - 1 ), where BASE is the floating point value
* of BETA.
*
* EMAX (output) INTEGER
* The maximum exponent before overflow occurs.
*
* RMAX (output) DOUBLE PRECISION
* The largest positive number for the machine, given by
* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point
* value of BETA.
*
* Further Details
* ===============
*
* The computation of EPS is based on a routine PARANOIA by
* W. Kahan of the University of California at Berkeley.
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND
INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT,
$ NGNMIN, NGPMIN
DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE,
$ SIXTH, SMALL, THIRD, TWO, ZERO
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMC3
EXTERNAL DLAMC3
* ..
* .. External Subroutines ..
EXTERNAL DLAMC1, DLAMC4, DLAMC5
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Save statement ..
SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX,
$ LRMIN, LT
* ..
* .. Data statements ..
DATA FIRST / .TRUE. / , IWARN / .FALSE. /
* ..
* .. Executable Statements ..
*
IF( FIRST ) THEN
FIRST = .FALSE.
ZERO = 0
ONE = 1
TWO = 2
*
* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of
* BETA, T, RND, EPS, EMIN and RMIN.
*
* Throughout this routine we use the function DLAMC3 to ensure
* that relevant values are stored and not held in registers, or
* are not affected by optimizers.
*
* DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1.
*
CALL DLAMC1( LBETA, LT, LRND, LIEEE1 )
*
* Start to find EPS.
*
B = LBETA
A = B**( -LT )
LEPS = A
*
* Try some tricks to see whether or not this is the correct EPS.
*
B = TWO / 3
HALF = ONE / 2
SIXTH = DLAMC3( B, -HALF )
THIRD = DLAMC3( SIXTH, SIXTH )
B = DLAMC3( THIRD, -HALF )
B = DLAMC3( B, SIXTH )
B = ABS( B )
IF( B.LT.LEPS )
$ B = LEPS
*
LEPS = 1
*
*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
10 CONTINUE
IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN
LEPS = B
C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) )
C = DLAMC3( HALF, -C )
B = DLAMC3( HALF, C )
C = DLAMC3( HALF, -B )
B = DLAMC3( HALF, C )
GO TO 10
END IF
*+ END WHILE
*
IF( A.LT.LEPS )
$ LEPS = A
*
* Computation of EPS complete.
*
* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)).
* Keep dividing A by BETA until (gradual) underflow occurs. This
* is detected when we cannot recover the previous A.
*
RBASE = ONE / LBETA
SMALL = ONE
DO 20 I = 1, 3
SMALL = DLAMC3( SMALL*RBASE, ZERO )
20 CONTINUE
A = DLAMC3( ONE, SMALL )
CALL DLAMC4( NGPMIN, ONE, LBETA )
CALL DLAMC4( NGNMIN, -ONE, LBETA )
CALL DLAMC4( GPMIN, A, LBETA )
CALL DLAMC4( GNMIN, -A, LBETA )
IEEE = .FALSE.
*
IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN
IF( NGPMIN.EQ.GPMIN ) THEN
LEMIN = NGPMIN
* ( Non twos-complement machines, no gradual underflow;
* e.g., VAX )
ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN
LEMIN = NGPMIN - 1 + LT
IEEE = .TRUE.
* ( Non twos-complement machines, with gradual underflow;
* e.g., IEEE standard followers )
ELSE
LEMIN = MIN( NGPMIN, GPMIN )
* ( A guess; no known machine )
IWARN = .TRUE.
END IF
*
ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN
IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN
LEMIN = MAX( NGPMIN, NGNMIN )
* ( Twos-complement machines, no gradual underflow;
* e.g., CYBER 205 )
ELSE
LEMIN = MIN( NGPMIN, NGNMIN )
* ( A guess; no known machine )
IWARN = .TRUE.
END IF
*
ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND.
$ ( GPMIN.EQ.GNMIN ) ) THEN
IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN
LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT
* ( Twos-complement machines with gradual underflow;
* no known machine )
ELSE
LEMIN = MIN( NGPMIN, NGNMIN )
* ( A guess; no known machine )
IWARN = .TRUE.
END IF
*
ELSE
LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN )
* ( A guess; no known machine )
IWARN = .TRUE.
END IF
***
* Comment out this if block if EMIN is ok
IF( IWARN ) THEN
FIRST = .TRUE.
WRITE( 6, FMT = 9999 )LEMIN
END IF
***
*
* Assume IEEE arithmetic if we found denormalised numbers above,
* or if arithmetic seems to round in the IEEE style, determined
* in routine DLAMC1. A true IEEE machine should have both things
* true; however, faulty machines may have one or the other.
*
IEEE = IEEE .OR. LIEEE1
*
* Compute RMIN by successive division by BETA. We could compute
* RMIN as BASE**( EMIN - 1 ), but some machines underflow during
* this computation.
*
LRMIN = 1
DO 30 I = 1, 1 - LEMIN
LRMIN = DLAMC3( LRMIN*RBASE, ZERO )
30 CONTINUE
*
* Finally, call DLAMC5 to compute EMAX and RMAX.
*
CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX )
END IF
*
BETA = LBETA
T = LT
RND = LRND
EPS = LEPS
EMIN = LEMIN
RMIN = LRMIN
EMAX = LEMAX
RMAX = LRMAX
*
RETURN
*
9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-',
$ ' EMIN = ', I8, /
$ ' If, after inspection, the value EMIN looks',
$ ' acceptable please comment out ',
$ / ' the IF block as marked within the code of routine',
$ ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / )
*
* End of DLAMC2
*
END
*
************************************************************************
*
DOUBLE PRECISION FUNCTION DLAMC3( A, B )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. Scalar Arguments ..
DOUBLE PRECISION A, B
* ..
*
* Purpose
* =======
*
* DLAMC3 is intended to force A and B to be stored prior to doing
* the addition of A and B , for use in situations where optimizers
* might hold one of these in a register.
*
* Arguments
* =========
*
* A, B (input) DOUBLE PRECISION
* The values A and B.
*
* =====================================================================
*
* .. Executable Statements ..
*
DLAMC3 = A + B
*
RETURN
*
* End of DLAMC3
*
END
*
************************************************************************
*
SUBROUTINE DLAMC4( EMIN, START, BASE )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. Scalar Arguments ..
INTEGER BASE, EMIN
DOUBLE PRECISION START
* ..
*
* Purpose
* =======
*
* DLAMC4 is a service routine for DLAMC2.
*
* Arguments
* =========
*
* EMIN (output) EMIN
* The minimum exponent before (gradual) underflow, computed by
* setting A = START and dividing by BASE until the previous A
* can not be recovered.
*
* START (input) DOUBLE PRECISION
* The starting point for determining EMIN.
*
* BASE (input) INTEGER
* The base of the machine.
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I
DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMC3
EXTERNAL DLAMC3
* ..
* .. Executable Statements ..
*
A = START
ONE = 1
RBASE = ONE / BASE
ZERO = 0
EMIN = 1
B1 = DLAMC3( A*RBASE, ZERO )
C1 = A
C2 = A
D1 = A
D2 = A
*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP
10 CONTINUE
IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND.
$ ( D2.EQ.A ) ) THEN
EMIN = EMIN - 1
A = B1
B1 = DLAMC3( A / BASE, ZERO )
C1 = DLAMC3( B1*BASE, ZERO )
D1 = ZERO
DO 20 I = 1, BASE
D1 = D1 + B1
20 CONTINUE
B2 = DLAMC3( A*RBASE, ZERO )
C2 = DLAMC3( B2 / RBASE, ZERO )
D2 = ZERO
DO 30 I = 1, BASE
D2 = D2 + B2
30 CONTINUE
GO TO 10
END IF
*+ END WHILE
*
RETURN
*
* End of DLAMC4
*
END
*
************************************************************************
*
SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. Scalar Arguments ..
LOGICAL IEEE
INTEGER BETA, EMAX, EMIN, P
DOUBLE PRECISION RMAX
* ..
*
* Purpose
* =======
*
* DLAMC5 attempts to compute RMAX, the largest machine floating-point
* number, without overflow. It assumes that EMAX + abs(EMIN) sum
* approximately to a power of 2. It will fail on machines where this
* assumption does not hold, for example, the Cyber 205 (EMIN = -28625,
* EMAX = 28718). It will also fail if the value supplied for EMIN is
* too large (i.e. too close to zero), probably with overflow.
*
* Arguments
* =========
*
* BETA (input) INTEGER
* The base of floating-point arithmetic.
*
* P (input) INTEGER
* The number of base BETA digits in the mantissa of a
* floating-point value.
*
* EMIN (input) INTEGER
* The minimum exponent before (gradual) underflow.
*
* IEEE (input) LOGICAL
* A logical flag specifying whether or not the arithmetic
* system is thought to comply with the IEEE standard.
*
* EMAX (output) INTEGER
* The largest exponent before overflow
*
* RMAX (output) DOUBLE PRECISION
* The largest machine floating-point number.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
* ..
* .. Local Scalars ..
INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
DOUBLE PRECISION OLDY, RECBAS, Y, Z
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMC3
EXTERNAL DLAMC3
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD
* ..
* .. Executable Statements ..
*
* First compute LEXP and UEXP, two powers of 2 that bound
* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum
* approximately to the bound that is closest to abs(EMIN).
* (EMAX is the exponent of the required number RMAX).
*
LEXP = 1
EXBITS = 1
10 CONTINUE
TRY = LEXP*2
IF( TRY.LE.( -EMIN ) ) THEN
LEXP = TRY
EXBITS = EXBITS + 1
GO TO 10
END IF
IF( LEXP.EQ.-EMIN ) THEN
UEXP = LEXP
ELSE
UEXP = TRY
EXBITS = EXBITS + 1
END IF
*
* Now -LEXP is less than or equal to EMIN, and -UEXP is greater
* than or equal to EMIN. EXBITS is the number of bits needed to
* store the exponent.
*
IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN
EXPSUM = 2*LEXP
ELSE
EXPSUM = 2*UEXP
END IF
*
* EXPSUM is the exponent range, approximately equal to
* EMAX - EMIN + 1 .
*
EMAX = EXPSUM + EMIN - 1
NBITS = 1 + EXBITS + P
*
* NBITS is the total number of bits needed to store a
* floating-point number.
*
IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN
*
* Either there are an odd number of bits used to store a
* floating-point number, which is unlikely, or some bits are
* not used in the representation of numbers, which is possible,
* (e.g. Cray machines) or the mantissa has an implicit bit,
* (e.g. IEEE machines, Dec Vax machines), which is perhaps the
* most likely. We have to assume the last alternative.
* If this is true, then we need to reduce EMAX by one because
* there must be some way of representing zero in an implicit-bit
* system. On machines like Cray, we are reducing EMAX by one
* unnecessarily.
*
EMAX = EMAX - 1
END IF
*
IF( IEEE ) THEN
*
* Assume we are on an IEEE machine which reserves one exponent
* for infinity and NaN.
*
EMAX = EMAX - 1
END IF
*
* Now create RMAX, the largest machine number, which should
* be equal to (1.0 - BETA**(-P)) * BETA**EMAX .
*
* First compute 1.0 - BETA**(-P), being careful that the
* result is less than 1.0 .
*
RECBAS = ONE / BETA
Z = BETA - ONE
Y = ZERO
DO 20 I = 1, P
Z = Z*RECBAS
IF( Y.LT.ONE )
$ OLDY = Y
Y = DLAMC3( Y, Z )
20 CONTINUE
IF( Y.GE.ONE )
$ Y = OLDY
*
* Now multiply by BETA**EMAX to get RMAX.
*
DO 30 I = 1, EMAX
Y = DLAMC3( Y*BETA, ZERO )
30 CONTINUE
*
RMAX = Y
RETURN
*
* End of DLAMC5
*
END
LOGICAL FUNCTION LSAME( CA, CB )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
CHARACTER CA, CB
* ..
*
* Purpose
* =======
*
* LSAME returns .TRUE. if CA is the same letter as CB regardless of
* case.
*
* Arguments
* =========
*
* CA (input) CHARACTER*1
* CB (input) CHARACTER*1
* CA and CB specify the single characters to be compared.
*
* =====================================================================
*
* .. Intrinsic Functions ..
INTRINSIC ICHAR
* ..
* .. Local Scalars ..
INTEGER INTA, INTB, ZCODE
* ..
* .. Executable Statements ..
*
* Test if the characters are equal
*
LSAME = CA.EQ.CB
IF( LSAME )
$ RETURN
*
* Now test for equivalence if both characters are alphabetic.
*
ZCODE = ICHAR( 'Z' )
*
* Use 'Z' rather than 'A' so that ASCII can be detected on Prime
* machines, on which ICHAR returns a value with bit 8 set.
* ICHAR('A') on Prime machines returns 193 which is the same as
* ICHAR('A') on an EBCDIC machine.
*
INTA = ICHAR( CA )
INTB = ICHAR( CB )
*
IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN
*
* ASCII is assumed - ZCODE is the ASCII code of either lower or
* upper case 'Z'.
*
IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32
IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32
*
ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN
*
* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
* upper case 'Z'.
*
IF( INTA.GE.129 .AND. INTA.LE.137 .OR.
$ INTA.GE.145 .AND. INTA.LE.153 .OR.
$ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64
IF( INTB.GE.129 .AND. INTB.LE.137 .OR.
$ INTB.GE.145 .AND. INTB.LE.153 .OR.
$ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64
*
ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN
*
* ASCII is assumed, on Prime machines - ZCODE is the ASCII code
* plus 128 of either lower or upper case 'Z'.
*
IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32
IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32
END IF
LSAME = INTA.EQ.INTB
*
* RETURN
*
* End of LSAME
*
END
SUBROUTINE XERBLA( SRNAME, INFO )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
CHARACTER*6 SRNAME
INTEGER INFO
* ..
*
* Purpose
* =======
*
* XERBLA is an error handler for the LAPACK routines.
* It is called by an LAPACK routine if an input parameter has an
* invalid value. A message is printed and execution stops.
*
* Installers may consider modifying the STOP statement in order to
* call system-specific exception-handling facilities.
*
* Arguments
* =========
*
* SRNAME (input) CHARACTER*6
* The name of the routine which called XERBLA.
*
* INFO (input) INTEGER
* The position of the invalid parameter in the parameter list
* of the calling routine.
*
* =====================================================================
*
* .. Executable Statements ..
*
WRITE( *, FMT = 9999 )SRNAME, INFO
*
STOP
*
9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ',
$ 'an illegal value' )
*
* End of XERBLA
*
END
* ======================================================================
* NIST Guide to Available Math Software.
* Fullsource for module DSCAL from package BLAS1.
* Retrieved from NETLIB on Mon Jun 15 14:50:56 1998.
* ======================================================================
subroutine dscal(n,da,dx,incx)
c
c scales a vector by a constant.
c uses unrolled loops for increment equal to one.
c jack dongarra, linpack, 3/11/78.
c modified 3/93 to return if incx .le. 0.
c modified 12/3/93, array(1) declarations changed to array(*)
c
double precision da,dx(*)
integer i,incx,m,mp1,n,nincx
c
if( n.le.0 .or. incx.le.0 )return
if(incx.eq.1)go to 20
c
c code for increment not equal to 1
c
nincx = n*incx
do 10 i = 1,nincx,incx
dx(i) = da*dx(i)
10 continue
return
c
c code for increment equal to 1
c
c
c clean-up loop
c
20 m = mod(n,5)
if( m .eq. 0 ) go to 40
do 30 i = 1,m
dx(i) = da*dx(i)
30 continue
if( n .lt. 5 ) return
40 mp1 = m + 1
do 50 i = mp1,n,5
dx(i) = da*dx(i)
dx(i + 1) = da*dx(i + 1)
dx(i + 2) = da*dx(i + 2)
dx(i + 3) = da*dx(i + 3)
dx(i + 4) = da*dx(i + 4)
50 continue
return
end
* ======================================================================
* NIST Guide to Available Math Software.
* Fullsource for module ZHPMV from package BLAS2.
* Retrieved from NETLIB on Mon Jun 15 14:52:24 1998.
* ======================================================================
SUBROUTINE ZHPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
* .. Scalar Arguments ..
COMPLEX*16 ALPHA, BETA
INTEGER INCX, INCY, N
CHARACTER*1 UPLO
* .. Array Arguments ..
COMPLEX*16 AP( * ), X( * ), Y( * )
* ..
*
* Purpose
* =======
*
* ZHPMV performs the matrix-vector operation
*
* y := alpha*A*x + beta*y,
*
* where alpha and beta are scalars, x and y are n element vectors and
* A is an n by n hermitian matrix, supplied in packed form.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the matrix A is supplied in the packed
* array AP as follows:
*
* UPLO = 'U' or 'u' The upper triangular part of A is
* supplied in AP.
*
* UPLO = 'L' or 'l' The lower triangular part of A is
* supplied in AP.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - COMPLEX*16 .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* AP - COMPLEX*16 array of DIMENSION at least
* ( ( n*( n + 1 ) )/2 ).
* Before entry with UPLO = 'U' or 'u', the array AP must
* contain the upper triangular part of the hermitian matrix
* packed sequentially, column by column, so that AP( 1 )
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
* and a( 2, 2 ) respectively, and so on.
* Before entry with UPLO = 'L' or 'l', the array AP must
* contain the lower triangular part of the hermitian matrix
* packed sequentially, column by column, so that AP( 1 )
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
* and a( 3, 1 ) respectively, and so on.
* Note that the imaginary parts of the diagonal elements need
* not be set and are assumed to be zero.
* Unchanged on exit.
*
* X - COMPLEX*16 array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* BETA - COMPLEX*16 .
* On entry, BETA specifies the scalar beta. When BETA is
* supplied as zero then Y need not be set on input.
* Unchanged on exit.
*
* Y - COMPLEX*16 array of dimension at least
* ( 1 + ( n - 1 )*abs( INCY ) ).
* Before entry, the incremented array Y must contain the n
* element vector y. On exit, Y is overwritten by the updated
* vector y.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y. INCY must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- Written on 22-October-1986.
* Jack Dongarra, Argonne National Lab.
* Jeremy Du Croz, Nag Central Office.
* Sven Hammarling, Nag Central Office.
* Richard Hanson, Sandia National Labs.
*
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
COMPLEX*16 ZERO
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
* .. Local Scalars ..
COMPLEX*16 TEMP1, TEMP2
INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* .. External Subroutines ..
EXTERNAL XERBLA
* .. Intrinsic Functions ..
INTRINSIC DCONJG, DBLE
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF ( .NOT.LSAME( UPLO, 'U' ).AND.
$ .NOT.LSAME( UPLO, 'L' ) )THEN
INFO = 1
ELSE IF( N.LT.0 )THEN
INFO = 2
ELSE IF( INCX.EQ.0 )THEN
INFO = 6
ELSE IF( INCY.EQ.0 )THEN
INFO = 9
END IF
IF( INFO.NE.0 )THEN
CALL XERBLA( 'ZHPMV ', INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
$ RETURN
*
* Set up the start points in X and Y.
*
IF( INCX.GT.0 )THEN
KX = 1
ELSE
KX = 1 - ( N - 1 )*INCX
END IF
IF( INCY.GT.0 )THEN
KY = 1
ELSE
KY = 1 - ( N - 1 )*INCY
END IF
*
* Start the operations. In this version the elements of the array AP
* are accessed sequentially with one pass through AP.
*
* First form y := beta*y.
*
IF( BETA.NE.ONE )THEN
IF( INCY.EQ.1 )THEN
IF( BETA.EQ.ZERO )THEN
DO 10, I = 1, N
Y( I ) = ZERO
10 CONTINUE
ELSE
DO 20, I = 1, N
Y( I ) = BETA*Y( I )
20 CONTINUE
END IF
ELSE
IY = KY
IF( BETA.EQ.ZERO )THEN
DO 30, I = 1, N
Y( IY ) = ZERO
IY = IY + INCY
30 CONTINUE
ELSE
DO 40, I = 1, N
Y( IY ) = BETA*Y( IY )
IY = IY + INCY
40 CONTINUE
END IF
END IF
END IF
IF( ALPHA.EQ.ZERO )
$ RETURN
KK = 1
IF( LSAME( UPLO, 'U' ) )THEN
*
* Form y when AP contains the upper triangle.
*
IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
DO 60, J = 1, N
TEMP1 = ALPHA*X( J )
TEMP2 = ZERO
K = KK
DO 50, I = 1, J - 1
Y( I ) = Y( I ) + TEMP1*AP( K )
TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( I )
K = K + 1
50 CONTINUE
Y( J ) = Y( J ) + TEMP1*DBLE( AP( KK + J - 1 ) )
$ + ALPHA*TEMP2
KK = KK + J
60 CONTINUE
ELSE
JX = KX
JY = KY
DO 80, J = 1, N
TEMP1 = ALPHA*X( JX )
TEMP2 = ZERO
IX = KX
IY = KY
DO 70, K = KK, KK + J - 2
Y( IY ) = Y( IY ) + TEMP1*AP( K )
TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( IX )
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
Y( JY ) = Y( JY ) + TEMP1*DBLE( AP( KK + J - 1 ) )
$ + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
KK = KK + J
80 CONTINUE
END IF
ELSE
*
* Form y when AP contains the lower triangle.
*
IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
DO 100, J = 1, N
TEMP1 = ALPHA*X( J )
TEMP2 = ZERO
Y( J ) = Y( J ) + TEMP1*DBLE( AP( KK ) )
K = KK + 1
DO 90, I = J + 1, N
Y( I ) = Y( I ) + TEMP1*AP( K )
TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( I )
K = K + 1
90 CONTINUE
Y( J ) = Y( J ) + ALPHA*TEMP2
KK = KK + ( N - J + 1 )
100 CONTINUE
ELSE
JX = KX
JY = KY
DO 120, J = 1, N
TEMP1 = ALPHA*X( JX )
TEMP2 = ZERO
Y( JY ) = Y( JY ) + TEMP1*DBLE( AP( KK ) )
IX = JX
IY = JY
DO 110, K = KK + 1, KK + N - J
IX = IX + INCX
IY = IY + INCY
Y( IY ) = Y( IY ) + TEMP1*AP( K )
TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( IX )
110 CONTINUE
Y( JY ) = Y( JY ) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
KK = KK + ( N - J + 1 )
120 CONTINUE
END IF
END IF
*
RETURN
*
* End of ZHPMV .
*
END
SUBROUTINE SMESSG(NUNIT,IP,NMESS)
C DEFINE THE TEXT OF ERROR MESSAGES.
C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
C REVISED 860623
C REVISED YYMMDD
C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
LOGICAL EX,OP,INQ
INTEGER NUNIT(3)
CHARACTER *256 MESS(09)
CHARACTER *256 M
DATA MESS(01)/
.' THE COMPILER IS GENERATING BAD CODE FOR IN-LINE DOT PRODUCTS OR
.IS INCORRECTLY EVALUATING THE ARITHMETIC EXPRESSIONS J*((J+1)*J)/2
. - (J+1)*J*(J-1)/3, J=1 THRU 32.'/
DATA MESS(02)/
.' ABNORMAL OR EARLY END-OF-FILE WHILE READING NAME OF FILE THAT CO
.NTAINS THE NAMES OF THE SUBPROGRAMS AND THE SUMMARY FILES.'/
DATA MESS(03)/
.' THE ABOVE FILE NAME MUST BE PRESENT ON THE SYSTEM. IT IS NOT.
.THIS FILE CONTAINS THE NAMES OF THE SUBPROGRAMS AND THE SUMMARY FI
.LES.'/
DATA MESS(04)/
.' ABNORMAL OR EARLY END-OF-FILE WHILE READING NAMES OF SUBPROGRAMS
. FROM THE ABOVE FILE NAME.'/
DATA MESS(05)/
.' ABNORNAL OR EARLY END-OF-FILE WHILE READING NAMES OF FILES FOR S
.UMMARY OUTPUT.'/
DATA MESS(06)/
.' ENTER NAME AND UNIT NUMBER OF FILE CONTAINING NAMES OF SUBPROGRA
.MS AND SUMMARY FILES. ONE ITEM PER LINE, PLEASE.'/
DATA MESS(07)/
.' THE SNAP-SHOT FILE OF ACTIVE TESTS CANNOT BE OPENED WITH ''NEW''
. STATUS OR IT CANNOT BE DELETED. THIS FILE SHOULD NOT BE PRESENT
.ON THE SYSTEM.'/
DATA MESS(08)/
.' THE SUMMARY FILE OF ACTIVE TESTS CANNOT BE OPENED WITH ''UNKOWN'
.' STATUS. THIS FILE SHOULD NOT BE PRESENT ON THE SYSTEM.'/
M = MESS(NMESS)
NL = 256
NS = 72
INQ = .TRUE.
DO 10 I = NL,1,-1
IF (ICHAR(M(I:I)).NE.ICHAR(' ')) GO TO 20
10 CONTINUE
NL = 0
GO TO 30
*
20 NL = I
C FOUND NS = POINTER TO LAST NONBLANK IN MESSAGE.
30 CONTINUE
C NOW OUTPUT THE MESSAGE. PARSE IT SO THAT UP TO NS CHARS. PER LINE
C PRINT, BUT DO NOT BREAK WORDS ACCROSS LINES.
IS = 1
40 CONTINUE
IE = MIN(NL,IS+NS)
IF (IS.GE.IE) GO TO 70
50 CONTINUE
IF (ICHAR(M(IE:IE)).EQ.ICHAR(' ') .OR. NL-IS.LT.NS) GO TO 60
IE = IE - 1
IF (IE.GT.IS) GO TO 50
60 CONTINUE
IF (INQ) THEN
INQUIRE (UNIT=NUNIT(IP),EXIST=EX,OPENED=OP)
END IF
C IF THE INTENDED UNIT IS NOT OPENED, SEND OUTPUT TO
C STANDARD OUTPUT SO IT WILL BE SEEN.
IF ( .NOT. OP .OR. .NOT. EX .OR. NUNIT(IP).EQ.0) THEN
IF (IE.EQ.NL) THEN
WRITE (*,'(A,/)') M(IS:IE)
*
ELSE
WRITE (*,'(A)') M(IS:IE)
END IF
*
INQ = .FALSE.
*
ELSE
LUNIT = NUNIT(IP)
WRITE (LUNIT,'(A)') M(IS:IE)
END IF
*
IS = IE
GO TO 40
*
70 CONTINUE
RETURN
END
*
SUBROUTINE SCHCK1(ISNUM,SNAME,IG,DOPE,NUNIT,AVIGR,FATAL)
C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
C REVISED 860623
C REVISED YYMMDD
C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
C THIS PROGRAM HAS TWO PARTS. THE FIRST PART CHECKS TO SEE
C IF ANY DATA GETS CHANGED WHEN NONE SHOULD. FOR EXAMPLE WHEN
C USING AN INVALID OPTION OR NONPOSITVE PROBLEM DIMENSIONS.
C THE SECOND PART CHECKS THAT THE RESULTS ARE REASONABLY ACCURATE.
C DIMENSION AND PROBLEM SIZE DATA..
INTEGER INC(04),IDIM(08),NUNIT(2)
REAL ALF(04),BET(04),SDIFF
LOGICAL ISAME(13),LSE,FATAL,SAME,NCHNG,RESET
CHARACTER *128 DOPE(2)
CHARACTER *6 SNAME
CHARACTER *3 ICH
CHARACTER *1 ICHS,ICI
INTEGER LA,LV
PARAMETER (LA=4096,LV=4096,LMN=2048)
REAL A(LA),AS(LA),X(LV),XS(LV)
REAL Y(LV),YS(LV),YT(LMN),XT(LMN)
REAL ALPHA,ALS,BETA,BLS,T,TRANSL,XN
PARAMETER (ZERO=0.E0,HALF=.5E0,ONE=1.E0)
INTEGER LIJU_ZERO(3)
DATA LIJU_ZERO/3*0/
COMMON /ARRAYS/AR,AS,X,XS,Y,YS,YT,XT
EXTERNAL SDIFF
*
DATA ALF/-1.E0,2.E0,.3E0,1.E0/
DATA BET/-1.E0,0.E0,.3E0,1.E0/
DATA INC/-2,-1,1,2/
DATA IDIM/1,2,4,8,64,128,2048,0/
DATA ICH/'NT/'/
FATAL = .FALSE.
C CHECK GENERAL MATRIX-VECTOR PRODUCT, Y = ALPHA*A*X+BETA*Y, NO.1-2.
IF (ISNUM.LT.0) GO TO 220
NC = 0
RESET = .TRUE.
AVIGR = ZERO
IX = 0
10 IX = IX + 1
IF (IX.GT.4) GO TO 200
INCX = INC(IX)
ALPHA = ALF(IX)
IY = 0
20 IY = IY + 1
IF (IY.GT.4) GO TO 190
INCY = INC(IY)
BETA = BET(IY)
MM = 0
30 MM = MM + 1
IF (MM.GT.8) GO TO 180
M = IDIM(MM)
NN = 0
40 NN = NN + 1
IF (NN.GT.8) GO TO 170
N = IDIM(NN)
IC = 0
50 IC = IC + 1
IF (IC.GT.3) GO TO 160
IF (FATAL) GO TO 210
C SET DEFAULT BANDWIDTH SO PRINTING WILL BE OK.
KL = MAX(0,M-1)
KU = MAX(0,N-1)
C DEFINE THE NUMBER OF ARGUMENTS AND THE Y ARGUMENT NUMBER.
IF (ISNUM.EQ.1) THEN
LDA = MAX(M,1)
NARGS = 11
IYARG = 10
*
ELSE IF (ISNUM.EQ.2) THEN
NARGS = 13
IYARG = 12
C DEFINE BANDWIDTH OF MATRIX FOR TEST OF SGBMV.
KL = MAX(0,MIN(M-1,M/2))
KU = MAX(0,MIN(N-1,N/2))
LDA = MAX(KL+KU+1,M)
END IF
*
ICI = ICH(IC:IC)
IF (ICHAR(ICI).EQ.ICHAR('T')) THEN
ML = N
NL = M
INCCA = 1
INCRA = LDA
*
ELSE
ML = M
NL = N
INCCA = LDA
INCRA = 1
END IF
*
C IF NOT ENOUGH STORAGE, SKIP THIS CASE. (AVOID EXPLICT LDA*N).
IF (SQRT(REAL(N))*SQRT(REAL(LDA)).GT.SQRT(REAL(LA))) GO TO 50
C DO (PREPARE NOTES FOR THIS TEST)
C
C PRINT A MESSAGE THAT GIVES DEBUGGING INFORMATION. THIS
C MESSAGE SAYS..
C IN SUBPROGRAM XXXXX TESTS WERE ACTIVE WITH
C OPTION = 'A'
C M = IIII, N = IIII,
C INCX = IIII, INCY = IIII,
C KL = IIII, KU = IIII.
C THE MAIN IDEA HERE IS THAT A SERIOUS BUG THAT OCCURS DURING THE
C TESTING OF THESE SUBPROGRAMS MAY LOSE PROGRAM CONTROL. THIS
C AUXILLIARY FILE CONTAINS THE DIMENSIONS THAT RESULTED IN THE LOSS
C OF CONTROL. HENCE IT PROVIDES THE IMPLEMENTOR WITH MORE COMPLETE
C INFORMATION ABOUT WHERE TO START TRACKING DOWN THE BUG.
IF (NUNIT(1).GT.0) THEN
C IF UNIT IS NOT AVAILABLE WITH 'NEW' STATUS, OPEN WITH
C 'OLD' AND THEN DELETE IT.
ISTAT = 1
CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR)
IF (IERROR.EQ.1) GO TO 60
C GET RID OF ANY OLD FILE.
CLOSE (UNIT=NUNIT(1),STATUS='DELETE',ERR=60)
60 CONTINUE
ISTAT = 2
C CREATE A NEW FILE FOR THE NEXT TEST.
CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR)
IF (IERROR.EQ.0) GO TO 80
NMESS = 7
C DO (PRINT A MESSAGE)
C PRINT AN ERROR MESSAGE ABOUT OPENING THE NAME FILE.
CALL SMESSG(LIJU_ZERO,1,NMESS)
FATAL = .TRUE.
GO TO 210
*
80 CONTINUE
WRITE (NUNIT(1),9001) SNAME,ICI,M,N,INCX,INCY,KL,KU
C CLOSE THE FILE SO USEFUL STATUS INFORMATION IS SEALED.
CLOSE (UNIT=NUNIT(1))
END IF
C DO (DEFINE A SET OF PROBLEM DATA)
ASSIGN 90 TO IGO3
GO TO 340
*
90 CONTINUE
C DO (CALL SUBROUTINE)
ASSIGN 100 TO IGO1
GO TO 280
*
100 CONTINUE
IF (M.LE.0 .OR. N.LE.0 .OR. ICHAR(ICI).EQ.ICHAR('/')) THEN
C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
ASSIGN 110 TO IGO2
GO TO 240
*
110 CONTINUE
C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN.
SAME = .TRUE.
DO 120 I = 1,NARGS
SAME = SAME .AND. ISAME(I)
IF ( .NOT. ISAME(I)) THEN
WRITE (NUNIT(2),9011) SNAME,I,ICI,M,N,INCX,INCY,KL,KU
END IF
*
120 CONTINUE
IF ( .NOT. SAME) THEN
FATAL = .TRUE.
GO TO 210
*
END IF
*
ELSE
C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
ASSIGN 130 TO IGO2
GO TO 240
*
130 CONTINUE
C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN.
SAME = .TRUE.
DO 140 I = 1,NARGS
NCHNG = (I.EQ.IYARG .OR. ISAME(I))
SAME = SAME .AND. NCHNG
IF ( .NOT. NCHNG) THEN
WRITE (NUNIT(2),9021) SNAME,I,ICI,M,N,INCX,INCY,KL,KU
END IF
*
140 CONTINUE
IF ( .NOT. SAME) THEN
FATAL = .TRUE.
GO TO 210
*
END IF
*
NC = NC + 1
C DO (COMPUTE A CORRECT RESULT)
ASSIGN 150 TO IGO4
GO TO 370
*
150 CONTINUE
C IF GOT REALLY BAD ANSWER, PRINT NOTE AND GO BACK.
IF (FATAL) GO TO 200
*
END IF
*
GO TO 50
*
160 CONTINUE
GO TO 40
*
170 CONTINUE
GO TO 30
*
180 CONTINUE
GO TO 20
*
190 CONTINUE
GO TO 10
*
200 CONTINUE
C REPORT ON ACCURACY OF DATA.
WRITE (NUNIT(2),9031) ISNUM,SNAME,AVIGR,IG
GO TO 230
*
210 CONTINUE
WRITE (NUNIT(2),9041) ISNUM,SNAME
GO TO 230
*
220 CONTINUE
WRITE (NUNIT(2),9051) - ISNUM,SNAME
230 CONTINUE
RETURN
*
240 CONTINUE
C PROCEDURE (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
IF (ISNUM.EQ.1) THEN
ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS)
ISAME(2) = MS .EQ. M
ISAME(3) = NS .EQ. N
ISAME(4) = ALS .EQ. ALPHA
ISAME(5) = .TRUE.
IF (M.GT.0 .AND. N.GT.0) ISAME(5) = LSE(AS,A,M,N,LDA)
ISAME(6) = LDAS .EQ. LDA
ISAME(7) = .TRUE.
IF (NL.GT.0 .AND. INCX.NE.0) ISAME(7) = LSE(XS,X,1,NL,
. ABS(INCX))
ISAME(8) = INCXS .EQ. INCX
ISAME(9) = BLS .EQ. BETA
ISAME(10) = .TRUE.
IF (ML.GT.0 .AND. INCY.NE.0) ISAME(10) = LSE(YS,Y,1,ML,
. ABS(INCY))
ISAME(11) = INCYS .EQ. INCY
*
ELSE IF (ISNUM.EQ.2) THEN
C COMPARE THE MATRIX IN THE SGBMV DATA STRUCTURE WITH
C THE SAVED COPY.
ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS)
ISAME(2) = MS .EQ. M
ISAME(3) = NS .EQ. N
ISAME(4) = KLS .EQ. KL
ISAME(5) = KUS .EQ. KU
ISAME(6) = ALS .EQ. ALPHA
ISAME(7) = .TRUE.
IF (N.GT.0 .AND. M.GT.0) THEN
DO 260 J = 1,N
DO 250 I = MAX(1,J-KU),MIN(M,J+KL)
IF (AS(1+ (I-1)+ (J-1)*LDA).NE.
. A(1+ (KU+I-J)+ (J-1)*LDA)) THEN
ISAME(7) = .FALSE.
GO TO 270
*
END IF
*
250 CONTINUE
260 CONTINUE
270 CONTINUE
END IF
*
ISAME(8) = LDAS .EQ. LDA
ISAME(9) = .TRUE.
IF (NL.GT.0 .AND. INCX.NE.0) ISAME(9) = LSE(XS,X,1,NL,
. ABS(INCX))
ISAME(10) = INCXS .EQ. INCX
ISAME(11) = BLS .EQ. BETA
ISAME(12) = .TRUE.
IF (ML.GT.0 .AND. INCY.NE.0) ISAME(12) = LSE(YS,Y,1,ML,
. ABS(INCY))
ISAME(13) = INCYS .EQ. INCY
END IF
*
GO TO IGO2
*
280 CONTINUE
C PROCEDURE (CALL SUBROUTINE)
C SAVE EVERY DATUM BEFORE THE CALL.
ICHS = ICI
MS = M
NS = N
KLS = KL
KUS = KU
ALS = ALPHA
DO 290 I = 1,LDA*N
AS(I) = A(I)
290 CONTINUE
LDAS = LDA
C SAVE COPY OF THE X AND Y VECTORS.
IBX = 1
IF (INCX.LT.0) IBX = 1 + (1-NL)*INCX
DO 300 J = 1,NL
XS(IBX+ (J-1)*INCX) = X(IBX+ (J-1)*INCX)
300 CONTINUE
INCXS = INCX
BLS = BETA
IBY = 1
IF (INCY.LT.0) IBY = 1 + (1-ML)*INCY
DO 310 I = 1,ML
YS(IBY+ (I-1)*INCY) = Y(IBY+ (I-1)*INCY)
310 CONTINUE
INCYS = INCY
IF (ISNUM.EQ.1) THEN
CALL SGEMV(ICI,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
ELSE IF (ISNUM.EQ.2) THEN
C TRANSFER THE MATRIX TO THE DATA STRUCTURE USED WITH SGBMV.
DO 330 J = 1,N
DO 320 I = MAX(1,J-KU),MIN(M,J+KL)
A(1+ (KU+I-J)+ (J-1)*LDA) = AS(1+ (I-1)+ (J-1)*LDA)
320 CONTINUE
330 CONTINUE
CALL SGBMV(ICI,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
END IF
*
GO TO IGO1
*
340 CONTINUE
C PROCEDURE (DEFINE A SET OF PROBLEM DATA)
C DO NOTHING IF BOTH DIMENSIONS ARE NOT POSITIVE.
IF (M.LE.0 .OR. N.LE.0) GO TO IGO3
TRANSL = ZERO
CALL SMAKE(A,M,N,LDA,RESET,TRANSL)
C TRIM AWAY ELEMENTS OUTSIDE THE BANDWIDTH FOR SGBMV.
IF (ISNUM.EQ.2) THEN
DO 360 J = 1,N
DO 350 I = 1,M
T = A(1+ (I-1)+ (J-1)*LDA)
IF (J.GT.I .AND. J-I.GT.KU) T = ZERO
IF (I.GT.J .AND. I-J.GT.KL) T = ZERO
A(1+ (I-1)+ (J-1)*LDA) = T
350 CONTINUE
360 CONTINUE
END IF
*
TRANSL = 500.E0
RESET = .FALSE.
CALL SMAKE(X,1,NL,MAX(1,ABS(INCX)),RESET,TRANSL)
IF (NL.GT.1 .AND. INCX.EQ.1) X(NL/2) = ZERO
TRANSL = ZERO
CALL SMAKE(Y,1,ML,MAX(1,ABS(INCY)),RESET,TRANSL)
GO TO IGO3
*
370 CONTINUE
C PROCEDURE (COMPUTE A CORRECT RESULT)
C COMPUTE THE CONDITION NUMBER TO USE AS GAUGE FOR ACCURATE RESULTS.
C THIS IS RETURNED IN XT(*).
C COMPUTE THE APPROXIMATE CORRECT RESULT.
C THIS IS RETURNED IN YT(*).
IF (INCY.LT.0) THEN
IBY = (1-ML)*INCY + 1
*
ELSE
IBY = 1
END IF
*
DO 390 I = 1,ML
YT(I) = BETA*YS(IBY+ (I-1)*INCY)
XT(I) = YS(IBY+ (I-1)*INCY)**2
IF (INCX.LT.0) THEN
IBX = (1-NL)*INCX + 1
*
ELSE
IBX = 1
END IF
*
DO 380 J = 1,NL
YT(I) = YT(I) + AS(1+ (I-1)*INCRA+ (J-1)*INCCA)*ALPHA*
. XS(IBX+ (J-1)*INCX)
XT(I) = XT(I) + AS(1+ (I-1)*INCRA+ (J-1)*INCCA)**2
380 CONTINUE
XT(I) = SQRT(XT(I))
390 CONTINUE
XN = BETA**2
DO 400 J = 1,NL
XN = XN + XS(IBX+ (J-1)*INCX)**2
400 CONTINUE
XN = SQRT(XN)
C COMPUTE THE GAUGES FOR THE RESULTS.
DO 410 I = 1,ML
XT(I) = XT(I)*XN
410 CONTINUE
C COMPUTE THE DIFFERENCES. THEY SHOULD BE SMALL FOR CORRECT RESULTS.
DO 420 I = 1,ML
YT(I) = YT(I) - Y(IBY+ (I-1)*INCY)
420 CONTINUE
C COMPUTE THE GRADE OF THIS RESULT.
IGR = 0
T = ONE
430 CONTINUE
C THIS TEST ALLOWS UP TO A LOSS OF FULL PRECISION BEFORE QUITTING.
IF (IGR.GE.IG) GO TO 460
DO 440 I = 1,ML
IF (SDIFF(T*ABS(YT(I))+XT(I),XT(I)).EQ.ZERO) GO TO 440
T = T*HALF
IGR = IGR + 1
GO TO 430
*
440 CONTINUE
C IF THE LOOP COMPLETES, ALL VALUES ARE 'SMALL.' THE VALUE IGR/IG
C IS THE GRADE ASSIGNED. THE VALUE OF IGR IS MAXIMIZED OVER ALL THE
C PROBLEMS.
450 CONTINUE
AVIGR = MAX(AVIGR,REAL(IGR))
GO TO IGO4
*
460 CONTINUE
FATAL = .TRUE.
GO TO 450
*
* LAST EXECUTABLE LINE OF SCHCK1
9001 FORMAT (' IN SUBPROGRAM ',A,/,' TESTS ACTIVE WITH OPTION = ',A,/,
. ' M =',I4,', N = ',I4,/,' INCX = ',I2,', INCY = ',I2,/,' KL =',
. I4,', KU =',I4)
9011 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2,
. ' WAS CHANGED WITH INVALID INPUT.',/,' OPTION = ',A,', M =',I4,
. ', N = ',I4,/,' INCX = ',I2,', INCY = ',I2,/,' KL =',I4,
. ', KU =',I4)
9021 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2,
. ' WAS CHANGED WHILE COMPUTING',/,' OPTION = ',A,', M =',I4,
. ', N = ',I4,/,' INCX = ',I2,', INCY = ',I2,/,' KL =',I4,
. ', KU =',I4)
9031 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'RECEIVED A LOSS GRADE OF ',
. F5.2,' OUT OF ',I3)
9041 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'FAILED.')
9051 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'NOT TESTED.')
END
SUBROUTINE SCHCK2(ISNUM,SNAME,IG,DOPE,NUNIT,AVIGR,FATAL)
C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
C TEST SSYMV, 03, SSBMV, 04, AND SSPMV, 05.
C REVISED 860623
C REVISED YYMMDD
C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
C THIS PROGRAM HAS TWO PARTS. THE FIRST PART CHECKS TO SEE
C IF ANY DATA GETS CHANGED WHEN NONE SHOULD. FOR EXAMPLE WHEN
C USING AN INVALID OPTION OR NONPOSITVE PROBLEM DIMENSIONS.
C THE SECOND PART CHECKS THAT THE RESULTS ARE REASONABLY ACCURATE.
C DIMENSION AND PROBLEM SIZE DATA..
INTEGER INC(04),IDIM(06),NUNIT(2)
REAL ALF(04),BET(04)
LOGICAL ISAME(13),LSE,FATAL,SAME,NCHNG,RESET
CHARACTER *128 DOPE(2)
CHARACTER *6 SNAME
CHARACTER *3 ICH
CHARACTER *1 ICHS,ICI
INTEGER LA,LV
PARAMETER (LA=4096,LV=4096,LMN=2048)
REAL ALPHA,ALS,BETA,BLS,T,TRANSL,XN
REAL A(LA),AS(LA),X(LV),XS(LV)
REAL Y(LV),YS(LV),YT(LMN),XT(LMN)
PARAMETER (ZERO=0.E0,HALF=.5E0,ONE=1.E0)
COMMON /ARRAYS/AR,AS,X,XS,Y,YS,YT,XT
EXTERNAL SDIFF
INTEGER LIJU_ZERO(3)
DATA LIJU_ZERO/3*0/
*
DATA ALF/-1.E0,2.E0,.3E0,1.E0/
DATA BET/-1.E0,0.E0,.3E0,1.E0/
DATA INC/-2,-1,1,2/
DATA IDIM/1,2,4,8,64,0/
DATA ICH/'LU/'/
FATAL = .FALSE.
C CHECK SYMMETRIC MATRIX-VECTOR PRODUCT, Y = ALPHA*A*X+BETA*Y, 3-5.
IF (ISNUM.LT.0) GO TO 200
NC = 0
RESET = .TRUE.
AVIGR = ZERO
IX = 0
10 IX = IX + 1
IF (IX.GT.4) GO TO 180
INCX = INC(IX)
ALPHA = ALF(IX)
IY = 0
20 IY = IY + 1
IF (IY.GT.4) GO TO 170
INCY = INC(IY)
BETA = BET(IY)
NN = 0
30 NN = NN + 1
IF (NN.GT.6) GO TO 160
N = IDIM(NN)
IC = 0
40 IC = IC + 1
IF (IC.GT.3) GO TO 150
IF (FATAL) GO TO 190
ICI = ICH(IC:IC)
C DEFINE DEFAULT VALUE OF K SO PRINTING IS OK.
K = MAX(0,N-1)
C DEFINE THE NUMBER OF ARGUMENTS AND THE Y ARGUMENT NUMBER.
LDA = MAX(N,1)
IF (ISNUM.EQ.3) THEN
NARGS = 10
IYARG = 09
*
ELSE IF (ISNUM.EQ.4) THEN
NARGS = 11
IYARG = 10
C DEFINE BANDWIDTH OF MATRIX FOR TEST OF SSBMV.
K = INT(SQRT(REAL(N))+HALF) - 1
*
ELSE IF (ISNUM.EQ.5) THEN
NARGS = 9
IYARG = 8
END IF
C DO (PREPARE NOTES FOR THIS TEST)
C
C PRINT A MESSAGE THAT GIVES DEBUGGING INFORMATION. THIS
C MESSAGE SAYS..
C IN SUBPROGRAM XXXXX TESTS WERE ACTIVE WITH
C OPTION = 'A'
C N = IIII,
C INCX = IIII, INCY = IIII,
C K = IIII.
C THE MAIN IDEA HERE IS THAT A SERIOUS BUG THAT OCCURS DURING THE
C TESTING OF THESE SUBPROGRAMS MAY LOSE PROGRAM CONTROL. THIS
C AUXILLIARY FILE CONTAINS THE DIMENSIONS THAT RESULTED IN THE LOSS
C OF CONTROL. HENCE IT PROVIDES THE IMPLEMENTOR WITH MORE COMPLETE
C INFORMATION ABOUT WHERE TO START TRACKING DOWN THE BUG.
IF (NUNIT(1).GT.0) THEN
C IF UNIT IS NOT AVAILABLE WITH 'NEW' STATUS, OPEN WITH
C 'OLD' AND THEN DELETE IT.
ISTAT = 1
CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR)
IF (IERROR.EQ.1) GO TO 50
C GET RID OF ANY OLD FILE.
CLOSE (UNIT=NUNIT(1),STATUS='DELETE',ERR=50)
50 CONTINUE
ISTAT = 2
C CREATE A NEW FILE FOR THE NEXT TEST.
CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR)
IF (IERROR.EQ.0) GO TO 70
60 CONTINUE
NMESS = 7
C DO (PRINT A MESSAGE)
C PRINT AN ERROR MESSAGE ABOUT OPENING THE NAME FILE.
CALL SMESSG(LIJU_ZERO,1,NMESS)
FATAL = .TRUE.
GO TO 190
*
70 CONTINUE
WRITE (NUNIT(1),9001) SNAME,ICI,N,INCX,INCY,K
C CLOSE THE FILE SO USEFUL STATUS INFORMATION IS SEALED.
CLOSE (UNIT=NUNIT(1))
END IF
C DO (DEFINE A SET OF PROBLEM DATA)
ASSIGN 80 TO IGO3
GO TO 370
*
80 CONTINUE
C DO (CALL SUBROUTINE)
ASSIGN 90 TO IGO1
GO TO 290
*
90 CONTINUE
IF (N.LE.0 .OR. ICHAR(ICI).EQ.ICHAR('/')) THEN
C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
ASSIGN 100 TO IGO2
GO TO 220
*
100 CONTINUE
C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN.
SAME = .TRUE.
DO 110 I = 1,NARGS
SAME = SAME .AND. ISAME(I)
IF ( .NOT. ISAME(I)) THEN
WRITE (NUNIT(2),9011) SNAME,I,ICI,N,INCX,INCY,K
END IF
*
110 CONTINUE
IF ( .NOT. SAME) THEN
FATAL = .TRUE.
GO TO 190
*
END IF
*
ELSE
C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
ASSIGN 120 TO IGO2
GO TO 220
*
120 CONTINUE
C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN.
SAME = .TRUE.
DO 130 I = 1,NARGS
NCHNG = (I.EQ.IYARG .OR. ISAME(I))
SAME = SAME .AND. NCHNG
IF ( .NOT. NCHNG) THEN
WRITE (NUNIT(2),9021) SNAME,I,ICI,N,INCX,INCY,K
END IF
*
130 CONTINUE
IF ( .NOT. SAME) THEN
FATAL = .TRUE.
GO TO 190
*
END IF
*
NC = NC + 1
C DO (COMPUTE A CORRECT RESULT)
ASSIGN 140 TO IGO4
GO TO 420
*
140 CONTINUE
C IF GOT REALLY BAD ANSWER, PRINT NOTE AND GO BACK.
IF (FATAL) GO TO 180
*
END IF
*
GO TO 40
*
150 CONTINUE
GO TO 30
*
160 CONTINUE
GO TO 20
*
170 CONTINUE
GO TO 10
*
180 CONTINUE
C REPORT ON ACCURACY OF DATA.
WRITE (NUNIT(2),9031) ISNUM,SNAME,AVIGR,IG
GO TO 210
*
190 CONTINUE
WRITE (NUNIT(2),9041) ISNUM,SNAME
GO TO 210
*
200 CONTINUE
WRITE (NUNIT(2),9051) - ISNUM,SNAME
210 CONTINUE
RETURN
*
220 CONTINUE
C PROCEDURE (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
IF (ISNUM.EQ.3) THEN
ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS)
ISAME(2) = NS .EQ. N
ISAME(3) = ALS .EQ. ALPHA
ISAME(4) = .TRUE.
IF (N.GT.0) ISAME(4) = LSE(AS,A,N,N,LDA)
ISAME(5) = LDAS .EQ. LDA
ISAME(6) = .TRUE.
IF (N.GT.0 .AND. INCX.NE.0) ISAME(6) = LSE(XS,X,1,N,ABS(INCX))
ISAME(7) = INCXS .EQ. INCX
ISAME(8) = BLS .EQ. BETA
ISAME(9) = .TRUE.
IF (N.GT.0 .AND. INCY.NE.0) ISAME(9) = LSE(YS,Y,1,N,ABS(INCY))
ISAME(10) = INCYS .EQ. INCY
*
ELSE IF (ISNUM.EQ.4) THEN
C COMPARE THE MATRIX IN THE SSBMV AND SSPMV DATA STRUCTURES WITH
C THE SAVED COPY.
ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS)
ISAME(2) = NS .EQ. N
ISAME(3) = KS .EQ. K
ISAME(4) = ALS .EQ. ALPHA
ISAME(5) = .TRUE.
C TEST THE MATRIX IN THE DATA STRUCTURE USED WITH SSBMV.
IF (ICHAR(ICI).EQ.ICHAR('U')) THEN
KOFF = K
*
ELSE
KOFF = 0
END IF
*
IF (N.GT.0) THEN
DO 240 J = 1,N
DO 230 I = MAX(1,J-K),MIN(N,J+K)
IF (AS(1+ (I-1)+ (J-1)*LDA).NE.
. A(1+ (KOFF+I-J)+ (J-1)*LDA)) THEN
ISAME(5) = .FALSE.
GO TO 250
*
END IF
*
230 CONTINUE
240 CONTINUE
250 CONTINUE
END IF
*
ISAME(6) = LDAS .EQ. LDA
ISAME(7) = .TRUE.
IF (N.GT.0 .AND. INCX.NE.0) ISAME(7) = LSE(XS,X,1,N,ABS(INCX))
ISAME(8) = INCXS .EQ. INCX
ISAME(9) = BLS .EQ. BETA
ISAME(10) = .TRUE.
IF (N.GT.0 .AND. INCY.NE.0) ISAME(10) = LSE(YS,Y,1,N,
. ABS(INCY))
ISAME(11) = INCYS .EQ. INCY
*
ELSE IF (ISNUM.EQ.5) THEN
ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS)
ISAME(2) = NS .EQ. N
ISAME(3) = ALS .EQ. ALPHA
ISAME(4) = .TRUE.
C TEST THE MATRIX USING THE DATA STRUCTURE USED WITH SSPMV.
IOFF = 0
DO 270 J = 1,N
IF (ICHAR(ICI).EQ.ICHAR('U')) THEN
ISTRT = 1
IEND = J
*
ELSE
ISTRT = J
IEND = N
END IF
*
DO 260 I = ISTRT,IEND
IOFF = IOFF + 1
IF (A(IOFF).NE.AS(1+ (I-1)+ (J-1)*LDA)) THEN
ISAME(4) = .FALSE.
GO TO 280
*
END IF
*
260 CONTINUE
*
270 CONTINUE
280 CONTINUE
ISAME(5) = .TRUE.
IF (N.GT.0 .AND. INCX.NE.0) ISAME(5) = LSE(XS,X,1,N,ABS(INCX))
ISAME(6) = INCXS .EQ. INCX
ISAME(7) = BLS .EQ. BETA
ISAME(8) = .TRUE.
IF (N.GT.0 .AND. INCY.NE.0) ISAME(8) = LSE(YS,Y,1,N,ABS(INCY))
ISAME(9) = INCYS .EQ. INCY
END IF
*
GO TO IGO2
*
290 CONTINUE
C PROCEDURE (CALL SUBROUTINE)
C SAVE EVERY DATUM BEFORE THE CALL.
ICHS = ICI
NS = N
KS = K
ALS = ALPHA
DO 300 I = 1,N*N
AS(I) = A(I)
300 CONTINUE
LDAS = LDA
C SAVE COPY OF THE X AND Y VECTORS.
IBX = 1
IF (INCX.LT.0) IBX = 1 + (1-N)*INCX
DO 310 J = 1,N
XS(IBX+ (J-1)*INCX) = X(IBX+ (J-1)*INCX)
310 CONTINUE
INCXS = INCX
BLS = BETA
IBY = 1
IF (INCY.LT.0) IBY = 1 + (1-N)*INCY
DO 320 I = 1,N
YS(IBY+ (I-1)*INCY) = Y(IBY+ (I-1)*INCY)
320 CONTINUE
INCYS = INCY
IF (ISNUM.EQ.3) THEN
CALL SSYMV(ICI,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
ELSE IF (ISNUM.EQ.4) THEN
C TRANSFER THE MATRIX TO THE DATA STRUCTURE USED WITH SSBMV.
IF (ICHAR(ICI).EQ.ICHAR('U')) THEN
KOFF = K
*
ELSE
KOFF = 0
END IF
*
DO 340 J = 1,N
DO 330 I = MAX(1,J-K),MIN(N,J+K)
A(1+ (KOFF+I-J)+ (J-1)*LDA) = AS(1+ (I-1)+ (J-1)*LDA)
330 CONTINUE
340 CONTINUE
CALL SSBMV(ICI,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
ELSE IF (ISNUM.EQ.5) THEN
C TRANSFER THE MATRIX TO THE DATA STRUCTURE USED WITH SSPMV.
IOFF = 0
DO 360 J = 1,N
IF (ICHAR(ICI).EQ.ICHAR('U')) THEN
ISTRT = 1
IEND = J
*
ELSE
ISTRT = J
IEND = N
END IF
*
DO 350 I = ISTRT,IEND
IOFF = IOFF + 1
A(IOFF) = AS(1+ (I-1)+ (J-1)*LDA)
350 CONTINUE
*
360 CONTINUE
CALL SSPMV(ICI,N,ALPHA,A,X,INCX,BETA,Y,INCY)
END IF
*
GO TO IGO1
*
370 CONTINUE
C PROCEDURE (DEFINE A SET OF PROBLEM DATA)
C DO NOTHING IF DIMENSIONS ARE NOT POSITIVE.
IF (N.LE.0) GO TO IGO3
TRANSL = ZERO
CALL SMAKE(A,N,N,LDA,RESET,TRANSL)
C MAKE THE DATA MATRIX SYMMETRIC.
DO 390 I = 1,N
DO 380 J = I,N
T = (A(1+ (I-1)+ (J-1)*LDA)+A(1+ (J-1)+ (I-1)*LDA))*HALF
A(1+ (I-1)+ (J-1)*LDA) = T
A(1+ (J-1)+ (I-1)*LDA) = T
380 CONTINUE
390 CONTINUE
C TRIM AWAY ELEMENTS OUTSIDE THE BANDWIDTH FOR SSBMV.
IF (ISNUM.EQ.4) THEN
DO 410 J = 1,N
DO 400 I = 1,N
T = A(1+ (I-1)+ (J-1)*LDA)
IF (J.GT.I .AND. J-I.GT.K) T = ZERO
IF (I.GT.J .AND. I-J.GT.K) T = ZERO
A(1+ (I-1)+ (J-1)*LDA) = T
400 CONTINUE
410 CONTINUE
END IF
*
TRANSL = 500.E0
RESET = .FALSE.
CALL SMAKE(X,1,N,MAX(1,ABS(INCX)),RESET,TRANSL)
IF (N.GT.1 .AND. INCX.EQ.1) X(N/2) = ZERO
TRANSL = ZERO
CALL SMAKE(Y,1,N,MAX(1,ABS(INCY)),RESET,TRANSL)
GO TO IGO3
*
420 CONTINUE
C PROCEDURE (COMPUTE A CORRECT RESULT)
C COMPUTE THE CONDITION NUMBER TO USE AS GAUGE FOR ACCURATE RESULTS.
C THIS IS RETURNED IN XT(*).
C COMPUTE THE APPROXIMATE CORRECT RESULT.
C THIS IS RETURNED IN YT(*).
IF (INCY.LT.0) THEN
IBY = (1-N)*INCY + 1
*
ELSE
IBY = 1
END IF
*
DO 440 I = 1,N
YT(I) = BETA*YS(IBY+ (I-1)*INCY)
XT(I) = YS(IBY+ (I-1)*INCY)**2
IF (INCX.LT.0) THEN
IBX = (1-N)*INCX + 1
*
ELSE
IBX = 1
END IF
*
DO 430 J = 1,N
YT(I) = YT(I) + AS(1+ (I-1)+ (J-1)*LDA)*ALPHA*
. XS(IBX+ (J-1)*INCX)
XT(I) = XT(I) + AS(1+ (I-1)+ (J-1)*LDA)**2
430 CONTINUE
XT(I) = SQRT(XT(I))
440 CONTINUE
XN = BETA**2
DO 450 J = 1,N
XN = XN + XS(IBX+ (J-1)*INCX)**2
450 CONTINUE
XN = SQRT(XN)
C COMPUTE THE GAUGES FOR THE RESULTS.
DO 460 I = 1,N
XT(I) = XT(I)*XN
460 CONTINUE
C COMPUTE THE DIFFERENCES. THEY SHOULD BE SMALL FOR CORRECT RESULTS.
DO 470 I = 1,N
YT(I) = YT(I) - Y(IBY+ (I-1)*INCY)
470 CONTINUE
C COMPUTE THE GRADE OF THIS RESULT.
IGR = 0
T = ONE
480 CONTINUE
C THIS TEST ALLOWS UP TO A LOSS OF FULL PRECISION BEFORE QUITTING.
IF (IGR.GT.IG) GO TO 510
DO 490 I = 1,N
IF (SDIFF(T*ABS(YT(I))+XT(I),XT(I)).EQ.ZERO) GO TO 490
T = T*HALF
IGR = IGR + 1
GO TO 480
*
490 CONTINUE
C IF THE LOOP COMPLETES, ALL VALUES ARE 'SMALL.' THE VALUE IGR/IG
C IS THE GRADE ASSIGNED. THE VALUE OF IGR IS MAXIMIZED OVER ALL THE
C PROBLEMS.
500 CONTINUE
AVIGR = MAX(AVIGR,REAL(IGR))
GO TO IGO4
*
510 CONTINUE
FATAL = .TRUE.
GO TO 500
*
* LAST EXECUTABLE LINE OF SCHCK2
9001 FORMAT (' IN SUBPROGRAM ',A,/,' TESTS ACTIVE WITH OPTION = ',A,/,
. ' N = ',I4,/,' INCX = ',I2,', INCY = ',I2,/,' K =',I4)
9011 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2,
. ' WAS CHANGED WITH INVALID INPUT.',/,' OPTION = ',A,/,' N = ',
. I4,/,' INCX = ',I2,', INCY = ',I2,/,' K = ',I4)
9021 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2,
. ' WAS CHANGED WHILE COMPUTING',/,' OPTION = ',A,/,' N = ',I4,/,
. ' INCX = ',I2,', INCY = ',I2,/,' K = ',I4)
9031 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'RECEIVED A LOSS GRADE OF ',
. F5.2,' OUT OF ',I3)
9041 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'FAILED.')
9051 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'NOT TESTED.')
END
SUBROUTINE SCHCK3(ISNUM,SNAME,IG,DOPE,NUNIT,AVIGR,FATAL)
C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
C TEST STRMV, 06, STBMV, 07, STPMV, 08,
C STRSV, 09, STBSV, 10, AND STPSV, 11.
C REVISED 860623
C REVISED YYMMDD
C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
C THIS PROGRAM HAS TWO PARTS. THE FIRST PART CHECKS TO SEE
C IF ANY DATA GETS CHANGED WHEN NONE SHOULD. FOR EXAMPLE WHEN
C USING AN INVALID OPTION OR NONPOSITVE PROBLEM DIMENSIONS.
C THE SECOND PART CHECKS THAT THE RESULTS ARE REASONABLY ACCURATE.
C DIMENSION AND PROBLEM SIZE DATA..
INTEGER INC(04),IDIM(06),NUNIT(2)
LOGICAL ISAME(13),LSE,FATAL,SAME,NCHNG,RESET
CHARACTER *128 DOPE(2)
CHARACTER *6 SNAME
CHARACTER *3 ICHI,ICHJ,ICHK
CHARACTER *1 ICIU,ICIT,ICID
CHARACTER *1 ICIUS,ICITS,ICIDS
INTEGER LA,LV
PARAMETER (LA=4096,LV=4096,LMN=2048)
REAL A(LA),AS(LA),X(LV),XS(LV)
REAL Y(LV),YS(LV),YT(LMN),XT(LMN)
PARAMETER (ZERO=0.E0,HALF=.5E0,ONE=1.E0)
COMMON /ARRAYS/AR,AS,X,XS,Y,YS,XT,YT
EXTERNAL SDIFF
INTEGER LIJU_ZERO(3)
DATA LIJU_ZERO/3*0/
*
DATA INC/-2,-1,1,2/
DATA IDIM/1,2,4,8,64,0/
DATA ICHI/'LU/'/,ICHJ/'NT/'/,ICHK/'NU/'/
FATAL = .FALSE.
C CHECK TRIANGULAR MATRIX-VECTOR PRODUCT, X = A*X, 6-8,
C AND TRIANGULAR SOLVERS, 9-11.
IF (ISNUM.LT.0) GO TO 180
NC = 0
RESET = .TRUE.
AVIGR = ZERO
IX = 0
10 IX = IX + 1
IF (IX.GT.4) GO TO 160
INCX = INC(IX)
NN = 0
20 NN = NN + 1
IF (NN.GT.6) GO TO 150
N = IDIM(NN)
IC = 0
30 IC = IC + 1
IF (IC.GT.3) GO TO 140
IF (FATAL) GO TO 170
ICIU = ICHI(IC:IC)
ICIT = ICHJ(IC:IC)
ICID = ICHK(IC:IC)
C DEFINE DEFAULT VALUE OF K SO PRINTING IS OK.
K = MAX(0,N-1)
C DEFINE THE NUMBER OF ARGUMENTS AND THE X ARGUMENT NUMBER.
LDA = MAX(N,1)
IF (ICHAR(ICIT).EQ.ICHAR('T')) THEN
INCRA = LDA
INCCA = 1
*
ELSE
INCRA = 1
INCCA = LDA
END IF
*
IF (ISNUM.EQ.6 .OR. ISNUM.EQ.9) THEN
NARGS = 08
IXARG = 07
*
ELSE IF (ISNUM.EQ.7 .OR. ISNUM.EQ.10) THEN
NARGS = 09
IXARG = 08
C DEFINE BANDWIDTH OF MATRIX FOR TEST OF STBMV.
K = INT(SQRT(REAL(N))+HALF) - 1
*
ELSE IF (ISNUM.EQ.8 .OR. ISNUM.EQ.11) THEN
NARGS = 07
IXARG = 06
END IF
C DO (PREPARE NOTES FOR THIS TEST)
C
C PRINT A MESSAGE THAT GIVES DEBUGGING INFORMATION. THIS
C MESSAGE SAYS..
C IN SUBPROGRAM XXXXX TESTS WERE ACTIVE WITH
C OPTIONS = 'A' 'A' 'A'
C N = IIII,
C INCX = IIII C K = IIII.
C THE MAIN IDEA HERE IS THAT A SERIOUS BUG THAT OCCURS DURING THE
C TESTING OF THESE SUBPROGRAMS MAY LOSE PROGRAM CONTROL. THIS
C AUXILLIARY FILE CONTAINS THE DIMENSIONS THAT RESULTED IN THE LOSS
C OF CONTROL. HENCE IT PROVIDES THE IMPLEMENTOR WITH MORE COMPLETE
C INFORMATION ABOUT WHERE TO START TRACKING DOWN THE BUG.
IF (NUNIT(1).GT.0) THEN
C IF UNIT IS NOT AVAILABLE WITH 'NEW' STATUS, OPEN WITH
C 'OLD' AND THEN DELETE IT.
ISTAT = 1
CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR)
IF (IERROR.EQ.1) GO TO 40
C GET RID OF ANY OLD FILE.
CLOSE (UNIT=NUNIT(1),STATUS='DELETE',ERR=40)
40 CONTINUE
ISTAT = 2
C CREATE A NEW FILE FOR THE NEXT TEST.
CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR)
IF (IERROR.EQ.0) GO TO 60
50 CONTINUE
NMESS = 7
C DO (PRINT A MESSAGE)
C PRINT AN ERROR MESSAGE ABOUT OPENING THE NAME FILE.
CALL SMESSG(LIJU_ZERO,1,NMESS)
FATAL = .TRUE.
GO TO 170
*
60 CONTINUE
WRITE (NUNIT(1),9001) SNAME,ICIU,ICIT,ICID,N,INCX,K
C CLOSE THE FILE SO USEFUL STATUS INFORMATION IS SEALED.
CLOSE (UNIT=NUNIT(1))
END IF
C DO (DEFINE A SET OF PROBLEM DATA)
ASSIGN 70 TO IGO3
GO TO 330
*
70 CONTINUE
C DO (CALL SUBROUTINE)
ASSIGN 80 TO IGO1
GO TO 260
*
80 CONTINUE
IF (N.LE.0 .OR. ICHAR(ICIU).EQ.ICHAR('/') .OR. ICHAR(ICIT).EQ.
. ICHAR('/') .OR. ICHAR(ICID).EQ.ICHAR('/')) THEN
C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
ASSIGN 90 TO IGO2
GO TO 200
*
90 CONTINUE
C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN.
SAME = .TRUE.
DO 100 I = 1,NARGS
SAME = SAME .AND. ISAME(I)
IF ( .NOT. ISAME(I)) THEN
WRITE (NUNIT(2),9011) SNAME,I,ICIU,ICIT,ICID,N,INCX,K
END IF
*
100 CONTINUE
IF ( .NOT. SAME) THEN
FATAL = .TRUE.
GO TO 170
*
END IF
*
ELSE
C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
ASSIGN 110 TO IGO2
GO TO 200
*
110 CONTINUE
C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN.
SAME = .TRUE.
DO 120 I = 1,NARGS
NCHNG = (I.EQ.IXARG .OR. ISAME(I))
SAME = SAME .AND. NCHNG
IF ( .NOT. NCHNG) THEN
WRITE (NUNIT(2),9021) SNAME,I,ICIU,ICIT,ICID,N,INCX,K
END IF
*
120 CONTINUE
IF ( .NOT. SAME) THEN
FATAL = .TRUE.
GO TO 170
*
END IF
*
NC = NC + 1
C DO (COMPUTE A CORRECT RESULT)
ASSIGN 130 TO IGO4
GO TO 380
*
130 CONTINUE
C IF GOT REALLY BAD ANSWER, PRINT NOTE AND GO BACK.
IF (FATAL) GO TO 160
*
END IF
*
GO TO 30
*
140 CONTINUE
GO TO 20
*
150 CONTINUE
GO TO 10
*
160 CONTINUE
C REPORT ON ACCURACY OF DATA.
WRITE (NUNIT(2),9031) ISNUM,SNAME,AVIGR,IG
GO TO 190
*
170 CONTINUE
WRITE (NUNIT(2),9041) ISNUM,SNAME
GO TO 190
*
180 CONTINUE
WRITE (NUNIT(2),9051) - ISNUM,SNAME
190 CONTINUE
RETURN
*
200 CONTINUE
C PROCEDURE (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
ISAME(1) = ICHAR(ICIU) .EQ. ICHAR(ICIUS)
ISAME(2) = ICHAR(ICIT) .EQ. ICHAR(ICITS)
ISAME(3) = ICHAR(ICID) .EQ. ICHAR(ICIDS)
ISAME(4) = NS .EQ. N
IF (ISNUM.EQ.6 .OR. ISNUM.EQ.9) THEN
ISAME(5) = .TRUE.
IF (N.GT.0) ISAME(5) = LSE(AS,A,N,N,LDA)
ISAME(6) = LDAS .EQ. LDA
ISAME(7) = .TRUE.
IF (N.GT.0) ISAME(7) = LSE(XS,X,1,N,ABS(INCX))
ISAME(8) = INCXS .EQ. INCX
*
ELSE IF (ISNUM.EQ.7 .OR. ISNUM.EQ.10) THEN
C COMPARE THE MATRIX IN THE STBMV AND STPMV DATA STRUCTURES WITH
C THE SAVED COPY.
ISAME(5) = KS .EQ. K
ISAME(6) = .TRUE.
IF (N.GT.0) THEN
DO 220 J = 1,N
IF (ICHAR(ICIU).EQ.ICHAR('U')) THEN
ISTRT = MAX(1,J-K)
IEND = J
*
ELSE
ISTRT = J
IEND = MIN(N,J+K)
END IF
*
DO 210 I = ISTRT,IEND
IF (AS(1+ (I-1)+ (J-1)*LDA).NE.
. A(1+ (KOFF+I-J)+ (J-1)*LDA)) THEN
ISAME(6) = .FALSE.
GO TO 230
*
END IF
*
210 CONTINUE
220 CONTINUE
230 CONTINUE
END IF
*
ISAME(7) = LDAS .EQ. LDA
ISAME(8) = .TRUE.
IF (N.GT.0) ISAME(8) = LSE(XS,X,1,N,ABS(INCX))
ISAME(9) = INCXS .EQ. INCX
*
ELSE IF (ISNUM.EQ.8 .OR. ISNUM.EQ.11) THEN
ISAME(5) = .TRUE.
IOFF = 0
DO 250 J = 1,N
IF (ICHAR(ICIU).EQ.ICHAR('U')) THEN
ISTRT = 1
IEND = J
*
ELSE
ISTRT = J
IEND = N
END IF
*
DO 240 I = ISTRT,IEND
IOFF = IOFF + 1
IF (A(IOFF).NE.AS(1+ (I-1)+ (J-1)*
. LDA)) ISAME(5) = .FALSE.
240 CONTINUE
*
250 CONTINUE
ISAME(6) = .TRUE.
IF (N.GT.0) ISAME(6) = LSE(XS,X,1,N,ABS(INCX))
ISAME(7) = INCXS .EQ. INCX
END IF
*
GO TO IGO2
*
260 CONTINUE
C PROCEDURE (CALL SUBROUTINE)
C SAVE EVERY DATUM BEFORE THE CALL.
ICIUS = ICIU
ICITS = ICIT
ICIDS = ICID
NS = N
KS = K
DO 270 I = 1,N*N
AS(I) = A(I)
270 CONTINUE
LDAS = LDA
C SAVE COPY OF THE X VECTOR.
IBX = 1
IF (INCX.LT.0) IBX = 1 + (1-N)*INCX
DO 280 J = 1,N
XS(IBX+ (J-1)*INCX) = X(IBX+ (J-1)*INCX)
280 CONTINUE
INCXS = INCX
IF (ISNUM.EQ.6) THEN
CALL STRMV(ICIU,ICIT,ICID,N,A,LDA,X,INCX)
*
ELSE IF (ISNUM.EQ.9) THEN
CALL STRSV(ICIU,ICIT,ICID,N,A,LDA,X,INCX)
*
ELSE IF (ISNUM.EQ.7 .OR. ISNUM.EQ.10) THEN
C TRANSFER THE MATRIX TO THE DATA STRUCTURE USED WITH STBMV.
IF (ICHAR(ICIU).EQ.ICHAR('U')) THEN
KOFF = K
*
ELSE
KOFF = 0
END IF
*
DO 300 J = 1,N
IF (ICHAR(ICIU).EQ.ICHAR('U')) THEN
ISTRT = MAX(1,J-K)
IEND = J
*
ELSE
ISTRT = J
IEND = MIN(N,J+K)
END IF
*
DO 290 I = ISTRT,IEND
A(1+ (KOFF+I-J)+ (J-1)*LDA) = AS(1+ (I-1)+ (J-1)*LDA)
290 CONTINUE
300 CONTINUE
IF (ISNUM.EQ.7) CALL STBMV(ICIU,ICIT,ICID,N,K,A,LDA,X,INCX)
IF (ISNUM.EQ.10) CALL STBSV(ICIU,ICIT,ICID,N,K,A,LDA,X,INCX)
*
ELSE IF (ISNUM.EQ.8 .OR. ISNUM.EQ.11) THEN
C TRANSFER THE MATRIX TO THE DATA STRUCTURE USED WITH STPMV.
IOFF = 0
DO 320 J = 1,N
IF (ICHAR(ICIU).EQ.ICHAR('U')) THEN
ISTRT = 1
IEND = J
*
ELSE
ISTRT = J
IEND = N
END IF
*
DO 310 I = ISTRT,IEND
IOFF = IOFF + 1
A(IOFF) = AS(1+ (I-1)+ (J-1)*LDA)
310 CONTINUE
*
320 CONTINUE
IF (ISNUM.EQ.8) CALL STPMV(ICIU,ICIT,ICID,N,A,X,INCX)
IF (ISNUM.EQ.11) CALL STPSV(ICIU,ICIT,ICID,N,A,X,INCX)
END IF
*
GO TO IGO1
*
330 CONTINUE
C PROCEDURE (DEFINE A SET OF PROBLEM DATA)
C DO NOTHING IF DIMENSIONS ARE NOT POSITIVE.
IF (N.LE.0) GO TO IGO3
TRANSL = ZERO
CALL SMAKE(A,N,N,LDA,RESET,TRANSL)
C MAKE THE DATA MATRIX TRIANGULAR.
DO 350 I = 1,N
DO 340 J = 1,N
T = A(1+INCRA* (I-1)+ (J-1)*INCCA)
S = A(1+INCRA* (J-1)+ (I-1)*INCCA)
C SCALE TERMS SO THAT UNIT MATRICES ARE WELL-CONDITIONED.
S = S/1000.E0
T = T/1000.E0
IF (ICHAR(ICIU).EQ.ICHAR('L') .AND. I.LT.J) T = ZERO
IF (ICHAR(ICIU).EQ.ICHAR('U') .AND. I.GT.J) S = ZERO
IF (ICHAR(ICID).EQ.ICHAR('U') .AND. I.EQ.J) THEN
S = ONE
T = ONE
END IF
*
A(1+INCRA* (I-1)+ (J-1)*INCCA) = T
A(1+INCRA* (J-1)+ (I-1)*INCCA) = S
340 CONTINUE
350 CONTINUE
C TRIM AWAY ELEMENTS OUTSIDE THE BANDWIDTH FOR STBMV.
IF (ISNUM.EQ.7 .OR. ISNUM.EQ.10) THEN
DO 370 I = 1,N
DO 360 J = 1,N
T = A(1+INCRA* (I-1)+ (J-1)*INCCA)
IF (J.GT.I .AND. J-I.GT.K) T = ZERO
IF (I.GT.J .AND. I-J.GT.K) T = ZERO
A(1+INCRA* (I-1)+ (J-1)*INCCA) = T
360 CONTINUE
370 CONTINUE
END IF
*
TRANSL = 500.E0
RESET = .FALSE.
CALL SMAKE(X,1,N,MAX(1,ABS(INCX)),RESET,TRANSL)
IF (N.GT.1 .AND. INCX.EQ.1) X(N/2) = ZERO
GO TO IGO3
*
380 CONTINUE
C PROCEDURE (COMPUTE A CORRECT RESULT)
C COMPUTE THE CONDITION NUMBER TO USE AS GAUGE FOR ACCURATE RESULTS.
C THIS IS RETURNED IN XT(*).
C COMPUTE THE APPROXIMATE CORRECT RESULT.
C THIS IS RETURNED IN YT(*).
DO 400 I = 1,N
YT(I) = ZERO
XT(I) = ZERO
IF (INCX.LT.0) THEN
IBX = (1-N)*INCX + 1
*
ELSE
IBX = 1
END IF
*
DO 390 J = 1,N
T = XS(IBX+ (J-1)*INCX)
IF (ISNUM.GE.9) T = X(IBX+ (J-1)*INCX)
YT(I) = YT(I) + AS(1+ (I-1)*INCRA+ (J-1)*INCCA)*T
XT(I) = XT(I) + AS(1+ (I-1)*INCRA+ (J-1)*INCCA)**2
390 CONTINUE
XT(I) = SQRT(XT(I))
400 CONTINUE
XN = ZERO
DO 410 J = 1,N
T = XS(IBX+ (J-1)*INCX)
IF (ISNUM.GE.9) T = X(IBX+ (J-1)*INCX)
XN = XN + T**2
410 CONTINUE
XN = SQRT(XN)
C COMPUTE THE GAUGES FOR THE RESULTS.
DO 420 I = 1,N
XT(I) = XT(I)*XN
420 CONTINUE
C COMPUTE THE DIFFERENCES. THEY SHOULD BE SMALL FOR CORRECT RESULTS.
DO 430 I = 1,N
T = X(IBX+ (I-1)*INCX)
IF (ISNUM.GE.9) T = XS(IBX+ (I-1)*INCX)
YT(I) = YT(I) - T
430 CONTINUE
C COMPUTE THE GRADE OF THIS RESULT.
IGR = 0
T = ONE
440 CONTINUE
C THIS TEST ALLOWS UP TO A LOSS OF FULL PRECISION BEFORE QUITTING.
IF (IGR.GE.IG) GO TO 470
DO 450 I = 1,N
IF (SDIFF(T*ABS(YT(I))+XT(I),XT(I)).EQ.ZERO) GO TO 450
T = T*HALF
IGR = IGR + 1
GO TO 440
*
450 CONTINUE
C IF THE LOOP COMPLETES, ALL VALUES ARE 'SMALL.' THE VALUE IGR/IG
C IS THE GRADE ASSIGNED. THE VALUE OF IGR IS MAXIMIZED OVER ALL THE
C PROBLEMS.
460 CONTINUE
AVIGR = MAX(AVIGR,REAL(IGR))
GO TO IGO4
*
470 CONTINUE
FATAL = .TRUE.
GO TO 460
*
* LAST EXECUTABLE LINE OF SCHCK3
9001 FORMAT (' IN SUBPROGRAM ',A,/,' TESTS ACTIVE WITH OPTIONS = ',
. 3 (A,2X),/,' N = ',I4,/,' INCX = ',I2,/,' K =',I4)
9011 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2,
. ' WAS CHANGED WITH INVALID INPUT.',/,' OPTIONS = ',3 (A,2X),/,
. ' N = ',I4,/,' INCX = ',I2,/,' K = ',I4)
9021 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2,
. ' WAS CHANGED WHILE COMPUTING',/,' OPTIONS = ',3 (A,2X),/,
. ' N = ',I4,/,' INCX = ',I2,/,' K = ',I4)
9031 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'RECEIVED A LOSS GRADE OF ',
. F5.2,' OUT OF ',I3)
9041 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'FAILED.')
9051 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'NOT TESTED.')
END
SUBROUTINE SCHCK4(ISNUM,SNAME,IG,DOPE,NUNIT,AVIGR,FATAL)
C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
C TEST SGER, 12.
C REVISED 860623
C REVISED YYMMDD
C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
C THIS PROGRAM HAS TWO PARTS. THE FIRST PART CHECKS TO SEE
C IF ANY DATA GETS CHANGED WHEN NONE SHOULD. FOR EXAMPLE WHEN
C USING AN INVALID OPTION OR NONPOSITVE PROBLEM DIMENSIONS.
C THE SECOND PART CHECKS THAT THE RESULTS ARE REASONABLY ACCURATE.
C DIMENSION AND PROBLEM SIZE DATA..
INTEGER INC(04),IDIM(08),NUNIT(2)
REAL ALF(04),SDIFF
LOGICAL ISAME(13),LSE,FATAL,SAME,NCHNG,RESET
CHARACTER *128 DOPE(2)
CHARACTER *6 SNAME
INTEGER LA,LV
PARAMETER (LA=4096,LV=4096,LMN=2048)
REAL A(LA),AS(LA),X(LV),XS(LV)
REAL Y(LV),YS(LV),YT(LMN),XT(LMN)
PARAMETER (ZERO=0.E0,HALF=.5E0,ONE=1.E0)
COMMON /ARRAYS/AR,AS,X,XS,Y,YS,YT,XT
EXTERNAL SDIFF
INTEGER LIJU_ZERO(3)
DATA LIJU_ZERO/3*0/
*
DATA ALF/-1.E0,2.E0,.3E0,1.E0/
DATA INC/-2,-1,1,2/
DATA IDIM/1,2,4,8,64,128,2048,0/
FATAL = .FALSE.
C CHECK GENERAL RANK 1 UPDATE, 12.
IF (ISNUM.LT.0) GO TO 200
NC = 0
RESET = .TRUE.
AVIGR = ZERO
IX = 0
10 IX = IX + 1
IF (IX.GT.4) GO TO 180
INCX = INC(IX)
ALPHA = ALF(IX)
IY = 0
20 IY = IY + 1
IF (IY.GT.4) GO TO 170
INCY = INC(IY)
MM = 0
30 MM = MM + 1
IF (MM.GT.8) GO TO 160
M = IDIM(MM)
NN = 0
40 NN = NN + 1
IF (NN.GT.8) GO TO 150
N = IDIM(NN)
IF (FATAL) GO TO 190
ML = N
NL = M
INCCA = M
INCRA = 1
C DEFINE THE NUMBER OF ARGUMENTS AND THE A ARGUMENT NUMBER.
LDA = MAX(M,1)
NARGS = 09
IAARG = 08
C IF NOT ENOUGH STORAGE, SKIP THIS CASE. (AVOID EXPLICT M*N).
IF (SQRT(REAL(N))*SQRT(REAL(M)).GT.SQRT(REAL(LA))) GO TO 40
C DO (PREPARE NOTES FOR THIS TEST)
C
C PRINT A MESSAGE THAT GIVES DEBUGGING INFORMATION. THIS
C MESSAGE SAYS..
C IN SUBPROGRAM XXXXX TESTS WERE ACTIVE WITH
C M = IIII, N = IIII,
C INCX = IIII, INCY = IIII,
C THE MAIN IDEA HERE IS THAT A SERIOUS BUG THAT OCCURS DURING THE
C TESTING OF THESE SUBPROGRAMS MAY LOSE PROGRAM CONTROL. THIS
C AUXILLIARY FILE CONTAINS THE DIMENSIONS THAT RESULTED IN THE LOSS
C OF CONTROL. HENCE IT PROVIDES THE IMPLEMENTOR WITH MORE COMPLETE
C INFORMATION ABOUT WHERE TO START TRACKING DOWN THE BUG.
IF (NUNIT(1).GT.0) THEN
C IF UNIT IS NOT AVAILABLE WITH 'NEW' STATUS, OPEN WITH
C 'OLD' AND THEN DELETE IT.
ISTAT = 1
CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR)
IF (IERROR.EQ.1) GO TO 50
C GET RID OF ANY OLD FILE.
CLOSE (UNIT=NUNIT(1),STATUS='DELETE',ERR=50)
50 CONTINUE
ISTAT = 2
C CREATE A NEW FILE FOR THE NEXT TEST.
CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR)
IF (IERROR.EQ.0) GO TO 70
60 CONTINUE
NMESS = 7
C DO (PRINT A MESSAGE)
C PRINT AN ERROR MESSAGE ABOUT OPENING THE NAME FILE.
CALL SMESSG(LIJU_ZERO,1,NMESS)
FATAL = .TRUE.
GO TO 190
*
70 CONTINUE
WRITE (NUNIT(1),9001) SNAME,M,N,INCX,INCY
C CLOSE THE FILE SO USEFUL STATUS INFORMATION IS SEALED.
CLOSE (UNIT=NUNIT(1))
END IF
C DO (DEFINE A SET OF PROBLEM DATA)
ASSIGN 80 TO IGO3
GO TO 270
*
80 CONTINUE
C DO (CALL SUBROUTINE)
ASSIGN 90 TO IGO1
GO TO 230
*
90 CONTINUE
IF (M.LE.0 .OR. N.LE.0) THEN
C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
ASSIGN 100 TO IGO2
GO TO 220
*
100 CONTINUE
C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN.
SAME = .TRUE.
DO 110 I = 1,NARGS
SAME = SAME .AND. ISAME(I)
IF ( .NOT. ISAME(I)) THEN
WRITE (NUNIT(2),9011) SNAME,I,M,N,INCX,INCY
END IF
*
110 CONTINUE
IF ( .NOT. SAME) THEN
FATAL = .TRUE.
GO TO 190
*
END IF
*
ELSE
C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
ASSIGN 120 TO IGO2
GO TO 220
*
120 CONTINUE
C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN.
SAME = .TRUE.
DO 130 I = 1,NARGS
NCHNG = (I.EQ.IAARG .OR. ISAME(I))
SAME = SAME .AND. NCHNG
IF ( .NOT. NCHNG) THEN
WRITE (NUNIT(2),9021) SNAME,I,M,N,INCX,INCY
END IF
*
130 CONTINUE
IF ( .NOT. SAME) THEN
FATAL = .TRUE.
GO TO 190
*
END IF
*
NC = NC + 1
C DO (COMPUTE A CORRECT RESULT)
ASSIGN 140 TO IGO4
GO TO 280
*
140 CONTINUE
C IF GOT REALLY BAD ANSWER, PRINT NOTE AND GO BACK.
IF (FATAL) GO TO 180
*
END IF
*
GO TO 40
*
150 CONTINUE
GO TO 30
*
160 CONTINUE
GO TO 20
*
170 CONTINUE
GO TO 10
*
180 CONTINUE
C REPORT ON ACCURACY OF DATA.
WRITE (NUNIT(2),9031) ISNUM,SNAME,AVIGR,IG
GO TO 210
*
190 CONTINUE
WRITE (NUNIT(2),9041) ISNUM,SNAME
GO TO 210
*
200 CONTINUE
WRITE (NUNIT(2),9051) - ISNUM,SNAME
210 CONTINUE
RETURN
*
220 CONTINUE
C PROCEDURE (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
ISAME(1) = MS .EQ. M
ISAME(2) = NS .EQ. N
ISAME(3) = ALS .EQ. ALPHA
ISAME(4) = .TRUE.
IF (NL.GT.0 .AND. INCX.NE.0) ISAME(4) = LSE(XS,X,1,NL,ABS(INCX))
ISAME(5) = INCXS .EQ. INCX
ISAME(6) = .TRUE.
IF (ML.GT.0 .AND. INCY.NE.0) ISAME(6) = LSE(YS,Y,1,ML,ABS(INCY))
ISAME(7) = INCYS .EQ. INCY
ISAME(8) = .TRUE.
IF (M.GT.0 .AND. N.GT.0) ISAME(8) = LSE(AS,A,M,N,LDA)
ISAME(9) = LDAS .EQ. LDA
*
GO TO IGO2
*
230 CONTINUE
C PROCEDURE (CALL SUBROUTINE)
C SAVE EVERY DATUM BEFORE THE CALL.
MS = M
NS = N
ALS = ALPHA
DO 240 I = 1,M*N
AS(I) = A(I)
240 CONTINUE
LDAS = LDA
C SAVE COPY OF THE X AND Y VECTORS.
IBX = 1
IF (INCX.LT.0) IBX = 1 + (1-NL)*INCX
DO 250 J = 1,NL
XS(IBX+ (J-1)*INCX) = X(IBX+ (J-1)*INCX)
250 CONTINUE
INCXS = INCX
IBY = 1
IF (INCY.LT.0) IBY = 1 + (1-ML)*INCY
DO 260 I = 1,ML
YS(IBY+ (I-1)*INCY) = Y(IBY+ (I-1)*INCY)
260 CONTINUE
INCYS = INCY
CALL SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
GO TO IGO1
*
270 CONTINUE
C PROCEDURE (DEFINE A SET OF PROBLEM DATA)
C DO NOTHING IF BOTH DIMENSIONS ARE NOT POSITIVE.
IF (M.LE.0 .OR. N.LE.0) GO TO IGO3
TRANSL = ZERO
CALL SMAKE(A,M,N,LDA,RESET,TRANSL)
*
TRANSL = 500.E0
RESET = .FALSE.
CALL SMAKE(X,1,NL,MAX(1,ABS(INCX)),RESET,TRANSL)
IF (NL.GT.1 .AND. INCX.EQ.1) X(NL/2) = ZERO
TRANSL = ZERO
CALL SMAKE(Y,1,ML,MAX(1,ABS(INCY)),RESET,TRANSL)
GO TO IGO3
*
280 CONTINUE
C PROCEDURE (COMPUTE A CORRECT RESULT)
C COMPUTE THE CONDITION NUMBER TO USE AS GAUGE FOR ACCURATE RESULTS.
C THIS IS RETURNED IN XT(*).
C COMPUTE THE APPROXIMATE CORRECT RESULT.
C THIS IS RETURNED IN YT(*), COLUMN BY COLUMN.
IF (INCY.LT.0) THEN
IBY = (1-ML)*INCY + 1
*
ELSE
IBY = 1
END IF
*
DO 340 J = 1,N
DO 290 I = 1,M
IF (INCX.LT.0) THEN
IBX = (1-NL)*INCX + 1
*
ELSE
IBX = 1
END IF
*
YT(I) = AS(1+ (I-1)*INCRA+ (J-1)*INCCA) +
. ALPHA*XS(IBX+ (I-1)*INCX)*YS(IBY+ (J-1)*INCY)
XT(I) = AS(1+ (I-1)*INCRA+ (J-1)*INCCA)**2 +
. ALPHA**2*XS(IBX+ (I-1)*INCX)**2*
. YS(IBY+ (J-1)*INCY)**2
C COMPUTE THE GAUGES FOR THE RESULTS.
XT(I) = SQRT(XT(I))
290 CONTINUE
C COMPUTE THE DIFFERENCES. THEY SHOULD BE SMALL FOR CORRECT RESULTS.
DO 300 I = 1,M
YT(I) = YT(I) - A(1+ (I-1)*INCRA+ (J-1)*INCCA)
300 CONTINUE
C COMPUTE THE GRADE OF THIS RESULT.
IGR = 0
T = ONE
310 CONTINUE
C THIS TEST ALLOWS UP TO A LOSS OF FULL PRECISION BEFORE QUITTING.
IF (IGR.GE.IG) GO TO 360
DO 320 I = 1,M
IF (SDIFF(T*ABS(YT(I))+XT(I),XT(I)).EQ.ZERO) GO TO 320
T = T*HALF
IGR = IGR + 1
GO TO 310
*
320 CONTINUE
C IF THE LOOP COMPLETES, ALL VALUES ARE 'SMALL.' THE VALUE IGR/IG
C IS THE GRADE ASSIGNED. THE VALUE OF IGR IS MAXIMIZED OVER ALL THE
C PROBLEMS.
330 CONTINUE
340 CONTINUE
350 AVIGR = MAX(AVIGR,REAL(IGR))
GO TO IGO4
*
360 CONTINUE
FATAL = .TRUE.
GO TO 350
*
* LAST EXECUTABLE LINE OF SCHCK4
9001 FORMAT (' IN SUBPROGRAM ',A,/,' M =',I4,', N = ',I4,/,' INCX = ',
. I2,', INCY = ',I2)
9011 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2,
. ' WAS CHANGED WITH INVALID INPUT.',/,' M =',I4,', N = ',I4,/,
. ' INCX = ',I2,', INCY = ',I2)
9021 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2,
. ' WAS CHANGED WHILE COMPUTING',/,' M =',I4,', N = ',I4,/,
. ' INCX = ',I2,', INCY = ',I2)
9031 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'RECEIVED A LOSS GRADE OF ',
. F5.2,' OUT OF ',I3)
9041 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'FAILED.')
9051 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'NOT TESTED.')
END
SUBROUTINE SCHCK5(ISNUM,SNAME,IG,DOPE,NUNIT,AVIGR,FATAL)
C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
C TEST SSYR, 13, SSPR, 14, SSYR2, 15, AND SSPR2,16.
C REVISED 860623
C REVISED YYMMDD
C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
C THIS PROGRAM HAS TWO PARTS. THE FIRST PART CHECKS TO SEE
C IF ANY DATA GETS CHANGED WHEN NONE SHOULD. FOR EXAMPLE WHEN
C USING AN INVALID OPTION OR NONPOSITVE PROBLEM DIMENSIONS.
C THE SECOND PART CHECKS THAT THE RESULTS ARE REASONABLY ACCURATE.
C DIMENSION AND PROBLEM SIZE DATA..
INTEGER INC(04),IDIM(06),NUNIT(2)
REAL ALF(04)
LOGICAL ISAME(13),LSE,FATAL,SAME,NCHNG,RESET
CHARACTER *128 DOPE(2)
CHARACTER *6 SNAME
CHARACTER *3 ICH
CHARACTER *1 ICHS,ICI
INTEGER LA,LV
PARAMETER (LA=4096,LV=4096,LMN=2048)
REAL A(LA),AS(LA),X(LV),XS(LV)
REAL Y(LV),YS(LV),YT(LMN),XT(LMN)
PARAMETER (ZERO=0.E0,HALF=.5E0,ONE=1.E0)
COMMON /ARRAYS/AR,AS,X,XS,Y,YS,YT,XT
EXTERNAL SDIFF
INTEGER LIJU_ZERO(3)
DATA LIJU_ZERO/3*0/
*
DATA ALF/-1.E0,2.E0,.3E0,1.E0/
DATA INC/-2,-1,1,2/
DATA IDIM/1,2,4,8,64,0/
DATA ICH/'LU/'/
FATAL = .FALSE.
C CHECK SYMMETRIC MATRIX RANK 1 AND RANK 2 UPDATES.
IF (ISNUM.LT.0) GO TO 200
NC = 0
RESET = .TRUE.
AVIGR = ZERO
IX = 0
10 IX = IX + 1
IF (IX.GT.4) GO TO 180
INCX = INC(IX)
ALPHA = ALF(IX)
IY = 0
20 IY = IY + 1
IF (IY.GT.4) GO TO 170
INCY = INC(IY)
NN = 0
30 NN = NN + 1
IF (NN.GT.6) GO TO 160
N = IDIM(NN)
IC = 0
40 IC = IC + 1
IF (IC.GT.3) GO TO 150
IF (FATAL) GO TO 190
ICI = ICH(IC:IC)
C DEFINE THE NUMBER OF ARGUMENTS AND THE Y ARGUMENT NUMBER.
LDA = MAX(N,1)
IF (ISNUM.EQ.13) THEN
NARGS = 07
IAARG = 06
*
ELSE IF (ISNUM.EQ.14) THEN
NARGS = 06
IAARG = 06
*
ELSE IF (ISNUM.EQ.15) THEN
NARGS = 9
IAARG = 8
*
ELSE IF (ISNUM.EQ.16) THEN
NARGS = 8
IAARG = 8
END IF
C DO (PREPARE NOTES FOR THIS TEST)
C
C PRINT A MESSAGE THAT GIVES DEBUGGING INFORMATION. THIS
C MESSAGE SAYS..
C IN SUBPROGRAM XXXXX TESTS WERE ACTIVE WITH
C OPTION = 'A'
C N = IIII,
C INCX = IIII, INCY = IIII,
C THE MAIN IDEA HERE IS THAT A SERIOUS BUG THAT OCCURS DURING THE
C TESTING OF THESE SUBPROGRAMS MAY LOSE PROGRAM CONTROL. THIS
C AUXILLIARY FILE CONTAINS THE DIMENSIONS THAT RESULTED IN THE LOSS
C OF CONTROL. HENCE IT PROVIDES THE IMPLEMENTOR WITH MORE COMPLETE
C INFORMATION ABOUT WHERE TO START TRACKING DOWN THE BUG.
IF (NUNIT(1).GT.0) THEN
C IF UNIT IS NOT AVAILABLE WITH 'NEW' STATUS, OPEN WITH
C 'OLD' AND THEN DELETE IT.
ISTAT = 1
CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR)
IF (IERROR.EQ.1) GO TO 50
C GET RID OF ANY OLD FILE.
CLOSE (UNIT=NUNIT(1),STATUS='DELETE',ERR=50)
50 CONTINUE
ISTAT = 2
C CREATE A NEW FILE FOR THE NEXT TEST.
CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR)
IF (IERROR.EQ.0) GO TO 70
60 CONTINUE
NMESS = 7
C DO (PRINT A MESSAGE)
C PRINT AN ERROR MESSAGE ABOUT OPENING THE NAME FILE.
CALL SMESSG(LIJU_ZERO,1,NMESS)
FATAL = .TRUE.
GO TO 190
*
70 CONTINUE
WRITE (NUNIT(1),9001) SNAME,ICI,N,INCX,INCY
C CLOSE THE FILE SO USEFUL STATUS INFORMATION IS SEALED.
CLOSE (UNIT=NUNIT(1))
END IF
C DO (DEFINE A SET OF PROBLEM DATA)
ASSIGN 80 TO IGO3
GO TO 370
*
80 CONTINUE
C DO (CALL SUBROUTINE)
ASSIGN 90 TO IGO1
GO TO 290
*
90 CONTINUE
IF (N.LE.0 .OR. ICHAR(ICI).EQ.ICHAR('/')) THEN
C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
ASSIGN 100 TO IGO2
GO TO 220
*
100 CONTINUE
C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN.
SAME = .TRUE.
DO 110 I = 1,NARGS
SAME = SAME .AND. ISAME(I)
IF ( .NOT. ISAME(I)) THEN
WRITE (NUNIT(2),9011) SNAME,I,ICI,N,INCX,INCY
END IF
*
110 CONTINUE
IF ( .NOT. SAME) THEN
FATAL = .TRUE.
GO TO 190
*
END IF
*
ELSE
C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
ASSIGN 120 TO IGO2
GO TO 220
*
120 CONTINUE
C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN.
SAME = .TRUE.
DO 130 I = 1,NARGS
NCHNG = (I.EQ.IAARG .OR. ISAME(I))
SAME = SAME .AND. NCHNG
IF ( .NOT. NCHNG) THEN
WRITE (NUNIT(2),9021) SNAME,I,ICI,N,INCX,INCY
END IF
*
130 CONTINUE
IF ( .NOT. SAME) THEN
FATAL = .TRUE.
GO TO 190
*
END IF
*
NC = NC + 1
C DO (COMPUTE A CORRECT RESULT)
ASSIGN 140 TO IGO4
GO TO 400
*
140 CONTINUE
C IF GOT REALLY BAD ANSWER, PRINT NOTE AND GO BACK.
IF (FATAL) GO TO 180
*
END IF
*
GO TO 40
*
150 CONTINUE
GO TO 30
*
160 CONTINUE
IF (ISNUM.GE.15) GO TO 20
GO TO 10
*
170 CONTINUE
GO TO 10
*
180 CONTINUE
C REPORT ON ACCURACY OF DATA.
WRITE (NUNIT(2),9031) ISNUM,SNAME,AVIGR,IG
GO TO 210
*
190 CONTINUE
WRITE (NUNIT(2),9041) ISNUM,SNAME
GO TO 210
*
200 CONTINUE
WRITE (NUNIT(2),9051) - ISNUM,SNAME
210 CONTINUE
RETURN
*
220 CONTINUE
C PROCEDURE (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
IF (ISNUM.EQ.13) THEN
ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS)
ISAME(2) = NS .EQ. N
ISAME(3) = ALS .EQ. ALPHA
ISAME(4) = .TRUE.
IF (N.GT.0 .AND. INCX.NE.0) ISAME(4) = LSE(XS,X,1,N,ABS(INCX))
ISAME(5) = INCXS .EQ. INCX
ISAME(6) = .TRUE.
IF (N.GT.0) ISAME(6) = LSE(AS,A,N,N,LDA)
ISAME(7) = LDAS .EQ. LDA
*
ELSE IF (ISNUM.EQ.14) THEN
C COMPARE THE MATRIX IN THE DATA STRUCTURES WITH THE SAVED COPY.
ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS)
ISAME(2) = NS .EQ. N
ISAME(3) = ALS .EQ. ALPHA
ISAME(4) = .TRUE.
IF (N.GT.0 .AND. INCX.NE.0) ISAME(4) = LSE(XS,X,1,N,ABS(INCX))
ISAME(5) = INCXS .EQ. INCX
ISAME(6) = .TRUE.
IOFF = 0
DO 240 J = 1,N
IF (ICHAR(ICI).EQ.ICHAR('U')) THEN
ISTRT = 1
IEND = J
*
ELSE
ISTRT = J
IEND = N
END IF
*
DO 230 I = ISTRT,IEND
IOFF = IOFF + 1
IF (A(IOFF).NE.AS(1+ (I-1)+ (J-1)*LDA)) THEN
ISAME(6) = .FALSE.
GO TO 250
*
END IF
*
230 CONTINUE
240 CONTINUE
250 CONTINUE
*
ELSE IF (ISNUM.EQ.15) THEN
ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS)
ISAME(2) = NS .EQ. N
ISAME(3) = ALS .EQ. ALPHA
ISAME(4) = .TRUE.
IF (N.GT.0 .AND. INCX.NE.0) ISAME(4) = LSE(XS,X,1,N,ABS(INCX))
ISAME(5) = INCXS .EQ. INCX
ISAME(6) = .TRUE.
IF (N.GT.0 .AND. INCY.NE.0) ISAME(6) = LSE(YS,Y,1,N,ABS(INCY))
ISAME(7) = INCYS .EQ. INCY
ISAME(8) = .TRUE.
IF (N.GT.0) ISAME(8) = LSE(AS,A,N,N,LDA)
ISAME(9) = LDAS .EQ. LDA
*
ELSE IF (ISNUM.EQ.16) THEN
ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS)
ISAME(2) = NS .EQ. N
ISAME(3) = ALS .EQ. ALPHA
ISAME(4) = .TRUE.
IF (N.GT.0 .AND. INCX.NE.0) ISAME(4) = LSE(XS,X,1,N,ABS(INCX))
ISAME(5) = INCXS .EQ. INCX
ISAME(6) = .TRUE.
IF (N.GT.0 .AND. INCY.NE.0) ISAME(6) = LSE(YS,Y,1,N,ABS(INCY))
ISAME(7) = INCYS .EQ. INCY
ISAME(8) = .TRUE.
IOFF = 0
DO 270 J = 1,N
IF (ICHAR(ICI).EQ.ICHAR('U')) THEN
ISTRT = 1
IEND = J
*
ELSE
ISTRT = J
IEND = N
END IF
*
DO 260 I = ISTRT,IEND
IOFF = IOFF + 1
IF (A(IOFF).NE.AS(1+ (I-1)+ (J-1)*LDA)) THEN
ISAME(8) = .FALSE.
GO TO 280
*
END IF
*
260 CONTINUE
270 CONTINUE
280 CONTINUE
END IF
*
GO TO IGO2
*
290 CONTINUE
C PROCEDURE (CALL SUBROUTINE)
C SAVE EVERY DATUM BEFORE THE CALL.
ICHS = ICI
NS = N
ALS = ALPHA
DO 300 I = 1,N*N
AS(I) = A(I)
300 CONTINUE
LDAS = LDA
C SAVE COPY OF THE X AND Y VECTORS.
IBX = 1
IF (INCX.LT.0) IBX = 1 + (1-N)*INCX
DO 310 J = 1,N
XS(IBX+ (J-1)*INCX) = X(IBX+ (J-1)*INCX)
310 CONTINUE
INCXS = INCX
IBY = 1
IF (INCY.LT.0) IBY = 1 + (1-N)*INCY
DO 320 I = 1,N
YS(IBY+ (I-1)*INCY) = Y(IBY+ (I-1)*INCY)
320 CONTINUE
INCYS = INCY
IF (ISNUM.EQ.13) THEN
CALL SSYR(ICI,N,ALPHA,X,INCX,A,LDA)
*
ELSE IF (ISNUM.EQ.14) THEN
C TRANSFER THE MATRIX TO THE DATA STRUCTURE USED WITH SSPR.
IOFF = 0
DO 340 J = 1,N
IF (ICHAR(ICI).EQ.ICHAR('U')) THEN
ISTRT = 1
IEND = J
*
ELSE
ISTRT = J
IEND = N
END IF
*
DO 330 I = ISTRT,IEND
IOFF = IOFF + 1
A(IOFF) = AS(1+ (I-1)+ (J-1)*LDA)
330 CONTINUE
*
340 CONTINUE
CALL SSPR(ICI,N,ALPHA,X,INCX,A)
*
ELSE IF (ISNUM.EQ.15) THEN
*
CALL SSYR2(ICI,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
ELSE IF (ISNUM.EQ.16) THEN
C TRANSFER THE MATRIX TO THE DATA STRUCTURE USED WITH SSPR2.
IOFF = 0
DO 360 J = 1,N
IF (ICHAR(ICI).EQ.ICHAR('U')) THEN
ISTRT = 1
IEND = J
*
ELSE
ISTRT = J
IEND = N
END IF
*
DO 350 I = ISTRT,IEND
IOFF = IOFF + 1
A(IOFF) = AS(1+ (I-1)+ (J-1)*LDA)
350 CONTINUE
*
360 CONTINUE
CALL SSPR2(ICI,N,ALPHA,X,INCX,Y,INCY,A)
END IF
*
GO TO IGO1
*
370 CONTINUE
C PROCEDURE (DEFINE A SET OF PROBLEM DATA)
C DO NOTHING IF DIMENSIONS ARE NOT POSITIVE.
IF (N.LE.0) GO TO IGO3
TRANSL = ZERO
CALL SMAKE(A,N,N,LDA,RESET,TRANSL)
C MAKE THE DATA MATRIX SYMMETRIC.
DO 390 I = 1,N
DO 380 J = I,N
T = (A(1+ (I-1)+ (J-1)*LDA)+A(1+ (J-1)+ (I-1)*LDA))*HALF
A(1+ (I-1)+ (J-1)*LDA) = T
A(1+ (J-1)+ (I-1)*LDA) = T
380 CONTINUE
390 CONTINUE
*
TRANSL = 500.E0
RESET = .FALSE.
CALL SMAKE(X,1,N,MAX(1,ABS(INCX)),RESET,TRANSL)
IF (N.GT.1 .AND. INCX.EQ.1) X(N/2) = ZERO
TRANSL = ZERO
CALL SMAKE(Y,1,N,MAX(1,ABS(INCY)),RESET,TRANSL)
GO TO IGO3
*
400 CONTINUE
C PROCEDURE (COMPUTE A CORRECT RESULT)
C COMPUTE THE CONDITION NUMBER TO USE AS GAUGE FOR ACCURATE RESULTS.
C THIS IS RETURNED IN XT(*).
C COMPUTE THE APPROXIMATE CORRECT RESULT.
IF (ISNUM.EQ.13 .OR. ISNUM.EQ.14) THEN
IF (INCX.LT.0) THEN
IBX = (1-N)*INCX + 1
*
ELSE
IBX = 1
END IF
*
IOFF = 0
DO 450 J = 1,N
IF (ICHAR(ICI).EQ.ICHAR('U')) THEN
ISTRT = 1
IEND = J
*
ELSE
ISTRT = J
IEND = N
END IF
*
DO 410 I = ISTRT,IEND
YT(I) = AS(1+ (I-1)+ (J-1)*LDA) +
. ALPHA*XS(IBX+ (J-1)*INCX)*XS(IBX+ (I-1)*INCX)
XT(I) = AS(1+ (I-1)+ (J-1)*LDA)**2 +
. ALPHA**2*XS(IBX+ (I-1)*INCX)**2*
. XS(IBX+ (J-1)*INCX)**2
410 CONTINUE
C COMPUTE THE DIFFERENCES. THEY SHOULD BE SMALL FOR CORRECT RESULTS.
DO 420 I = ISTRT,IEND
XT(I) = SQRT(XT(I))
IF (ISNUM.EQ.13) THEN
YT(I) = YT(I) - A(1+ (I-1)+ (J-1)*LDA)
*
ELSE IF (ISNUM.EQ.14) THEN
IOFF = IOFF + 1
YT(I) = YT(I) - A(IOFF)
END IF
*
420 CONTINUE
C COMPUTE THE GRADE OF THIS RESULT.
IGR = 0
T = ONE
DO 440 I = ISTRT,IEND
430 CONTINUE
C THIS TEST ALLOWS UP TO A LOSS OF FULL PRECISION BEFORE QUITTING.
IF (IGR.GE.IG) GO TO 520
IF (SDIFF(T*ABS(YT(I))+XT(I),XT(I)).EQ.ZERO) GO TO 440
T = T*HALF
IGR = IGR + 1
GO TO 430
*
C IF THE LOOP COMPLETES, ALL VALUES ARE 'SMALL.' THE VALUE IGR/IG
C IS THE GRADE ASSIGNED. THE VALUE OF IGR IS MAXIMIZED OVER ALL THE
C PROBLEMS.
440 CONTINUE
450 CONTINUE
*
ELSE IF (ISNUM.EQ.15 .OR. ISNUM.EQ.16) THEN
IF (INCX.LT.0) THEN
IBX = (1-N)*INCX + 1
*
ELSE
IBX = 1
END IF
*
IF (INCY.LT.0) THEN
IBY = (1-N)*INCY + 1
*
ELSE
IBY = 1
END IF
*
IOFF = 0
DO 500 J = 1,N
IF (ICHAR(ICI).EQ.ICHAR('U')) THEN
ISTRT = 1
IEND = J
*
ELSE
ISTRT = J
IEND = N
END IF
*
DO 460 I = ISTRT,IEND
YT(I) = AS(1+ (I-1)+ (J-1)*LDA) +
. ALPHA*XS(IBX+ (J-1)*INCX)*YS(IBY+ (I-1)*INCY) +
. ALPHA*XS(IBX+ (I-1)*INCX)*YS(IBY+ (J-1)*INCY)
XT(I) = AS(1+ (I-1)+ (J-1)*LDA)**2 +
. ALPHA**2*XS(IBX+ (I-1)*INCX)**2*
. YS(IBY+ (J-1)*INCY)**2 +
. ALPHA**2*XS(IBX+ (J-1)*INCX)**2*
. YS(IBY+ (I-1)*INCY)**2
460 CONTINUE
C COMPUTE THE DIFFERENCES. THEY SHOULD BE SMALL FOR CORRECT RESULTS.
DO 470 I = ISTRT,IEND
XT(I) = SQRT(XT(I))
IF (ISNUM.EQ.15) THEN
YT(I) = YT(I) - A(1+ (I-1)+ (J-1)*LDA)
*
ELSE IF (ISNUM.EQ.16) THEN
IOFF = IOFF + 1
YT(I) = YT(I) - A(IOFF)
END IF
*
470 CONTINUE
C COMPUTE THE GRADE OF THIS RESULT.
IGR = 0
T = ONE
DO 490 I = ISTRT,IEND
480 CONTINUE
C THIS TEST ALLOWS UP TO A LOSS OF FULL PRECISION BEFORE QUITTING.
IF (IGR.GE.IG) GO TO 520
IF (SDIFF(T*ABS(YT(I))+XT(I),XT(I)).EQ.ZERO) GO TO 490
T = T*HALF
IGR = IGR + 1
GO TO 480
*
C IF THE LOOP COMPLETES, ALL VALUES ARE 'SMALL.' THE VALUE IGR/IG
C IS THE GRADE ASSIGNED. THE VALUE OF IGR IS MAXIMIZED OVER ALL THE
C PROBLEMS.
490 CONTINUE
500 CONTINUE
END IF
*
510 CONTINUE
AVIGR = MAX(AVIGR,REAL(IGR))
GO TO IGO4
*
520 CONTINUE
FATAL = .TRUE.
GO TO 510
*
* LAST EXECUTABLE LINE OF SCHCK5
9001 FORMAT (' IN SUBPROGRAM ',A,/,' TESTS ACTIVE WITH OPTION = ',A,/,
. ' N = ',I4,/,' INCX = ',I2,', INCY = ',I2)
9011 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2,
. ' WAS CHANGED WITH INVALID INPUT.',/,' OPTION = ',A,/,' N = ',
. I4,/,' INCX = ',I2,', INCY = ',I2)
9021 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2,
. ' WAS CHANGED WHILE COMPUTING',/,' OPTION = ',A,/,' N = ',I4,/,
. ' INCX = ',I2,', INCY = ',I2)
9031 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'RECEIVED A LOSS GRADE OF ',
. F5.2,' OUT OF ',I3)
9041 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'FAILED.')
9051 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'NOT TESTED.')
END
SUBROUTINE SMAKE(A,M,N,LDA,RESET,TRANS)
C GENERATE VALUES FOR AN M BY N MATRIX A.
C RESET THE GENERATOR IF FLAG RESET = .TRUE.
C TRANSLATE THE VALUES WITH TRANS.
C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
C REVISED 860623
C REVISED YYMMDD
C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
REAL A(LDA,*),TRANS,ANOISE
REAL ZERO,HALF,ONE
PARAMETER (ZERO=0.E0,HALF=.5E0,ONE=1.E0,THREE=3.E0)
LOGICAL RESET
IF (RESET) THEN
ANOISE = -ONE
ANOISE = SBEG(ANOISE)
ANOISE = ZERO
END IF
*
IC = 0
DO 20 I = 1,M
DO 10 J = 1,N
IC = IC + 1
C BREAK UP PERIODICITIES THAT ARE MULTIPLES OF 5.
IF (MOD(IC,5).EQ.0) A(I,J) = SBEG(ANOISE)
A(I,J) = SBEG(ANOISE) - TRANS
C HERE THE PERTURBATION IN THE LAST BIT POSITION IS MADE.
A(I,J) = A(I,J) + ONE/THREE
ANOISE = 0.E0
10 CONTINUE
20 CONTINUE
RETURN
* LAST EXECUTABLE LINE OF SMAKE
END
SUBROUTINE SOPEN(IUNIT,NAME,ISTAT,IERROR)
C OPEN UNIT IUNIT WITH FILE NAMED NAME.
C ISTAT=1 FOR 'OLD', =2 FOR 'NEW', =3 FOR 'UNKNOWN'.
C THE RETURN FLAG IERROR=0 FOR SUCCESS, =1 FOR FAILURE.
C A BAD VALUE OF ISTAT CAN ALSO INDICATE FAILURE.
C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
C REVISED 860623
C REVISED YYMMDD
C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
CHARACTER * (*) NAME
IF (ISTAT.EQ.1) OPEN (UNIT=IUNIT,FILE=NAME,STATUS='OLD',ERR=10)
IF (ISTAT.EQ.2) OPEN (UNIT=IUNIT,FILE=NAME,STATUS='NEW',ERR=10)
IF (ISTAT.EQ.3) OPEN (UNIT=IUNIT,FILE=NAME,STATUS='UNKNOWN',
. ERR=10)
GO TO (20,20,20),ISTAT
*
10 CONTINUE
IERROR = 1
GO TO 30
*
20 CONTINUE
IERROR = 0
30 CONTINUE
RETURN
* LAST EXECUTABLE LINE OF SOPEN
END
FUNCTION SDIFF(X,Y)
C C.L.LAWSON AND R.J.HANSON, JET PROPULSION LABORATORY, 1973 JUNE 7
C APPEARED IN 'SOLVING LEAST SQUARES PROBLEMS', PRENTICE-HALL, 1974
C THIS IS USED AS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
C REVISED 860623
C REVISED YYMMDD
C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
SDIFF = X - Y
RETURN
* LAST EXECUTABLE LINE OF SDIFF
END
*
FUNCTION SBEG(ANOISE)
C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
C REVISED 860623
C REVISED YYMMDD
C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
SAVE
C GENERATE NUMBERS FOR CONSTRUCTION OF TEST CASES.
IF (ANOISE) 10,30,20
10 MI = 891
MJ = 457
I = 7
J = 7
AJ = 0.
SBEG = 0.
RETURN
*
20 J = J*MJ
J = J - 997* (J/997)
AJ = J - 498
C THE SEQUENCE OF VALUES OF I IS BOUNDED BETWEEN 1 AND 999
C IF INITIAL I = 1,2,3,6,7, OR 9, THE PERIOD WILL BE 50
C IF INITIAL I = 4 OR 8 THE PERIOD WILL BE 25
C IF INITIAL I = 5 THE PERIOD WILL BE 10
30 I = I*MI
I = I - 1000* (I/1000)
AI = I - 500
SBEG = AI + AJ*ANOISE
RETURN
* LAST EXECUTABLE LINE OF SBEG
END
*
LOGICAL FUNCTION LSE(RI,RJ,M,N,LDI)
C TEST IF TWO REAL ARRAYS ARE IDENTICAL.
C THE ARRAYS ARE M BY N.
C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
C REVISED 860623
C REVISED YYMMDD
C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
REAL RI(LDI,*),RJ(LDI,*)
DO 20 I = 1,M
DO 10 J = 1,N
IF (RI(I,J).NE.RJ(I,J)) THEN
LSE = .FALSE.
GO TO 30
*
END IF
*
10 CONTINUE
20 CONTINUE
LSE = .TRUE.
30 CONTINUE
RETURN
* LAST EXECUTABLE LINE OF LSE
END
*
LOGICAL FUNCTION LDE(DI,DJ,M,N,LDI)
C TEST IF TWO DOUBLE PRECISION ARRAYS ARE IDENTICAL.
C THE ARRAYS ARE M BY N.
C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
C REVISED 860623
C REVISED YYMMDD
C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
DOUBLE PRECISION DI(LDI,*),DJ(LDI,*)
DO 20 I = 1,M
DO 10 J = 1,N
IF (DI(I,J).NE.DJ(I,J)) THEN
LDE = .FALSE.
GO TO 30
*
END IF
*
10 CONTINUE
20 CONTINUE
LDE = .TRUE.
30 CONTINUE
RETURN
* LAST EXECUTABLE LINE OF LDE
END
*
LOGICAL FUNCTION LCE(CI,CJ,M,N,LDI)
C TEST IF TWO COMPLEX ARRAYS ARE IDENTICAL.
C THE ARRAYS ARE M BY N.
C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
C REVISED 860623
C REVISED YYMMDD
C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
COMPLEX CI(LDI,*),CJ(LDI,*)
DO 20 I = 1,M
DO 10 J = 1,N
IF (REAL(CI(I,J)).NE.REAL(CJ(I,J)) .OR. AIMAG(CI(I,J)).NE.
. AIMAG(CJ(I,J))) THEN
LCE = .FALSE.
GO TO 30
*
END IF
*
10 CONTINUE
20 CONTINUE
LCE = .TRUE.
30 CONTINUE
RETURN
* LAST EXECUTABLE LINE OF LCE
END
C
C***********************************************************************
C
C File of the REAL Level 2 BLAS routines:
C
C SGEMV, SGBMV, SSYMV, SSBMV, SSPMV, STRMV, STBMV, STPMV,
C SGER , SSYR , SSPR ,
C SSYR2, SSPR2,
C STRSV, STBSV, STPSV.
C
C See:
C
C Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J..
C A proposal for an extended set of Fortran Basic Linear Algebra
C Subprograms. Technical Memorandum No.41 (revision 1),
C Mathematics and Computer Science Division, Argone National
C Laboratory, 9700 South Cass Avenue, Argonne, Illinois 60439,
C USA, or NAG Technical Report TR4/85, Numerical Algorithms Group
C Inc., 1101 31st Street, Suite 100, Downers Grove, Illinois
C 60606-1263, USA.
C
C***********************************************************************
C
SUBROUTINE SGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
CHARACTER *1 TRANS
INTEGER M,N,LDA,INCX,INCY
REAL ALPHA,A(LDA,*),X(*),BETA,Y(*)
*
* Purpose
* =======
*
* SGEMV performs one of the matrix-vector operations
*
* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
*
* where alpha and beta are scalars, x and y are vectors and A is an
* m by n matrix.
*
* Parameters
* ==========
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the operation to be performed as
* follows:
*
* TRANS = 'N' y := alpha*A*x + beta*y.
*
* TRANS = 'T' y := alpha*A'*x + beta*y.
*
* TRANS = 'C' y := alpha*A'*x + beta*y
*.
* Unchanged on exit.
*
* M - INTEGER.
* On entry, M specifies the number of rows of the matrix A.
* M must be at least zero.
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the number of columns of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry, the leading m by n part of the array A must
* contain the matrix of coefficients.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the leading dimension of A as
* declared in the calling (sub) program. LDA must be at least
* max(m,1).
* Unchanged on exit.
*
* X - REAL array of DIMENSION at least
* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N'
* and at least
* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
* Before entry, the incremented array X must contain the
* vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X.
* Unchanged on exit.
*
* BETA - REAL
* On entry, BETA specifies the scalar beta. When BETA is
* supplied as zero then Y need not be set on input.
* Unchanged on exit.
*
* Y - REAL array of DIMENSION at least
* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N'
* and at least
* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
* Before entry with BETA non-zero, the incremented array Y
* must contain the vector y. On exit, Y is overwritten by the
* updated vector y.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y.
* Unchanged on exit.
*
*
* Note that TRANS, M, N and LDA must be such that the value of the
* LOGICAL variable OK in the following statement is true.
*
*
*
*
* Level 2 Blas routine.
*
* -- Written on 30-August-1985.
* Sven Hammarling, Nag Central Office.
C REVISED 860623
C REVISED YYMMDD
C BY R. J. HANSON, SANDIA NATIONAL LABS.
*
INTEGER I,IX,IY,J,JX,JY
INTEGER KX,KY,LENX,LENY
REAL ONE,ZERO
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
REAL TEMP
LOGICAL OK,LSAME
OK = (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR.
. LSAME(TRANS,'C')) .AND. ((M.GT.0) .AND. (N.GT.0) .AND.
. (LDA.GE.M))
*
* Quick return if possible.
*
IF (((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE)) .OR. .NOT. OK) RETURN
*
* Set LENX and LENY, the lengths of the vectors x and y.
*
IF (LSAME(TRANS,'N')) THEN
LENX = N
LENY = M
*
ELSE
LENX = M
LENY = N
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through A.
*
* First form y := beta*y and set up the start points in X and Y if
* the increments are not both unity.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
IF (BETA.NE.ONE) THEN
IF (BETA.EQ.ZERO) THEN
DO 10,I = 1,LENY
Y(I) = ZERO
10 CONTINUE
*
ELSE
DO 20,I = 1,LENY
Y(I) = BETA*Y(I)
20 CONTINUE
END IF
*
END IF
*
ELSE
IF (INCX.GT.0) THEN
KX = 1
*
ELSE
KX = 1 - (LENX-1)*INCX
END IF
*
IF (INCY.GT.0) THEN
KY = 1
*
ELSE
KY = 1 - (LENY-1)*INCY
END IF
*
IF (BETA.NE.ONE) THEN
IY = KY
IF (BETA.EQ.ZERO) THEN
DO 30,I = 1,LENY
Y(IY) = ZERO
IY = IY + INCY
30 CONTINUE
*
ELSE
DO 40,I = 1,LENY
Y(IY) = BETA*Y(IY)
IY = IY + INCY
40 CONTINUE
END IF
*
END IF
*
END IF
*
IF (ALPHA.EQ.ZERO) RETURN
IF (LSAME(TRANS,'N')) THEN
*
* Form y := alpha*A*x + y.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60,J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = ALPHA*X(J)
DO 50,I = 1,M
Y(I) = Y(I) + TEMP*A(I,J)
50 CONTINUE
END IF
*
60 CONTINUE
*
ELSE
JX = KX
DO 80,J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*X(JX)
IY = KY
DO 70,I = 1,M
Y(IY) = Y(IY) + TEMP*A(I,J)
IY = IY + INCY
70 CONTINUE
END IF
*
JX = JX + INCX
80 CONTINUE
END IF
*
ELSE
*
* Form y := alpha*A'*x + y.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 100,J = 1,N
TEMP = ZERO
DO 90,I = 1,M
TEMP = TEMP + A(I,J)*X(I)
90 CONTINUE
Y(J) = Y(J) + ALPHA*TEMP
100 CONTINUE
*
ELSE
JY = KY
DO 120,J = 1,N
TEMP = ZERO
IX = KX
DO 110,I = 1,M
TEMP = TEMP + A(I,J)*X(IX)
IX = IX + INCX
110 CONTINUE
Y(JY) = Y(JY) + ALPHA*TEMP
JY = JY + INCY
120 CONTINUE
END IF
*
END IF
*
RETURN
*
* End of SGEMV .
*
END
SUBROUTINE SGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
CHARACTER *1 TRANS
INTEGER M,N,KL,KU,LDA,INCX,INCY
REAL ALPHA,A(LDA,*),X(*),BETA,Y(*)
*
* Purpose
* =======
*
* SGBMV performs one of the matrix-vector operations
*
* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
*
* where alpha and beta are scalars, x and y are vectors and A is an
* m by n band matrix, with kl sub-diagonals and ku super-diagonals.
*
* Parameters
* ==========
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the operation to be performed as
* follows:
*
* TRANS = 'N' y := alpha*A*x + beta*y.
*
* TRANS = 'T' y := alpha*A'*x + beta*y.
*
* TRANS = 'C' y := alpha*A'*x + beta*y.
*
* Unchanged on exit.
*
* M - INTEGER.
* On entry, M specifies the number of rows of the matrix A.
* M must be at least zero.
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the number of columns of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* KL - INTEGER.
* On entry, KL specifies the number of sub-diagonals of the
* matrix A. KL must satisfy 0 .le. KL.
* Unchanged on exit.
*
* KU - INTEGER.
* On entry, KU specifies the number of super-diagonals of the
* matrix A. KU must satisfy 0 .le. KU.
* Unchanged on exit.
*
* Users may find that efficiency of their application is enhanced by
* adjusting the values of m and n so that KL .ge. max(0,m-n) and
* KU .ge. max(0,n-m) or KL and KU so that KL .lt. m and KU .lt. n.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry, the leading ( kl + ku + 1 ) by n part of the
* array A must contain the matrix of coefficients, supplied
* column by column, with the leading diagonal of the matrix in
* row ( ku + 1 ) of the array, the first super-diagonal
* starting at position 2 in row ku, the first sub-diagonal
* starting at position 1 in row ( ku + 2 ), and so on.
* This placement of the data can be realized with the
* following loops:
* DO 20 J =1,N
* K=KU+1-J
* DO 10 I =MAX(1,J-KU),MIN(M,J+KL)
* A(K+I,J)=matrix entry of row I, column J.
* 10 CONTINUE
* 20 CONTINUE
* Elements in the array A that do not correspond to elements
* in the band matrix (such as the top left ku by ku triangle)
* are not referenced.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the leading dimension of A as
* declared in the calling (sub) program. LDA must be at least
* ( kl + ku + 1 ).
* Unchanged on exit.
*
* X - REAL array of DIMENSION at least
* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N'
* and at least
* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
* Before entry, the incremented array X must contain the
* vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X.
* Unchanged on exit.
*
* BETA - REAL .
* On entry, BETA specifies the scalar beta. When BETA is
* supplied as zero then Y need not be set on input.
* Unchanged on exit.
*
* Y - REAL array of DIMENSION at least
* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N'
* and at least
* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
* Before entry, the incremented array Y must contain the
* vector y. On exit, Y is overwritten by the updated vector y.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y.
* Unchanged on exit.
*
*
*
*
* Level 2 Blas routine.
*
* -- Written on 27-Sept-1985.
* Sven Hammarling, Nag Central Office.
C REVISED 860623
C REVISED YYMMDD
C BY R. J. HANSON, SANDIA NATIONAL LABS.
*
INTRINSIC MAX,MIN
INTEGER I,IX,IY,J,JX,JY
INTEGER K,KUP1,KX,KY,LENX,LENY
REAL ONE,ZERO
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
REAL TEMP
LOGICAL OK,LSAME
OK = (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR.
. LSAME(TRANS,'C')) .AND. (M.GT.0) .AND. (N.GT.0) .AND.
. (KL.GE.0) .AND. (KU.GE.0) .AND.
. (LDA.GE. (KL+KU+1))
*
* Quick return if possible.
*
IF ( .NOT. OK .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
* Set LENX and LENY, the lengths of the vectors x and y.
*
IF (LSAME(TRANS,'N')) THEN
LENX = N
LENY = M
*
ELSE
LENX = M
LENY = N
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through the band part of A.
*
* First form y := beta*y and set up the start points in X and Y
* if the increments are not both unity.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
IF (BETA.NE.ONE) THEN
IF (BETA.EQ.ZERO) THEN
DO 10,I = 1,LENY
Y(I) = ZERO
10 CONTINUE
*
ELSE
DO 20,I = 1,LENY
Y(I) = BETA*Y(I)
20 CONTINUE
END IF
*
END IF
*
ELSE
IF (INCX.GT.0) THEN
KX = 1
*
ELSE
KX = 1 - (LENX-1)*INCX
END IF
*
IF (INCY.GT.0) THEN
KY = 1
*
ELSE
KY = 1 - (LENY-1)*INCY
END IF
*
IF (BETA.NE.ONE) THEN
IY = KY
IF (BETA.EQ.ZERO) THEN
DO 30,I = 1,LENY
Y(IY) = ZERO
IY = IY + INCY
30 CONTINUE
*
ELSE
DO 40,I = 1,LENY
Y(IY) = BETA*Y(IY)
IY = IY + INCY
40 CONTINUE
END IF
*
END IF
*
END IF
*
IF (ALPHA.EQ.ZERO) RETURN
KUP1 = KU + 1
IF (LSAME(TRANS,'N')) THEN
*
* Form y := alpha*A*x + y.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60,J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = ALPHA*X(J)
K = KUP1 - J
DO 50,I = MAX(1,J-KU),MIN(M,J+KL)
Y(I) = Y(I) + TEMP*A(K+I,J)
50 CONTINUE
END IF
*
60 CONTINUE
*
ELSE
JX = KX
DO 80,J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*X(JX)
IY = KY
K = KUP1 - J
DO 70,I = MAX(1,J-KU),MIN(M,J+KL)
Y(IY) = Y(IY) + TEMP*A(K+I,J)
IY = IY + INCY
70 CONTINUE
END IF
*
JX = JX + INCX
IF (J.GT.KU) KY = KY + INCY
80 CONTINUE
END IF
*
ELSE
*
* Form y := alpha*A'*x + y.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 100,J = 1,N
TEMP = ZERO
K = KUP1 - J
DO 90,I = MAX(1,J-KU),MIN(M,J+KL)
TEMP = TEMP + A(K+I,J)*X(I)
90 CONTINUE
Y(J) = Y(J) + ALPHA*TEMP
100 CONTINUE
*
ELSE
JY = KY
DO 120,J = 1,N
TEMP = ZERO
IX = KX
K = KUP1 - J
DO 110,I = MAX(1,J-KU),MIN(M,J+KL)
TEMP = TEMP + A(K+I,J)*X(IX)
IX = IX + INCX
110 CONTINUE
Y(JY) = Y(JY) + ALPHA*TEMP
JY = JY + INCY
IF (J.GT.KU) KX = KX + INCX
120 CONTINUE
END IF
*
END IF
*
RETURN
*
* End of SGBMV .
*
END
SUBROUTINE SSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
CHARACTER *1 UPLO
INTEGER N,LDA,INCX,INCY
REAL ALPHA,A(LDA,*),X(*),BETA,Y(*)
*
* Purpose
* =======
*
* SSYMV performs the matrix-vector operation
*
* y := alpha*A*x + beta*y,
*
* where alpha and beta are scalars, x and y are n element vectors and
* A is an n by n symmetric matrix.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the array A is to be referenced as
* follows:
*
* UPLO = 'U' Only the upper triangular part of A
* is to be referenced.
*
* UPLO = 'L' Only the lower triangular part of A
* is to be referenced.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U', the leading n by n
* upper triangular part of the array A must contain the upper
* triangular part of the symmetric matrix and the strictly
* lower triangular part of A is not referenced.
* Before entry with UPLO = 'L', the leading n by n
* lower triangular part of the array A must contain the lower
* triangular part of the symmetric matrix and the strictly
* upper triangular part of A is not referenced.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least max(n,1).
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X.
* Unchanged on exit.
*
* BETA - REAL .
* On entry, BETA specifies the scalar beta. When BETA is
* supplied as zero then Y need not be set on input.
* Unchanged on exit.
*
* Y - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCY ) ).
* Before entry, the incremented array Y must contain the n
* element vector y. On exit, Y is overwritten by the updated
* vector y.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- Written on 27-Sept-1985.
* Sven Hammarling, Nag Central Office.
C REVISED 860623
C REVISED YYMMDD
C BY R. J. HANSON, SANDIA NATIONAL LABS.
*
INTEGER I,IX,IY,J,JX,JY
INTEGER KX,KY
REAL ONE,ZERO
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
REAL TEMP1,TEMP2
LOGICAL OK,LSAME
OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. (N.GT.0) .AND.
. (LDA.GE.N)
*
* Quick return if possible.
*
IF ( .NOT. OK .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through the triangular part
* of A.
*
* First form y := beta*y and set up the start points in X and Y if
* the increments are not both unity.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
IF (BETA.NE.ONE) THEN
IF (BETA.EQ.ZERO) THEN
DO 10,I = 1,N
Y(I) = ZERO
10 CONTINUE
*
ELSE
DO 20,I = 1,N
Y(I) = BETA*Y(I)
20 CONTINUE
END IF
*
END IF
*
ELSE
IF (INCX.GT.0) THEN
KX = 1
*
ELSE
KX = 1 - (N-1)*INCX
END IF
*
IF (INCY.GT.0) THEN
KY = 1
*
ELSE
KY = 1 - (N-1)*INCY
END IF
*
IF (BETA.NE.ONE) THEN
IY = KY
IF (BETA.EQ.ZERO) THEN
DO 30,I = 1,N
Y(IY) = ZERO
IY = IY + INCY
30 CONTINUE
*
ELSE
DO 40,I = 1,N
Y(IY) = BETA*Y(IY)
IY = IY + INCY
40 CONTINUE
END IF
*
END IF
*
END IF
*
IF (ALPHA.EQ.ZERO) RETURN
IF (LSAME(UPLO,'U')) THEN
*
* Form y when A is stored in upper triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60,J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
DO 50,I = 1,J - 1
Y(I) = Y(I) + TEMP1*A(I,J)
TEMP2 = TEMP2 + A(I,J)*X(I)
50 CONTINUE
Y(J) = Y(J) + TEMP1*A(J,J) + ALPHA*TEMP2
60 CONTINUE
*
ELSE
IX = KX - INCX
DO 80,J = 1,N
TEMP1 = ALPHA*X(IX+INCX)
TEMP2 = ZERO
IX = KX
IY = KY
DO 70,I = 1,J - 1
Y(IY) = Y(IY) + TEMP1*A(I,J)
TEMP2 = TEMP2 + A(I,J)*X(IX)
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
Y(IY) = Y(IY) + TEMP1*A(J,J) + ALPHA*TEMP2
80 CONTINUE
END IF
*
ELSE
*
* Form y when A is stored in lower triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 100,J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
Y(J) = Y(J) + TEMP1*A(J,J)
DO 90,I = J + 1,N
Y(I) = Y(I) + TEMP1*A(I,J)
TEMP2 = TEMP2 + A(I,J)*X(I)
90 CONTINUE
Y(J) = Y(J) + ALPHA*TEMP2
100 CONTINUE
*
ELSE
JX = KX
JY = KY
DO 120,J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
Y(JY) = Y(JY) + TEMP1*A(J,J)
IX = JX
IY = JY
DO 110,I = J + 1,N
IX = IX + INCX
IY = IY + INCY
Y(IY) = Y(IY) + TEMP1*A(I,J)
TEMP2 = TEMP2 + A(I,J)*X(IX)
110 CONTINUE
Y(JY) = Y(JY) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
120 CONTINUE
END IF
*
END IF
*
RETURN
*
* End of SSYMV .
*
END
SUBROUTINE SSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
CHARACTER *1 UPLO
INTEGER N,K,LDA,INCX,INCY
REAL ALPHA,A(LDA,*),X(*),BETA,Y(*)
*
* Purpose
* =======
*
* SSBMV performs the matrix-vector operation
*
* y := alpha*A*x + beta*y,
*
* where alpha and beta are scalars, x and y are n element vectors and
* A is an n by n symmetric band matrix, with k super-diagonals.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the band matrix A is being supplied as
* follows:
*
* UPLO = 'U' The upper triangular part of A is
* being supplied.
*
* UPLO = 'L' The lower triangular part of A is
* being supplied.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* K - INTEGER.
* On entry, K specifies the number of super-diagonals of the
* matrix A. K must satisfy 0 .le. K .lt. n.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U', the leading ( k + 1 )
* by n part of the array A must contain the upper triangular
* band part of the symmetric matrix, supplied column by
* column, with the leading diagonal of the matrix in row
* ( k + 1 ) of the array, the first super-diagonal starting at
* position 2 in row k, and so on. The top left k by k triangle
* of the array A is not referenced.
* Before entry with UPLO = 'L', the leading ( k + 1 )
* by n part of the array A must contain the lower triangular
* band part of the symmetric matrix, supplied column by
* column, with the leading diagonal of the matrix in row 1 of
* the array, the first sub-diagonal starting at position 1 in
* row 2, and so on. The bottom right k by k triangle of the
* array A is not referenced.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the leading dimension of A as
* declared in the calling (sub) program. LDA must be at least
* ( k + 1 ).
* Unchanged on exit.
*
* X - REAL array of DIMENSION at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the
* vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X.
* Unchanged on exit.
*
* BETA - REAL .
* On entry, BETA specifies the scalar beta.
* Unchanged on exit.
*
* Y - REAL array of DIMENSION at least
* ( 1 + ( n - 1 )*abs( INCY ) ).
* Before entry, the incremented array Y must contain the
* vector y. On exit, Y is overwritten by the updated vector y.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y.
* Unchanged on exit.
*
*
*
* Level 2 Blas routine.
*
* -- Written on 30-September-1985.
* Sven Hammarling, Nag Central Office.
C REVISED 860623
C REVISED YYMMDD
C BY R. J. HANSON, SANDIA NATIONAL LABS.
*
INTRINSIC MAX,MIN
INTEGER I,IX,IY,J,JX,JY
INTEGER KPLUS1,KX,KY,L
REAL ONE,ZERO
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
REAL TEMP1,TEMP2
LOGICAL OK,LSAME
OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. (N.GT.0) .AND.
. (K.GE.0) .AND. (K.LT.N) .AND. (LDA.GE. (K+1))
*
* Quick return if possible.
*
IF ( .NOT. OK .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
* Start the operations. In this version the elements of the array A
* are accessed sequentially with one pass through A.
*
* First form y := beta*y and set up the start points in X and Y if
* the increments are not both unity.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
IF (BETA.NE.ONE) THEN
IF (BETA.EQ.ZERO) THEN
DO 10,I = 1,N
Y(I) = ZERO
10 CONTINUE
*
ELSE
DO 20,I = 1,N
Y(I) = BETA*Y(I)
20 CONTINUE
END IF
*
END IF
*
ELSE
IF (INCX.GT.0) THEN
KX = 1
*
ELSE
KX = 1 - (N-1)*INCX
END IF
*
IF (INCY.GT.0) THEN
KY = 1
*
ELSE
KY = 1 - (N-1)*INCY
END IF
*
IF (BETA.NE.ONE) THEN
IY = KY
IF (BETA.EQ.ZERO) THEN
DO 30,I = 1,N
Y(IY) = ZERO
IY = IY + INCY
30 CONTINUE
*
ELSE
DO 40,I = 1,N
Y(IY) = BETA*Y(IY)
IY = IY + INCY
40 CONTINUE
END IF
*
END IF
*
END IF
*
IF (ALPHA.EQ.ZERO) RETURN
IF (LSAME(UPLO,'U')) THEN
*
* Form y when upper triangle of A is stored.
*
KPLUS1 = K + 1
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60,J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
I = MAX(1,J-K)
DO 50,L = KPLUS1 + I - J,K
Y(I) = Y(I) + TEMP1*A(L,J)
TEMP2 = TEMP2 + A(L,J)*X(I)
I = I + 1
50 CONTINUE
Y(J) = Y(J) + TEMP1*A(KPLUS1,J) + ALPHA*TEMP2
60 CONTINUE
*
ELSE
IX = KX - INCX
DO 80,J = 1,N
TEMP1 = ALPHA*X(IX+INCX)
TEMP2 = ZERO
IX = KX
IY = KY
DO 70,L = 1 + MAX(KPLUS1-J,0),K
Y(IY) = Y(IY) + TEMP1*A(L,J)
TEMP2 = TEMP2 + A(L,J)*X(IX)
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
Y(IY) = Y(IY) + TEMP1*A(KPLUS1,J) + ALPHA*TEMP2
IF (J.GT.K) THEN
KX = KX + INCX
KY = KY + INCY
END IF
*
80 CONTINUE
END IF
*
ELSE
*
* Form y when lower triangle of A is stored.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 100,J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
Y(J) = Y(J) + TEMP1*A(1,J)
I = J + 1
DO 90,L = 2,1 + MIN(K,N-J)
Y(I) = Y(I) + TEMP1*A(L,J)
TEMP2 = TEMP2 + A(L,J)*X(I)
I = I + 1
90 CONTINUE
Y(J) = Y(J) + ALPHA*TEMP2
100 CONTINUE
*
ELSE
JX = KX
JY = KY
DO 120,J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
Y(JY) = Y(JY) + TEMP1*A(1,J)
IX = JX
IY = JY
DO 110,L = 2,1 + MIN(K,N-J)
IX = IX + INCX
IY = IY + INCY
Y(IY) = Y(IY) + TEMP1*A(L,J)
TEMP2 = TEMP2 + A(L,J)*X(IX)
110 CONTINUE
Y(JY) = Y(JY) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
120 CONTINUE
END IF
*
END IF
*
RETURN
*
* End of SSBMV .
*
END
SUBROUTINE SSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
CHARACTER *1 UPLO
INTEGER N,INCX,INCY
REAL ALPHA,AP(*),X(*),BETA,Y(*)
*
* Purpose
* =======
*
* SSPMV performs the matrix-vector operation
*
* y := alpha*A*x + beta*y,
*
* where alpha and beta are scalars, x and y are n element vectors and
* A is an n by n symmetric matrix.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the matrix A is supplied in the packed
* array AP as follows:
*
* UPLO = 'U' The upper triangular part of A is
* supplied in AP.
*
* UPLO = 'L' The lower triangular part of A is
* supplied in AP.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* AP - REAL array of DIMENSION at least
* ( ( n*( n + 1 ) )/2 ).
* Before entry with UPLO = 'U', the array AP must
* contain the upper triangular part of the symmetric matrix
* packed sequentially, column by column, so that AP( 1 )
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
* and a( 2, 2 ) respectively, and so on.
* Before entry with UPLO = 'L', the array AP must
* contain the lower triangular part of the symmetric matrix
* packed sequentially, column by column, so that AP( 1 )
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
* and a( 3, 1 ) respectively, and so on.
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X.
* Unchanged on exit.
*
* BETA - REAL .
* On entry, BETA specifies the scalar beta. When BETA is
* supplied as zero then Y need not be set on input.
* Unchanged on exit.
*
* Y - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCY ) ).
* Before entry, the incremented array Y must contain the n
* element vector y. On exit, Y is overwritten by the updated
* vector y.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y.
* Unchanged on exit.
*
*
*
*
*
* Level 2 Blas routine.
*
* -- Written on 27-Sept-1985.
* Sven Hammarling, Nag Central Office.
C REVISED 860623
C REVISED YYMMDD
C BY R. J. HANSON, SANDIA NATIONAL LABS.
*
INTEGER I,IX,IY,J,JX,JY
INTEGER K,KK,KX,KY
REAL ONE,ZERO
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
REAL TEMP1,TEMP2
LOGICAL OK,LSAME
OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. (N.GT.0)
*
* Quick return if possible.
*
IF ( .NOT. OK .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
* Start the operations. In this version the elements of the array AP
* are accessed sequentially with one pass through AP.
*
* First form y := beta*y and set up the start points in X and Y if
* the increments are not both unity.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
IF (BETA.NE.ONE) THEN
IF (BETA.EQ.ZERO) THEN
DO 10,I = 1,N
Y(I) = ZERO
10 CONTINUE
*
ELSE
DO 20,I = 1,N
Y(I) = BETA*Y(I)
20 CONTINUE
END IF
*
END IF
*
ELSE
IF (INCX.GT.0) THEN
KX = 1
*
ELSE
KX = 1 - (N-1)*INCX
END IF
*
IF (INCY.GT.0) THEN
KY = 1
*
ELSE
KY = 1 - (N-1)*INCY
END IF
*
IF (BETA.NE.ONE) THEN
IY = KY
IF (BETA.EQ.ZERO) THEN
DO 30,I = 1,N
Y(IY) = ZERO
IY = IY + INCY
30 CONTINUE
*
ELSE
DO 40,I = 1,N
Y(IY) = BETA*Y(IY)
IY = IY + INCY
40 CONTINUE
END IF
*
END IF
*
END IF
*
IF (ALPHA.EQ.ZERO) RETURN
K = 1
IF (LSAME(UPLO,'U')) THEN
*
* Form y when AP contains the upper triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60,J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
DO 50,I = 1,J - 1
Y(I) = Y(I) + TEMP1*AP(K)
TEMP2 = TEMP2 + AP(K)*X(I)
K = K + 1
50 CONTINUE
Y(J) = Y(J) + TEMP1*AP(K) + ALPHA*TEMP2
K = K + 1
60 CONTINUE
*
ELSE
IX = KX - INCX
DO 80,J = 1,N
TEMP1 = ALPHA*X(IX+INCX)
TEMP2 = ZERO
IX = KX
IY = KY
KK = K
DO 70,K = KK,KK + J - 2
Y(IY) = Y(IY) + TEMP1*AP(K)
TEMP2 = TEMP2 + AP(K)*X(IX)
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
Y(IY) = Y(IY) + TEMP1*AP(K) + ALPHA*TEMP2
K = K + 1
80 CONTINUE
END IF
*
ELSE
*
* Form y when AP contains the upper triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 100,J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
Y(J) = Y(J) + TEMP1*AP(K)
K = K + 1
DO 90,I = J + 1,N
Y(I) = Y(I) + TEMP1*AP(K)
TEMP2 = TEMP2 + AP(K)*X(I)
K = K + 1
90 CONTINUE
Y(J) = Y(J) + ALPHA*TEMP2
100 CONTINUE
*
ELSE
JX = KX
JY = KY
DO 120,J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
Y(JY) = Y(JY) + TEMP1*AP(K)
IX = JX
IY = JY
KK = K + 1
DO 110,K = KK,KK + N - (J+1)
IX = IX + INCX
IY = IY + INCY
Y(IY) = Y(IY) + TEMP1*AP(K)
TEMP2 = TEMP2 + AP(K)*X(IX)
110 CONTINUE
Y(JY) = Y(JY) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
120 CONTINUE
END IF
*
END IF
*
RETURN
*
* End of SSPMV .
*
END
SUBROUTINE STRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
CHARACTER *1 UPLO,TRANS,DIAG
INTEGER N,LDA,INCX
REAL A(LDA,*),X(*)
*
* Purpose
* =======
*
* STRMV performs one of the matrix-vector operations
*
* x := A*x, or x := A'*x,
*
* where x is n element vector and A is an n by n unit, or non-unit,
* upper or lower triangular matrix.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix is an upper or
* lower triangular matrix as follows:
*
* UPLO = 'U' A is an upper triangular matrix.
*
* UPLO = 'L' A is a lower triangular matrix.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the operation to be performed as
* follows:
*
* TRANS = 'N' x := A*x.
*
* TRANS = 'T' x := A'*x.
*
* TRANS = 'C' x := A'*x.
*
* Unchanged on exit.
*
* DIAG - CHARACTER*1.
* On entry, DIAG specifies whether or not A is unit
* triangular as follows:
*
* DIAG = 'U' A is assumed to be unit triangular.
*
* DIAG = 'N' A is not assumed to be unit
* triangular.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U', the leading n by n
* upper triangular part of the array A must contain the upper
* triangular matrix and the strictly lower triangular part of
* A is not referenced.
* Before entry with UPLO = 'L', the leading n by n
* lower triangular part of the array A must contain the lower
* triangular matrix and the strictly upper triangular part of
* A is not referenced.
* Note that when DIAG = 'U', the diagonal elements of
* A are not referenced either, but are assumed to be unity.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least max(n,1).
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x. On exit, X is overwritten with the
* tranformed vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X.
* Unchanged on exit.
*
*
*
*
* Level 2 Blas routine.
*
* -- Written on 30-September-1985.
* Sven Hammarling, Nag Central Office.
C REVISED 860623
C REVISED YYMMDD
C BY R. J. HANSON, SANDIA NATIONAL LABS.
*
LOGICAL NOUNIT
INTEGER I,IX,J,JX,KX
REAL ZERO
PARAMETER (ZERO=0.0E+0)
LOGICAL OK,LSAME
OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND.
. (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR.
. LSAME(TRANS,'C')) .AND. (LSAME(DIAG,'U') .OR.
. LSAME(DIAG,'N')) .AND. (N.GT.0) .AND. (LDA.GE.N)
*
*
* Quick return if possible.
*
IF ( .NOT. OK) RETURN
NOUNIT = LSAME(DIAG,'N')
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
*
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through A.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x := A*x.
*
IF (LSAME(UPLO,'U')) THEN
IF (INCX.EQ.1) THEN
DO 20,J = 1,N
IF (X(J).NE.ZERO) THEN
DO 10,I = 1,J - 1
X(I) = X(I) + X(J)*A(I,J)
10 CONTINUE
IF (NOUNIT) X(J) = X(J)*A(J,J)
END IF
*
20 CONTINUE
*
ELSE
JX = KX
DO 40,J = 1,N
IF (X(JX).NE.ZERO) THEN
IX = KX
DO 30,I = 1,J - 1
X(IX) = X(IX) + X(JX)*A(I,J)
IX = IX + INCX
30 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*A(J,J)
END IF
*
JX = JX + INCX
40 CONTINUE
END IF
*
ELSE
IF (INCX.EQ.1) THEN
DO 60,J = N,1,-1
IF (X(J).NE.ZERO) THEN
DO 50,I = N,J + 1,-1
X(I) = X(I) + X(J)*A(I,J)
50 CONTINUE
IF (NOUNIT) X(J) = X(J)*A(J,J)
END IF
*
60 CONTINUE
*
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 80,J = N,1,-1
IF (X(JX).NE.ZERO) THEN
IX = KX
DO 70,I = N,J + 1,-1
X(IX) = X(IX) + X(JX)*A(I,J)
IX = IX - INCX
70 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*A(J,J)
END IF
*
JX = JX - INCX
80 CONTINUE
END IF
*
END IF
*
ELSE
*
* Form x := A'*x.
*
IF (LSAME(UPLO,'U')) THEN
IF (INCX.EQ.1) THEN
DO 100,J = N,1,-1
IF (NOUNIT) X(J) = X(J)*A(J,J)
DO 90,I = J - 1,1,-1
X(J) = X(J) + A(I,J)*X(I)
90 CONTINUE
100 CONTINUE
*
ELSE
JX = KX + (N-1)*INCX
DO 120,J = N,1,-1
IX = JX
IF (NOUNIT) X(JX) = X(JX)*A(J,J)
DO 110,I = J - 1,1,-1
IX = IX - INCX
X(JX) = X(JX) + A(I,J)*X(IX)
110 CONTINUE
JX = JX - INCX
120 CONTINUE
END IF
*
ELSE
IF (INCX.EQ.1) THEN
DO 140,J = 1,N
IF (NOUNIT) X(J) = X(J)*A(J,J)
DO 130,I = J + 1,N
X(J) = X(J) + A(I,J)*X(I)
130 CONTINUE
140 CONTINUE
*
ELSE
JX = KX
DO 160,J = 1,N
IX = JX
IF (NOUNIT) X(JX) = X(JX)*A(J,J)
DO 150,I = J + 1,N
IX = IX + INCX
X(JX) = X(JX) + A(I,J)*X(IX)
150 CONTINUE
JX = JX + INCX
160 CONTINUE
END IF
*
END IF
*
END IF
*
RETURN
*
* End of STRMV .
*
END
SUBROUTINE STBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
CHARACTER *1 UPLO,TRANS,DIAG
INTEGER N,K,LDA,INCX
REAL A(LDA,*),X(*)
*
* Purpose
* =======
*
* STBMV performs one of the matrix-vector operations
*
* x := A*x, or x := A'*x,
*
* where x is n element vector and A is an n by n unit, or non-unit,
* upper or lower triangular band matrix, with ( k + 1 ) diagonals.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix is an upper or
* lower triangular matrix as follows:
*
* UPLO = 'U' A is an upper triangular matrix.
*
* UPLO = 'L' A is a lower triangular matrix.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the operation to be performed as
* follows:
*
* TRANS = 'N' x := A*x.
*
* TRANS = 'T' x := A'*x.
*
* TRANS = 'C' x := A'*x.
*
* Unchanged on exit.
*
* DIAG - CHARACTER*1.
* On entry, DIAG specifies whether or not A is unit
* triangular as follows:
*
* DIAG = 'U' A is assumed to be unit triangular.
*
* DIAG = 'N' A is not assumed to be unit
* triangular.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* K - INTEGER.
* On entry with UPLO = 'U', K specifies the number of
* super-diagonals of the matrix A.
* On entry with UPLO = 'L', K specifies the number of
* sub-diagonals of the matrix A.
* K must satisfy 0 .le. K.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U', the leading ( k + 1 )
* by n part of the array A must contain the upper triangular
* band part of the matrix of coefficients, supplied column by
* column, with the leading diagonal of the matrix in row
* ( k + 1 ) of the array, the first super-diagonal starting at
* position 2 in row k, and so on. The top left k by k triangle
* of the array A is not referenced.
* Before entry with UPLO = 'L', the leading ( k + 1 )
* by n part of the array A must contain the lower triangular
* band part of the matrix of coefficients, supplied column by
* column, with the leading diagonal of the matrix in row 1 of
* the array, the first sub-diagonal starting at position 1 in
* row 2, and so on. The bottom right k by k triangle of the
* array A is not referenced.
* Note that when DIAG = 'U' the elements of the array A
* corresponding to the diagonal elements of the matrix are not
* referenced, but are assumed to be unity.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the leading dimension of A as
* declared in the calling (sub) program. LDA must be at least
* ( k + 1 ).
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x. On exit, X is overwritten with the
* tranformed vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X.
* Unchanged on exit.
*
*
*
*
* Level 2 Blas routine.
*
* -- Written on 5-November-1985.
* Sven Hammarling, Nag Central Office.
C REVISED 860623
C REVISED YYMMDD
C BY R. J. HANSON, SANDIA NATIONAL LABS.
*
INTRINSIC MAX,MIN
LOGICAL NOUNIT
INTEGER I,IX,J,JX,KPLUS1,KX
INTEGER L
REAL ZERO
PARAMETER (ZERO=0.0E+0)
LOGICAL OK,LSAME
OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND.
. (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR.
. LSAME(TRANS,'C')) .AND. (LSAME(DIAG,'U') .OR.
. LSAME(DIAG,'N')) .AND. (N.GT.0) .AND. (K.GE.0) .AND.
. (LDA.GE. (K+1))
*
*
* Quick return if possible.
*
IF ( .NOT. OK) RETURN
NOUNIT = LSAME(DIAG,'N')
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
*
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through A.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x := A*x.
*
IF (LSAME(UPLO,'U')) THEN
KPLUS1 = K + 1
IF (INCX.EQ.1) THEN
DO 20,J = 1,N
IF (X(J).NE.ZERO) THEN
I = MAX(1,J-K)
DO 10,L = KPLUS1 + I - J,K
X(I) = X(I) + X(J)*A(L,J)
I = I + 1
10 CONTINUE
IF (NOUNIT) X(J) = X(J)*A(KPLUS1,J)
END IF
*
20 CONTINUE
*
ELSE
JX = KX
DO 40,J = 1,N
IF (X(JX).NE.ZERO) THEN
IX = KX
DO 30,L = 1 + MAX(KPLUS1-J,0),K
X(IX) = X(IX) + X(JX)*A(L,J)
IX = IX + INCX
30 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*A(KPLUS1,J)
END IF
*
JX = JX + INCX
IF (J.GT.K) KX = KX + INCX
40 CONTINUE
END IF
*
ELSE
IF (INCX.EQ.1) THEN
DO 60,J = N,1,-1
IF (X(J).NE.ZERO) THEN
I = MIN(N,J+K)
DO 50,L = 1 + I - J,2,-1
X(I) = X(I) + X(J)*A(L,J)
I = I - 1
50 CONTINUE
IF (NOUNIT) X(J) = X(J)*A(1,J)
END IF
*
60 CONTINUE
*
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 80,J = N,1,-1
IF (X(JX).NE.ZERO) THEN
IX = KX
DO 70,L = 1 + MIN(K,N-J),2,-1
X(IX) = X(IX) + X(JX)*A(L,J)
IX = IX - INCX
70 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*A(1,J)
END IF
*
JX = JX - INCX
IF ((N-J).GE.K) KX = KX - INCX
80 CONTINUE
END IF
*
END IF
*
ELSE
*
* Form x := A'*x.
*
IF (LSAME(UPLO,'U')) THEN
KPLUS1 = K + 1
IF (INCX.EQ.1) THEN
DO 100,J = N,1,-1
I = J
IF (NOUNIT) X(J) = X(J)*A(KPLUS1,J)
DO 90,L = K,1 + MAX(KPLUS1-J,0),-1
I = I - 1
X(J) = X(J) + A(L,J)*X(I)
90 CONTINUE
100 CONTINUE
*
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 120,J = N,1,-1
KX = KX - INCX
IX = KX
IF (NOUNIT) X(JX) = X(JX)*A(KPLUS1,J)
DO 110,L = K,1 + MAX(KPLUS1-J,0),-1
X(JX) = X(JX) + A(L,J)*X(IX)
IX = IX - INCX
110 CONTINUE
JX = JX - INCX
120 CONTINUE
END IF
*
ELSE
IF (INCX.EQ.1) THEN
DO 140,J = 1,N
I = J
IF (NOUNIT) X(J) = X(J)*A(1,J)
DO 130,L = 2,1 + MIN(K,N-J)
I = I + 1
X(J) = X(J) + A(L,J)*X(I)
130 CONTINUE
140 CONTINUE
*
ELSE
JX = KX
DO 160,J = 1,N
KX = KX + INCX
IX = KX
IF (NOUNIT) X(JX) = X(JX)*A(1,J)
DO 150,L = 2,1 + MIN(K,N-J)
X(JX) = X(JX) + A(L,J)*X(IX)
IX = IX + INCX
150 CONTINUE
JX = JX + INCX
160 CONTINUE
END IF
*
END IF
*
END IF
*
RETURN
*
* End of STBMV .
*
END
SUBROUTINE STPMV(UPLO,TRANS,DIAG,N,AP,X,INCX)
CHARACTER *1 UPLO,TRANS,DIAG
INTEGER N,INCX
REAL AP(*),X(*)
*
* Purpose
* =======
*
* STPMV performs one of the matrix-vector operations
*
* x := A*x, or x := A'*x,
*
* where x is n element vector and A is an n by n unit, or non-unit,
* upper or lower triangular matrix.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix is an upper or
* lower triangular matrix as follows:
*
* UPLO = 'U' A is an upper triangular matrix.
*
* UPLO = 'L' A is a lower triangular matrix.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the operation to be performed as
* follows:
*
* TRANS = 'N' x := A*x.
*
* TRANS = 'T' x := A'*x.
*
* TRANS = 'C' x := A'*x.
*
* Unchanged on exit.
*
* DIAG - CHARACTER*1.
* On entry, DIAG specifies whether or not A is unit
* triangular as follows:
*
* DIAG = 'U' A is assumed to be unit triangular.
*
* DIAG = 'N' A is not assumed to be unit
* triangular.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* AP - REAL array of DIMENSION at least
* ( ( n*( n + 1 ) )/2 ).
* Before entry with UPLO = 'U', the array AP must
* contain the upper triangular matrix packed sequentially,
* column by column, so that AP( 1 ) contains a( 1, 1 ),
* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
* respectively, and so on.
* Before entry with UPLO = 'L', the array AP must
* contain the lower triangular matrix packed sequentially,
* column by column, so that AP( 1 ) contains a( 1, 1 ),
* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
* respectively, and so on.
* Note that when DIAG = 'U', the diagonal elements of
* A are not referenced, but are assumed to be unity.
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x. On exit, X is overwritten with the
* tranformed vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X.
* Unchanged on exit.
*
*
* Note that UPLO, TRANS, DIAG and N must be such that the value of the
* LOGICAL variable OK in the following statement is true.
*
*
*
* Level 2 Blas routine.
*
* -- Written on 2-October-1985.
* Sven Hammarling, Nag Central Office.
C REVISED 860623
C REVISED YYMMDD
C BY R. J. HANSON, SANDIA NATIONAL LABS.
*
LOGICAL NOUNIT
INTEGER I,IX,J,JX,K,KK
INTEGER KX
REAL ZERO
PARAMETER (ZERO=0.0E+0)
LOGICAL OK,LSAME
OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND.
. (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR.
. LSAME(TRANS,'C')) .AND. (LSAME(DIAG,'U') .OR.
. LSAME(DIAG,'N')) .AND. (N.GT.0)
*
*
* Quick return if possible.
*
IF ( .NOT. OK) RETURN
NOUNIT = LSAME(DIAG,'N')
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
*
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of AP are
* accessed sequentially with one pass through AP.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x:= A*x.
*
IF (LSAME(UPLO,'U')) THEN
K = 1
IF (INCX.EQ.1) THEN
DO 20,J = 1,N
IF (X(J).NE.ZERO) THEN
DO 10,I = 1,J - 1
X(I) = X(I) + X(J)*AP(K)
K = K + 1
10 CONTINUE
IF (NOUNIT) X(J) = X(J)*AP(K)
K = K + 1
*
ELSE
K = K + J
END IF
*
20 CONTINUE
*
ELSE
JX = KX
DO 40,J = 1,N
IF (X(JX).NE.ZERO) THEN
IX = KX
KK = K
DO 30,K = KK,KK + J - 2
X(IX) = X(IX) + X(JX)*AP(K)
IX = IX + INCX
30 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*AP(K)
K = K + 1
*
ELSE
K = K + J
END IF
*
JX = JX + INCX
40 CONTINUE
END IF
*
ELSE
K = (N* (N+1))/2
IF (INCX.EQ.1) THEN
DO 60,J = N,1,-1
IF (X(J).NE.ZERO) THEN
DO 50,I = N,J + 1,-1
X(I) = X(I) + X(J)*AP(K)
K = K - 1
50 CONTINUE
IF (NOUNIT) X(J) = X(J)*AP(K)
K = K - 1
*
ELSE
K = K - (N-J+1)
END IF
*
60 CONTINUE
*
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 80,J = N,1,-1
IF (X(JX).NE.ZERO) THEN
IX = KX
KK = K
DO 70,K = KK,KK - (N- (J+1)),-1
X(IX) = X(IX) + X(JX)*AP(K)
IX = IX - INCX
70 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*AP(K)
K = K - 1
*
ELSE
K = K - (N-J+1)
END IF
*
JX = JX - INCX
80 CONTINUE
END IF
*
END IF
*
ELSE
*
* Form x := A'*x.
*
IF (LSAME(UPLO,'U')) THEN
K = (N* (N+1))/2
IF (INCX.EQ.1) THEN
DO 100,J = N,1,-1
IF (NOUNIT) X(J) = X(J)*AP(K)
K = K - 1
DO 90,I = J - 1,1,-1
X(J) = X(J) + AP(K)*X(I)
K = K - 1
90 CONTINUE
100 CONTINUE
*
ELSE
JX = KX + (N-1)*INCX
DO 120,J = N,1,-1
IX = JX
IF (NOUNIT) X(JX) = X(JX)*AP(K)
KK = K - 1
DO 110,K = KK,KK - J + 2,-1
IX = IX - INCX
X(JX) = X(JX) + AP(K)*X(IX)
110 CONTINUE
JX = JX - INCX
120 CONTINUE
END IF
*
ELSE
K = 1
IF (INCX.EQ.1) THEN
DO 140,J = 1,N
IF (NOUNIT) X(J) = X(J)*AP(K)
K = K + 1
DO 130,I = J + 1,N
X(J) = X(J) + AP(K)*X(I)
K = K + 1
130 CONTINUE
140 CONTINUE
*
ELSE
JX = KX
DO 160,J = 1,N
IX = JX
IF (NOUNIT) X(JX) = X(JX)*AP(K)
KK = K + 1
DO 150,K = KK,KK + N - (J+1)
IX = IX + INCX
X(JX) = X(JX) + AP(K)*X(IX)
150 CONTINUE
JX = JX + INCX
160 CONTINUE
END IF
*
END IF
*
END IF
*
RETURN
*
* End of STPMV .
*
END
SUBROUTINE STRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
CHARACTER *1 UPLO,TRANS,DIAG
INTEGER N,LDA,INCX
REAL A(LDA,*),X(*)
*
* Purpose
* =======
*
* STRSV solves one of the systems of equations
*
* A*x = b, or A'*x = b,
*
* where b and x are n element vectors and A is an n by n unit, or
* non-unit, upper or lower triangular matrix.
*
* No test for singularity or near-singularity is included in this
* routine. Such tests must be performed before calling this routine.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix is an upper or
* lower triangular matrix as follows:
*
* UPLO = 'U' A is an upper triangular matrix.
*
* UPLO = 'L' A is a lower triangular matrix.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the equations to be solved as
* follows:
*
* TRANS = 'N' A*x = b.
*
* TRANS = 'T' A'*x = b.
*
* TRANS = 'C' A'*x = b.
*
* Unchanged on exit.
*
* DIAG - CHARACTER*1.
* On entry, DIAG specifies whether or not A is unit
* triangular as follows:
*
* DIAG = 'U' A is assumed to be unit triangular.
*
* DIAG = 'N' A is not assumed to be unit
* triangular.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U', the leading n by n
* upper triangular part of the array A must contain the upper
* triangular matrix and the strictly lower triangular part of
* A is not referenced.
* Before entry with UPLO = 'L', the leading n by n
* lower triangular part of the array A must contain the lower
* triangular matrix and the strictly upper triangular part of
* A is not referenced.
* Note that when DIAG = 'U', the diagonal elements of
* A are not referenced either, but are assumed to be unity.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least max(n,1).
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element right-hand side vector b. On exit, X is overwritten
* with the solution vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X.
* Unchanged on exit.
*
*
*
*
* Level 2 Blas routine.
*
* -- Written on 30-September-1985.
* Sven Hammarling, Nag Central Office.
C REVISED 860623
C REVISED YYMMDD
C BY R. J. HANSON, SANDIA NATIONAL LABS.
*
LOGICAL NOUNIT
INTEGER I,IX,J,JX,KX
REAL ZERO
PARAMETER (ZERO=0.0E+0)
LOGICAL OK,LSAME
OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND.
. (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR.
. LSAME(TRANS,'C')) .AND. (LSAME(DIAG,'U') .OR.
. LSAME(DIAG,'N')) .AND. (N.GT.0) .AND. (LDA.GE.N)
*
*
* Quick return if possible.
*
IF ( .NOT. OK) RETURN
NOUNIT = LSAME(DIAG,'N')
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
*
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through A.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x := inv( A )*x.
*
IF (LSAME(UPLO,'U')) THEN
IF (INCX.EQ.1) THEN
DO 20,J = N,1,-1
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/A(J,J)
DO 10,I = J - 1,1,-1
X(I) = X(I) - X(J)*A(I,J)
10 CONTINUE
END IF
*
20 CONTINUE
*
ELSE
JX = KX + (N-1)*INCX
DO 40,J = N,1,-1
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/A(J,J)
IX = JX
DO 30,I = J - 1,1,-1
IX = IX - INCX
X(IX) = X(IX) - X(JX)*A(I,J)
30 CONTINUE
END IF
*
JX = JX - INCX
40 CONTINUE
END IF
*
ELSE
IF (INCX.EQ.1) THEN
DO 60,J = 1,N
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/A(J,J)
DO 50,I = J + 1,N
X(I) = X(I) - X(J)*A(I,J)
50 CONTINUE
END IF
*
60 CONTINUE
*
ELSE
JX = KX
DO 80,J = 1,N
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/A(J,J)
IX = JX
DO 70,I = J + 1,N
IX = IX + INCX
X(IX) = X(IX) - X(JX)*A(I,J)
70 CONTINUE
END IF
*
JX = JX + INCX
80 CONTINUE
END IF
*
END IF
*
ELSE
*
* Form x := inv( A' )*x.
*
IF (LSAME(UPLO,'U')) THEN
IF (INCX.EQ.1) THEN
DO 100,J = 1,N
DO 90,I = 1,J - 1
X(J) = X(J) - A(I,J)*X(I)
90 CONTINUE
IF (NOUNIT) X(J) = X(J)/A(J,J)
100 CONTINUE
*
ELSE
JX = KX
DO 120,J = 1,N
IX = KX
DO 110,I = 1,J - 1
X(JX) = X(JX) - A(I,J)*X(IX)
IX = IX + INCX
110 CONTINUE
IF (NOUNIT) X(JX) = X(JX)/A(J,J)
JX = JX + INCX
120 CONTINUE
END IF
*
ELSE
IF (INCX.EQ.1) THEN
DO 140,J = N,1,-1
DO 130,I = N,J + 1,-1
X(J) = X(J) - A(I,J)*X(I)
130 CONTINUE
IF (NOUNIT) X(J) = X(J)/A(J,J)
140 CONTINUE
*
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 160,J = N,1,-1
IX = KX
DO 150,I = N,J + 1,-1
X(JX) = X(JX) - A(I,J)*X(IX)
IX = IX - INCX
150 CONTINUE
IF (NOUNIT) X(JX) = X(JX)/A(J,J)
JX = JX - INCX
160 CONTINUE
END IF
*
END IF
*
END IF
*
RETURN
*
* End of STRSV .
*
END
SUBROUTINE STBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
CHARACTER *1 UPLO,TRANS,DIAG
INTEGER N,K,LDA,INCX
REAL A(LDA,*),X(*)
*
* Purpose
* =======
*
* STBSV solves one of the systems of equations
*
* A*x = b, or A'*x = b,
*
* where b and x are n element vectors and A is an n by n unit, or
* non-unit, upper or lower triangular band matrix, with ( k + 1 )
* diagonals.
*
* No test for singularity or near-singularity is included in this
* routine. Such tests must be performed before calling this routine.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix is an upper or
* lower triangular matrix as follows:
*
* UPLO = 'U' A is an upper triangular matrix.
*
* UPLO = 'L' A is a lower triangular matrix.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the equations to be solved as
* follows:
*
* TRANS = 'N' A*x = b.
*
* TRANS = 'T' A'*x = b.
*
* TRANS = 'C' A'*x = b.
*
* Unchanged on exit.
*
* DIAG - CHARACTER*1.
* On entry, DIAG specifies whether or not A is unit
* triangular as follows:
*
* DIAG = 'U' A is assumed to be unit triangular.
*
* DIAG = 'N' A is not assumed to be unit
* triangular.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* K - INTEGER.
* On entry with UPLO = 'U', K specifies the number of
* super-diagonals of the matrix A.
* On entry with UPLO = 'L', K specifies the number of
* sub-diagonals of the matrix A.
* K must satisfy 0 .le. K.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U', the leading ( k + 1 )
* by n part of the array A must contain the upper triangular
* band part of the matrix of coefficients, supplied column by
* column, with the leading diagonal of the matrix in row
* ( k + 1 ) of the array, the first super-diagonal starting at
* position 2 in row k, and so on. The top left k by k triangle
* of the array A is not referenced.
* Before entry with UPLO = 'L', the leading ( k + 1 )
* by n part of the array A must contain the lower triangular
* band part of the matrix of coefficients, supplied column by
* column, with the leading diagonal of the matrix in row 1 of
* the array, the first sub-diagonal starting at position 1 in
* row 2, and so on. The bottom right k by k triangle of the
* array A is not referenced.
* Note that when DIAG = 'U' the elements of the array A
* corresponding to the diagonal elements of the matrix are not
* referenced, but are assumed to be unity.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the leading dimension of A as
* declared in the calling (sub) program. LDA must be at least
* ( k + 1 ).
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element right-hand side vector b. On exit, X is overwritten
* with the solution vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X.
* Unchanged on exit.
*
*
*
*
*
* Level 2 Blas routine.
*
* -- Written on 7-November-1985.
* Sven Hammarling, Nag Central Office.
C REVISED 860623
C REVISED YYMMDD
C BY R. J. HANSON, SANDIA NATIONAL LABS.
*
INTRINSIC MAX,MIN
LOGICAL NOUNIT
INTEGER I,IX,J,JX,KPLUS1,KX
INTEGER L
REAL ZERO
PARAMETER (ZERO=0.0E+0)
LOGICAL OK,LSAME
OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND.
. (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR.
. LSAME(TRANS,'C')) .AND. (LSAME(DIAG,'U') .OR.
. LSAME(DIAG,'N')) .AND. (N.GT.0) .AND. (K.GE.0) .AND.
. (LDA.GE. (K+1))
*
*
* Quick return if possible.
*
IF ( .NOT. OK) RETURN
NOUNIT = LSAME(DIAG,'N')
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
*
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of A are
* accessed by sequentially with one pass through A.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x := inv( A )*x.
*
IF (LSAME(UPLO,'U')) THEN
KPLUS1 = K + 1
IF (INCX.EQ.1) THEN
DO 20,J = N,1,-1
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J)
I = J
DO 10,L = K,1 + MAX(KPLUS1-J,0),-1
I = I - 1
X(I) = X(I) - X(J)*A(L,J)
10 CONTINUE
END IF
*
20 CONTINUE
*
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 40,J = N,1,-1
KX = KX - INCX
IX = KX
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J)
DO 30 L = K,1 + MAX(KPLUS1-J,0),-1
X(IX) = X(IX) - X(JX)*A(L,J)
IX = IX - INCX
30 CONTINUE
END IF
*
JX = JX - INCX
40 CONTINUE
END IF
*
ELSE
IF (INCX.EQ.1) THEN
DO 60,J = 1,N
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/A(1,J)
I = J
DO 50,L = 2,1 + MIN(K,N-J)
I = I + 1
X(I) = X(I) - X(J)*A(L,J)
50 CONTINUE
END IF
*
60 CONTINUE
*
ELSE
JX = KX
DO 80,J = 1,N
KX = KX + INCX
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/A(1,J)
IX = KX
DO 70,L = 2,1 + MIN(K,N-J)
X(IX) = X(IX) - X(JX)*A(L,J)
IX = IX + INCX
70 CONTINUE
END IF
*
JX = JX + INCX
80 CONTINUE
END IF
*
END IF
*
ELSE
*
* Form x := inv( A')*x.
*
IF (LSAME(UPLO,'U')) THEN
KPLUS1 = K + 1
IF (INCX.EQ.1) THEN
DO 100,J = 1,N
I = MAX(1,J-K)
DO 90,L = KPLUS1 + I - J,K
X(J) = X(J) - A(L,J)*X(I)
I = I + 1
90 CONTINUE
IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J)
100 CONTINUE
*
ELSE
JX = KX
DO 120,J = 1,N
IX = KX
DO 110,L = 1 + MAX(KPLUS1-J,0),K
X(JX) = X(JX) - A(L,J)*X(IX)
IX = IX + INCX
110 CONTINUE
IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J)
JX = JX + INCX
IF (J.GT.K) KX = KX + INCX
120 CONTINUE
END IF
*
ELSE
IF (INCX.EQ.1) THEN
DO 140,J = N,1,-1
I = MIN(N,J+K)
DO 130,L = 1 + I - J,2,-1
X(J) = X(J) - A(L,J)*X(I)
I = I - 1
130 CONTINUE
IF (NOUNIT) X(J) = X(J)/A(1,J)
140 CONTINUE
*
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 160,J = N,1,-1
IX = KX
DO 150,L = 1 + MIN(K,N-J),2,-1
X(JX) = X(JX) - A(L,J)*X(IX)
IX = IX - INCX
150 CONTINUE
IF (NOUNIT) X(JX) = X(JX)/A(1,J)
JX = JX - INCX
IF ((N-J).GE.K) KX = KX - INCX
160 CONTINUE
END IF
*
END IF
*
END IF
*
RETURN
*
* End of STBSV .
*
END
SUBROUTINE STPSV(UPLO,TRANS,DIAG,N,AP,X,INCX)
CHARACTER *1 UPLO,TRANS,DIAG
INTEGER N,INCX
REAL AP(*),X(*)
*
* Purpose
* =======
*
* STPSV solves one of the systems of equations
*
* A*x = b, or A'*x = b,
*
* where b and x are n element vectors and A is an n by n unit, or
* non-unit, upper or lower triangular matrix.
*
* No test for singularity or near-singularity is included in this
* routine. Such tests must be performed before calling this routine.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the matrix is an upper or
* lower triangular matrix as follows:
*
* UPLO = 'U' A is an upper triangular matrix.
*
* UPLO = 'L' A is a lower triangular matrix.
*
* Unchanged on exit.
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the equations to be solved as
* follows:
*
* TRANS = 'N' A*x = b.
*
* TRANS = 'T' A'*x = b.
*
* TRANS = 'C' A'*x = b.
*
* Unchanged on exit.
*
* DIAG - CHARACTER*1.
* On entry, DIAG specifies whether or not A is unit
* triangular as follows:
*
* DIAG = 'U' A is assumed to be unit triangular.
*
* DIAG = 'N' A is not assumed to be unit
* triangular.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* AP - REAL array of DIMENSION at least
* ( ( n*( n + 1 ) )/2 ).
* Before entry with UPLO = 'U', the array AP must
* contain the upper triangular matrix packed sequentially,
* column by column, so that AP( 1 ) contains a( 1, 1 ),
* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
* respectively, and so on.
* Before entry with UPLO = 'L', the array AP must
* contain the lower triangular matrix packed sequentially,
* column by column, so that AP( 1 ) contains a( 1, 1 ),
* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
* respectively, and so on.
* Note that when DIAG = 'U', the diagonal elements of
* A are not referenced, but are assumed to be unity.
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element right-hand side vector b. On exit, X is overwritten
* with the solution vector x.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X.
* Unchanged on exit.
*
*
*
*
*
* Level 2 Blas routine.
*
* -- Written on 11-November-1985.
* Sven Hammarling, Nag Central Office.
C REVISED 860623
C REVISED YYMMDD
C BY R. J. HANSON, SANDIA NATIONAL LABS.
*
LOGICAL NOUNIT
INTEGER I,IX,J,JX,K,KK
INTEGER KX
REAL ZERO
PARAMETER (ZERO=0.0E+0)
LOGICAL OK,LSAME
OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND.
. (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR.
. LSAME(TRANS,'C')) .AND. (LSAME(DIAG,'U') .OR.
. LSAME(DIAG,'N')) .AND. (N.GT.0)
*
* Quick return if possible.
*
IF ( .NOT. OK) RETURN
NOUNIT = LSAME(DIAG,'N')
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
*
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of AP are
* accessed sequentially with one pass through AP.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x := inv( A )*x.
*
IF (LSAME(UPLO,'U')) THEN
K = (N* (N+1))/2
IF (INCX.EQ.1) THEN
DO 20,J = N,1,-1
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/AP(K)
K = K - 1
DO 10,I = J - 1,1,-1
X(I) = X(I) - X(J)*AP(K)
K = K - 1
10 CONTINUE
*
ELSE
K = K - J
END IF
*
20 CONTINUE
*
ELSE
JX = KX + (N-1)*INCX
DO 40,J = N,1,-1
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/AP(K)
IX = JX
KK = K - 1
DO 30,K = KK,KK - J + 2,-1
IX = IX - INCX
X(IX) = X(IX) - X(JX)*AP(K)
30 CONTINUE
*
ELSE
K = K - J
END IF
*
JX = JX - INCX
40 CONTINUE
END IF
*
ELSE
K = 1
IF (INCX.EQ.1) THEN
DO 60,J = 1,N
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/AP(K)
K = K + 1
DO 50,I = J + 1,N
X(I) = X(I) - X(J)*AP(K)
K = K + 1
50 CONTINUE
*
ELSE
K = K + N - J + 1
END IF
*
60 CONTINUE
*
ELSE
JX = KX
DO 80,J = 1,N
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/AP(K)
IX = JX
KK = K + 1
DO 70,K = KK,KK + N - (J+1)
IX = IX + INCX
X(IX) = X(IX) - X(JX)*AP(K)
70 CONTINUE
*
ELSE
K = K + N - J + 1
END IF
*
JX = JX + INCX
80 CONTINUE
END IF
*
END IF
*
ELSE
*
* Form x := inv( A' )*x.
*
IF (LSAME(UPLO,'U')) THEN
K = 1
IF (INCX.EQ.1) THEN
DO 100,J = 1,N
DO 90,I = 1,J - 1
X(J) = X(J) - AP(K)*X(I)
K = K + 1
90 CONTINUE
IF (NOUNIT) X(J) = X(J)/AP(K)
K = K + 1
100 CONTINUE
*
ELSE
JX = KX
DO 120,J = 1,N
IX = KX
KK = K
DO 110,K = KK,KK + J - 2
X(JX) = X(JX) - AP(K)*X(IX)
IX = IX + INCX
110 CONTINUE
IF (NOUNIT) X(JX) = X(JX)/AP(K)
K = K + 1
JX = JX + INCX
120 CONTINUE
END IF
*
ELSE
K = (N* (N+1))/2
IF (INCX.EQ.1) THEN
DO 140,J = N,1,-1
DO 130,I = N,J + 1,-1
X(J) = X(J) - AP(K)*X(I)
K = K - 1
130 CONTINUE
IF (NOUNIT) X(J) = X(J)/AP(K)
K = K - 1
140 CONTINUE
*
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 160,J = N,1,-1
IX = KX
KK = K
DO 150,K = KK,KK - (N- (J+1)),-1
X(JX) = X(JX) - AP(K)*X(IX)
IX = IX - INCX
150 CONTINUE
IF (NOUNIT) X(JX) = X(JX)/AP(K)
K = K - 1
JX = JX - INCX
160 CONTINUE
END IF
*
END IF
*
END IF
*
RETURN
*
* End of STPSV .
*
END
SUBROUTINE SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
INTEGER M,N,INCX,INCY,LDA
REAL ALPHA,X(*),Y(*),A(LDA,*)
*
* Purpose
* =======
*
* SGER performs the rank 1 operation
*
* A := alpha*x*y' + A,
*
* where alpha is a scalar, x is an m element vector, y is an n element
* vector and A is an m by n matrix.
*
* Parameters
* ==========
*
* M - INTEGER.
* On entry, M specifies the number of rows of the matrix A.
* M must be at least zero.
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the number of columns of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( m - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the m
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X.
* Unchanged on exit.
*
* Y - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCY ) ).
* Before entry, the incremented array Y must contain the n
* element vector y.
* Unchanged on exit.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry, the leading m by n part of the array A must
* contain the matrix of coefficients. On exit, A is
* overwritten by the updated matrix.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least max(1,m).
* Unchanged on exit.
*
*
*
* Level 2 Blas routine.
*
* -- Written on 30-August-1985.
* Sven Hammarling, Nag Central Office.
C REVISED 860623
C REVISED YYMMDD
C BY R. J. HANSON, SANDIA NATIONAL LABS.
*
INTEGER I,IX,J,JY,KX
REAL ZERO
PARAMETER (ZERO=0.0E+0)
REAL TEMP
LOGICAL OK
OK = (M.GT.0) .AND. (N.GT.0) .AND. (LDA.GE.M)
*
*
* Quick return if possible.
*
IF ( .NOT. OK .OR. (ALPHA.EQ.ZERO)) RETURN
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through A.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 20,J = 1,N
IF (Y(J).NE.ZERO) THEN
TEMP = ALPHA*Y(J)
DO 10,I = 1,M
A(I,J) = A(I,J) + X(I)*TEMP
10 CONTINUE
END IF
*
20 CONTINUE
*
ELSE
IF (INCX.GT.0) THEN
KX = 1
*
ELSE
KX = 1 - (M-1)*INCX
END IF
*
IF (INCY.GT.0) THEN
JY = 1
*
ELSE
JY = 1 - (N-1)*INCY
END IF
*
DO 40,J = 1,N
IF (Y(JY).NE.ZERO) THEN
TEMP = ALPHA*Y(JY)
IX = KX
DO 30,I = 1,M
A(I,J) = A(I,J) + X(IX)*TEMP
IX = IX + INCX
30 CONTINUE
END IF
*
JY = JY + INCY
40 CONTINUE
END IF
*
RETURN
*
* End of SGER .
*
END
SUBROUTINE SSYR(UPLO,N,ALPHA,X,INCX,A,LDA)
CHARACTER *1 UPLO
INTEGER N,INCX,LDA
REAL ALPHA,X(*),A(LDA,*)
*
* Purpose
* =======
*
* SSYR performs the symmetric rank 1 operation
*
* A := alpha*x*x' + A,
*
* where alpha is a real scalar, x is an n element vector and A is an
* n by n symmetric matrix.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the array A is to be referenced as
* follows:
*
* UPLO = 'U' Only the upper triangular part of A
* is to be referenced.
*
* UPLO = 'L' Only the lower triangular part of A
* is to be referenced.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U', the leading n by n
* upper triangular part of the array A must contain the upper
* triangular part of the symmetric matrix and the strictly
* lower triangular part of A is not referenced. On exit, the
* upper triangular part of the array A is overwritten by the
* upper triangular part of the updated matrix.
* Before entry with UPLO = 'L', the leading n by n
* lower triangular part of the array A must contain the lower
* triangular part of the symmetric matrix and the strictly
* upper triangular part of A is not referenced. On exit, the
* lower triangular part of the array A is overwritten by the
* lower triangular part of the updated matrix.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least max(1,n).
* Unchanged on exit.
*
*
*
*
*
* Level 2 Blas routine.
*
* -- Written on 27-September-1985.
* Sven Hammarling, Nag Central Office.
C REVISED 860623
C REVISED YYMMDD
C BY R. J. HANSON, SANDIA NATIONAL LABS.
*
INTEGER I,IX,J,JX,KX
REAL ZERO
PARAMETER (ZERO=0.0E+0)
REAL TEMP
LOGICAL OK,LSAME
OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. (N.GT.0) .AND.
. (LDA.GE.N)
*
* Quick return if possible.
*
IF ( .NOT. OK .OR. (ALPHA.EQ.ZERO)) RETURN
*
* Set the start point in X if the increment is not unity.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
*
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through the triangular part
* of A.
*
IF (LSAME(UPLO,'U')) THEN
*
* Form A when A is stored in upper triangle.
*
IF (INCX.EQ.1) THEN
DO 20,J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = ALPHA*X(J)
DO 10,I = 1,J
A(I,J) = A(I,J) + X(I)*TEMP
10 CONTINUE
END IF
*
20 CONTINUE
*
ELSE
JX = KX
DO 40,J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*X(JX)
IX = KX
DO 30,I = 1,J
A(I,J) = A(I,J) + X(IX)*TEMP
IX = IX + INCX
30 CONTINUE
END IF
*
JX = JX + INCX
40 CONTINUE
END IF
*
ELSE
*
* Form A when A is stored in lower triangle.
*
IF (INCX.EQ.1) THEN
DO 60,J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = ALPHA*X(J)
DO 50,I = J,N
A(I,J) = A(I,J) + X(I)*TEMP
50 CONTINUE
END IF
*
60 CONTINUE
*
ELSE
JX = KX
DO 80,J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*X(JX)
IX = JX
DO 70,I = J,N
A(I,J) = A(I,J) + X(IX)*TEMP
IX = IX + INCX
70 CONTINUE
END IF
*
JX = JX + INCX
80 CONTINUE
END IF
*
END IF
*
RETURN
*
* End of SSYR .
*
END
SUBROUTINE SSPR(UPLO,N,ALPHA,X,INCX,AP)
CHARACTER *1 UPLO
INTEGER N,INCX
REAL ALPHA,X(*),AP(*)
*
* Purpose
* =======
*
* SSPR performs the symmetric rank 1 operation
*
* A := alpha*x*x' + A,
*
* where alpha is a real scalar, x is an n element vector and A is an
* n by n symmetric matrix.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the matrix A is supplied in the packed
* array AP as follows:
*
* UPLO = 'U' The upper triangular part of A is
* supplied in AP.
*
* UPLO = 'L' The lower triangular part of A is
* supplied in AP.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X.
* Unchanged on exit.
*
* AP - REAL array of DIMENSION at least
* ( ( n*( n + 1 ) )/2 ).
* Before entry with UPLO = 'U', the array AP must
* contain the upper triangular part of the symmetric matrix
* packed sequentially, column by column, so that AP( 1 )
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
* and a( 2, 2 ) respectively, and so on. On exit, the array
* AP is overwritten by the upper triangular part of the
* updated matrix.
* Before entry with UPLO = 'L', the array AP must
* contain the lower triangular part of the symmetric matrix
* packed sequentially, column by column, so that AP( 1 )
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
* and a( 3, 1 ) respectively, and so on. On exit, the array
* AP is overwritten by the lower triangular part of the
* updated matrix.
*
*
*
*
* Level 2 Blas routine.
*
* -- Written on 30-September-1985.
* Sven Hammarling, Nag Central Office.
C REVISED 860623
C REVISED YYMMDD
C BY R. J. HANSON, SANDIA NATIONAL LABS.
*
INTEGER I,IX,J,JX,K,KK
INTEGER KX
REAL ZERO
PARAMETER (ZERO=0.0E+0)
REAL TEMP
LOGICAL OK,LSAME
OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. (N.GT.0)
*
* Quick return if possible.
*
IF ( .NOT. OK .OR. (ALPHA.EQ.ZERO)) RETURN
*
* Set the start point in X if the increment is not unity.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
*
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of the array AP
* are accessed sequentially with one pass through AP.
*
K = 1
IF (LSAME(UPLO,'U')) THEN
*
* Form A when upper triangle is stored in AP.
*
IF (INCX.EQ.1) THEN
DO 20,J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = ALPHA*X(J)
DO 10,I = 1,J
AP(K) = AP(K) + X(I)*TEMP
K = K + 1
10 CONTINUE
*
ELSE
K = K + J
END IF
*
20 CONTINUE
*
ELSE
JX = KX
DO 40,J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*X(JX)
IX = KX
KK = K
DO 30,K = KK,KK + J - 1
AP(K) = AP(K) + X(IX)*TEMP
IX = IX + INCX
30 CONTINUE
*
ELSE
K = K + J
END IF
*
JX = JX + INCX
40 CONTINUE
END IF
*
ELSE
*
* Form A when lower triangle is stored in AP.
*
IF (INCX.EQ.1) THEN
DO 60,J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = ALPHA*X(J)
DO 50,I = J,N
AP(K) = AP(K) + X(I)*TEMP
K = K + 1
50 CONTINUE
*
ELSE
K = K + N - J + 1
END IF
*
60 CONTINUE
*
ELSE
JX = KX
DO 80,J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*X(JX)
IX = JX
KK = K
DO 70,K = KK,KK + N - J
AP(K) = AP(K) + X(IX)*TEMP
IX = IX + INCX
70 CONTINUE
*
ELSE
K = K + N - J + 1
END IF
*
JX = JX + INCX
80 CONTINUE
END IF
*
END IF
*
RETURN
*
* End of SSPR .
*
END
SUBROUTINE SSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
CHARACTER *1 UPLO
INTEGER N,INCX,INCY,LDA
REAL ALPHA,X(*),Y(*),A(LDA,*)
*
* Purpose
* =======
*
* SSYR2 performs the symmetric rank 2 operation
*
* A := alpha*x*y' + alpha*y*x' + A,
*
* where alpha is a scalar, x and y are n element vectors and A is an n
* by n symmetric matrix.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the array A is to be referenced as
* follows:
*
* UPLO = 'U' Only the upper triangular part of A
* is to be referenced.
*
* UPLO = 'L' Only the lower triangular part of A
* is to be referenced.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X.
* Unchanged on exit.
*
* Y - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCY ) ).
* Before entry, the incremented array Y must contain the n
* element vector y.
* Unchanged on exit.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y.
* Unchanged on exit.
*
* A - REAL array of DIMENSION ( LDA, n ).
* Before entry with UPLO = 'U', the leading n by n
* upper triangular part of the array A must contain the upper
* triangular part of the symmetric matrix and the strictly
* lower triangular part of A is not referenced. On exit, the
* upper triangular part of the array A is overwritten by the
* upper triangular part of the updated matrix.
* Before entry with UPLO = 'L', the leading n by n
* lower triangular part of the array A must contain the lower
* triangular part of the symmetric matrix and the strictly
* upper triangular part of A is not referenced. On exit, the
* lower triangular part of the array A is overwritten by the
* lower triangular part of the updated matrix.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least max(1,n).
* Unchanged on exit.
*
*
*
*
*
* Level 2 Blas routine.
*
* -- Written on 27-September-1985.
* Sven Hammarling, Nag Central Office.
C REVISED 860623
C REVISED YYMMDD
C BY R. J. HANSON, SANDIA NATIONAL LABS.
*
INTEGER I,IX,IY,J,JX,JY
INTEGER KX,KY
REAL ZERO
PARAMETER (ZERO=0.0E+0)
REAL TEMP1,TEMP2
LOGICAL OK,LSAME
OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. (N.GT.0) .AND.
. (LDA.GE.N)
*
* Quick return if possible.
*
IF ( .NOT. OK .OR. (ALPHA.EQ.ZERO)) RETURN
*
* Set up the start points in X and Y if the increments are not both
* unity.
*
IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
IF (INCX.GT.0) THEN
KX = 1
*
ELSE
KX = 1 - (N-1)*INCX
END IF
*
IF (INCY.GT.0) THEN
KY = 1
*
ELSE
KY = 1 - (N-1)*INCY
END IF
*
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through the triangular part
* of A.
*
IF (LSAME(UPLO,'U')) THEN
*
* Form A when A is stored in the upper triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 20,J = 1,N
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(J)
TEMP2 = ALPHA*X(J)
DO 10,I = 1,J
A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
10 CONTINUE
END IF
*
20 CONTINUE
*
ELSE
JX = KX
JY = KY
DO 40,J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(JY)
TEMP2 = ALPHA*X(JX)
IX = KX
IY = KY
DO 30,I = 1,J
A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
IX = IX + INCX
IY = IY + INCY
30 CONTINUE
END IF
*
JX = JX + INCX
JY = JY + INCY
40 CONTINUE
END IF
*
ELSE
*
* Form A when A is stored in the upper triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60,J = 1,N
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(J)
TEMP2 = ALPHA*X(J)
DO 50,I = J,N
A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
50 CONTINUE
END IF
*
60 CONTINUE
*
ELSE
JX = KX
JY = KY
DO 80,J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(JY)
TEMP2 = ALPHA*X(JX)
IX = JX
IY = JY
DO 70,I = J,N
A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
END IF
*
JX = JX + INCX
JY = JY + INCY
80 CONTINUE
END IF
*
END IF
*
RETURN
*
* End of SSYR2 .
*
END
SUBROUTINE SSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP)
CHARACTER *1 UPLO
INTEGER N,INCX,INCY
REAL ALPHA,X(*),Y(*),AP(*)
*
* Purpose
* =======
*
* SSPR2 performs the symmetric rank 2 operation
*
* A := alpha*x*y' + alpha*y*x' + A,
*
* where alpha is a scalar, x and y are n element vectors and A is an
* n by n symmetric matrix.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the matrix A is supplied in the packed
* array AP as follows:
*
* UPLO = 'U' The upper triangular part of A is
* supplied in AP.
*
* UPLO = 'L' The lower triangular part of A is
* supplied in AP.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - REAL .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* X - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X.
* Unchanged on exit.
*
* Y - REAL array of dimension at least
* ( 1 + ( n - 1 )*abs( INCY ) ).
* Before entry, the incremented array Y must contain the n
* element vector y.
* Unchanged on exit.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y.
* Unchanged on exit.
*
* AP - REAL array of DIMENSION at least
* ( ( n*( n + 1 ) )/2 ).
* Before entry with UPLO = 'U', the array AP must
* contain the upper triangular part of the symmetric matrix
* packed sequentially, column by column, so that AP( 1 )
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
* and a( 2, 2 ) respectively, and so on. On exit, the array
* AP is overwritten by the upper triangular part of the
* updated matrix.
* Before entry with UPLO = 'L', the array AP must
* contain the lower triangular part of the symmetric matrix
* packed sequentially, column by column, so that AP( 1 )
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
* and a( 3, 1 ) respectively, and so on. On exit, the array
* AP is overwritten by the lower triangular part of the
* updated matrix.
*
*
*
*
*
* Level 2 Blas routine.
*
* -- Written on 30-September-1985.
* Sven Hammarling, Nag Central Office.
C REVISED 860623
C REVISED YYMMDD
C BY R. J. HANSON, SANDIA NATIONAL LABS.
*
INTEGER I,IX,IY,J,JX,JY
INTEGER K,KK,KX,KY
REAL ZERO
PARAMETER (ZERO=0.0E+0)
REAL TEMP1,TEMP2
LOGICAL OK,LSAME
OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. (N.GT.0)
*
* Quick return if possible.
*
IF ( .NOT. OK .OR. (ALPHA.EQ.ZERO)) RETURN
*
* Set up the start points in X and Y if the increments are not both
* unity.
*
IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
IF (INCX.GT.0) THEN
KX = 1
*
ELSE
KX = 1 - (N-1)*INCX
END IF
*
IF (INCY.GT.0) THEN
KY = 1
*
ELSE
KY = 1 - (N-1)*INCY
END IF
*
END IF
*
* Start the operations. In this version the elements of the array AP
* are accessed sequentially with one pass through AP.
*
K = 1
IF (LSAME(UPLO,'U')) THEN
*
* Form A when upper triangle is stored in AP.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 20,J = 1,N
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(J)
TEMP2 = ALPHA*X(J)
DO 10,I = 1,J
AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
K = K + 1
10 CONTINUE
*
ELSE
K = K + J
END IF
*
20 CONTINUE
*
ELSE
JX = KX
JY = KY
DO 40,J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(JY)
TEMP2 = ALPHA*X(JX)
IX = KX
IY = KY
KK = K
DO 30,K = KK,KK + J - 1
AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
IX = IX + INCX
IY = IY + INCY
30 CONTINUE
*
ELSE
K = K + J
END IF
*
JX = JX + INCX
JY = JY + INCY
40 CONTINUE
END IF
*
ELSE
*
* Form A when lower triangle is stored in AP.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60,J = 1,N
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(J)
TEMP2 = ALPHA*X(J)
DO 50,I = J,N
AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
K = K + 1
50 CONTINUE
*
ELSE
K = K + N - J + 1
END IF
*
60 CONTINUE
*
ELSE
JX = KX
JY = KY
DO 80,J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*Y(JY)
TEMP2 = ALPHA*X(JX)
IX = JX
IY = JY
KK = K
DO 70,K = KK,KK + N - J
AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
*
ELSE
K = K + N - J + 1
END IF
*
JX = JX + INCX
JY = JY + INCY
80 CONTINUE
END IF
*
END IF
*
RETURN
*
* End of SSPR2 .
*
END
* ======================================================================
* NIST Guide to Available Math Software.
* Fullsource for module ZDSCAL from package BLAS1.
* Retrieved from NETLIB on Mon Jun 15 14:48:38 1998.
* ======================================================================
subroutine zdscal(n,da,zx,incx)
c
c scales a vector by a constant.
c jack dongarra, 3/11/78.
c modified 3/93 to return if incx .le. 0.
c modified 12/3/93, array(1) declarations changed to array(*)
c
double complex zx(*)
double precision da
integer i,incx,ix,n
c
if( n.le.0 .or. incx.le.0 )return
if(incx.eq.1)go to 20
c
c code for increment not equal to 1
c
ix = 1
do 10 i = 1,n
zx(ix) = dcmplx(da,0.0d0)*zx(ix)
ix = ix + incx
10 continue
return
c
c code for increment equal to 1
c
20 do 30 i = 1,n
zx(i) = dcmplx(da,0.0d0)*zx(i)
30 continue
return
end
* ======================================================================
* NIST Guide to Available Math Software.
* Fullsource for module ZDOTC from package BLAS1.
* Retrieved from NETLIB on Mon Jun 15 15:01:53 1998.
* ======================================================================
double complex function zdotc(n,zx,incx,zy,incy)
c
c forms the dot product of a vector.
c jack dongarra, 3/11/78.
c modified 12/3/93, array(1) declarations changed to array(*)
c
double complex zx(*),zy(*),ztemp
integer i,incx,incy,ix,iy,n
ztemp = (0.0d0,0.0d0)
zdotc = (0.0d0,0.0d0)
if(n.le.0)return
if(incx.eq.1.and.incy.eq.1)go to 20
c
c code for unequal increments or equal increments
c not equal to 1
c
ix = 1
iy = 1
if(incx.lt.0)ix = (-n+1)*incx + 1
if(incy.lt.0)iy = (-n+1)*incy + 1
do 10 i = 1,n
ztemp = ztemp + dconjg(zx(ix))*zy(iy)
ix = ix + incx
iy = iy + incy
10 continue
zdotc = ztemp
return
c
c code for both increments equal to 1
c
20 do 30 i = 1,n
ztemp = ztemp + dconjg(zx(i))*zy(i)
30 continue
zdotc = ztemp
return
end
* ======================================================================
* NIST Guide to Available Math Software.
* Fullsource for module ZAXPY from package BLAS1.
* Retrieved from NETLIB on Mon Jun 15 15:02:56 1998.
* ======================================================================
subroutine zaxpy(n,za,zx,incx,zy,incy)
c
c constant times a vector plus a vector.
c jack dongarra, 3/11/78.
c modified 12/3/93, array(1) declarations changed to array(*)
c
double complex zx(*),zy(*),za
integer i,incx,incy,ix,iy,n
double precision dcabs1
if(n.le.0)return
if (dcabs1(za) .eq. 0.0d0) return
if (incx.eq.1.and.incy.eq.1)go to 20
c
c code for unequal increments or equal increments
c not equal to 1
c
ix = 1
iy = 1
if(incx.lt.0)ix = (-n+1)*incx + 1
if(incy.lt.0)iy = (-n+1)*incy + 1
do 10 i = 1,n
zy(iy) = zy(iy) + za*zx(ix)
ix = ix + incx
iy = iy + incy
10 continue
return
c
c code for both increments equal to 1
c
20 do 30 i = 1,n
zy(i) = zy(i) + za*zx(i)
30 continue
return
end
double precision function dcabs1(z)
double complex z,zz
double precision t(2)
equivalence (zz,t(1))
zz = z
dcabs1 = dabs(t(1)) + dabs(t(2))
return
end
* ======================================================================
* NIST Guide to Available Math Software.
* Fullsource for module ZHPR2 from package BLAS2.
* Retrieved from NETLIB on Mon Jun 15 15:03:49 1998.
* ======================================================================
SUBROUTINE ZHPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP )
* .. Scalar Arguments ..
COMPLEX*16 ALPHA
INTEGER INCX, INCY, N
CHARACTER*1 UPLO
* .. Array Arguments ..
COMPLEX*16 AP( * ), X( * ), Y( * )
* ..
*
* Purpose
* =======
*
* ZHPR2 performs the hermitian rank 2 operation
*
* A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A,
*
* where alpha is a scalar, x and y are n element vectors and A is an
* n by n hermitian matrix, supplied in packed form.
*
* Parameters
* ==========
*
* UPLO - CHARACTER*1.
* On entry, UPLO specifies whether the upper or lower
* triangular part of the matrix A is supplied in the packed
* array AP as follows:
*
* UPLO = 'U' or 'u' The upper triangular part of A is
* supplied in AP.
*
* UPLO = 'L' or 'l' The lower triangular part of A is
* supplied in AP.
*
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the order of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - COMPLEX*16 .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* X - COMPLEX*16 array of dimension at least
* ( 1 + ( n - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the n
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* Y - COMPLEX*16 array of dimension at least
* ( 1 + ( n - 1 )*abs( INCY ) ).
* Before entry, the incremented array Y must contain the n
* element vector y.
* Unchanged on exit.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y. INCY must not be zero.
* Unchanged on exit.
*
* AP - COMPLEX*16 array of DIMENSION at least
* ( ( n*( n + 1 ) )/2 ).
* Before entry with UPLO = 'U' or 'u', the array AP must
* contain the upper triangular part of the hermitian matrix
* packed sequentially, column by column, so that AP( 1 )
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
* and a( 2, 2 ) respectively, and so on. On exit, the array
* AP is overwritten by the upper triangular part of the
* updated matrix.
* Before entry with UPLO = 'L' or 'l', the array AP must
* contain the lower triangular part of the hermitian matrix
* packed sequentially, column by column, so that AP( 1 )
* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
* and a( 3, 1 ) respectively, and so on. On exit, the array
* AP is overwritten by the lower triangular part of the
* updated matrix.
* Note that the imaginary parts of the diagonal elements need
* not be set, they are assumed to be zero, and on exit they
* are set to zero.
*
*
* Level 2 Blas routine.
*
* -- Written on 22-October-1986.
* Jack Dongarra, Argonne National Lab.
* Jeremy Du Croz, Nag Central Office.
* Sven Hammarling, Nag Central Office.
* Richard Hanson, Sandia National Labs.
*
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
* .. Local Scalars ..
COMPLEX*16 TEMP1, TEMP2
INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* .. External Subroutines ..
EXTERNAL XERBLA
* .. Intrinsic Functions ..
INTRINSIC DCONJG, DBLE
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF ( .NOT.LSAME( UPLO, 'U' ).AND.
$ .NOT.LSAME( UPLO, 'L' ) )THEN
INFO = 1
ELSE IF( N.LT.0 )THEN
INFO = 2
ELSE IF( INCX.EQ.0 )THEN
INFO = 5
ELSE IF( INCY.EQ.0 )THEN
INFO = 7
END IF
IF( INFO.NE.0 )THEN
CALL XERBLA( 'ZHPR2 ', INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
$ RETURN
*
* Set up the start points in X and Y if the increments are not both
* unity.
*
IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN
IF( INCX.GT.0 )THEN
KX = 1
ELSE
KX = 1 - ( N - 1 )*INCX
END IF
IF( INCY.GT.0 )THEN
KY = 1
ELSE
KY = 1 - ( N - 1 )*INCY
END IF
JX = KX
JY = KY
END IF
*
* Start the operations. In this version the elements of the array AP
* are accessed sequentially with one pass through AP.
*
KK = 1
IF( LSAME( UPLO, 'U' ) )THEN
*
* Form A when upper triangle is stored in AP.
*
IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
DO 20, J = 1, N
IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN
TEMP1 = ALPHA*DCONJG( Y( J ) )
TEMP2 = DCONJG( ALPHA*X( J ) )
K = KK
DO 10, I = 1, J - 1
AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2
K = K + 1
10 CONTINUE
AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) +
$ DBLE( X( J )*TEMP1 + Y( J )*TEMP2 )
ELSE
AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) )
END IF
KK = KK + J
20 CONTINUE
ELSE
DO 40, J = 1, N
IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN
TEMP1 = ALPHA*DCONJG( Y( JY ) )
TEMP2 = DCONJG( ALPHA*X( JX ) )
IX = KX
IY = KY
DO 30, K = KK, KK + J - 2
AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2
IX = IX + INCX
IY = IY + INCY
30 CONTINUE
AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) +
$ DBLE( X( JX )*TEMP1 +
$ Y( JY )*TEMP2 )
ELSE
AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) )
END IF
JX = JX + INCX
JY = JY + INCY
KK = KK + J
40 CONTINUE
END IF
ELSE
*
* Form A when lower triangle is stored in AP.
*
IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
DO 60, J = 1, N
IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN
TEMP1 = ALPHA*DCONJG( Y( J ) )
TEMP2 = DCONJG( ALPHA*X( J ) )
AP( KK ) = DBLE( AP( KK ) ) +
$ DBLE( X( J )*TEMP1 + Y( J )*TEMP2 )
K = KK + 1
DO 50, I = J + 1, N
AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2
K = K + 1
50 CONTINUE
ELSE
AP( KK ) = DBLE( AP( KK ) )
END IF
KK = KK + N - J + 1
60 CONTINUE
ELSE
DO 80, J = 1, N
IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN
TEMP1 = ALPHA*DCONJG( Y( JY ) )
TEMP2 = DCONJG( ALPHA*X( JX ) )
AP( KK ) = DBLE( AP( KK ) ) +
$ DBLE( X( JX )*TEMP1 + Y( JY )*TEMP2 )
IX = JX
IY = JY
DO 70, K = KK + 1, KK + N - J
IX = IX + INCX
IY = IY + INCY
AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2
70 CONTINUE
ELSE
AP( KK ) = DBLE( AP( KK ) )
END IF
JX = JX + INCX
JY = JY + INCY
KK = KK + N - J + 1
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of ZHPR2 .
*
END
* ======================================================================
* NIST Guide to Available Math Software.
* Source for module ZGEMV from package BLAS2.
* Retrieved from NETLIB on Mon Jun 15 15:22:37 1998.
* ======================================================================
SUBROUTINE ZGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
$ BETA, Y, INCY )
* .. Scalar Arguments ..
COMPLEX*16 ALPHA, BETA
INTEGER INCX, INCY, LDA, M, N
CHARACTER*1 TRANS
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), X( * ), Y( * )
* ..
*
* Purpose
* =======
*
* ZGEMV performs one of the matrix-vector operations
*
* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or
*
* y := alpha*conjg( A' )*x + beta*y,
*
* where alpha and beta are scalars, x and y are vectors and A is an
* m by n matrix.
*
* Parameters
* ==========
*
* TRANS - CHARACTER*1.
* On entry, TRANS specifies the operation to be performed as
* follows:
*
* TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
*
* TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
*
* TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y.
*
* Unchanged on exit.
*
* M - INTEGER.
* On entry, M specifies the number of rows of the matrix A.
* M must be at least zero.
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the number of columns of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - COMPLEX*16 .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* A - COMPLEX*16 array of DIMENSION ( LDA, n ).
* Before entry, the leading m by n part of the array A must
* contain the matrix of coefficients.
* Unchanged on exit.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least
* max( 1, m ).
* Unchanged on exit.
*
* X - COMPLEX*16 array of DIMENSION at least
* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
* and at least
* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
* Before entry, the incremented array X must contain the
* vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* BETA - COMPLEX*16 .
* On entry, BETA specifies the scalar beta. When BETA is
* supplied as zero then Y need not be set on input.
* Unchanged on exit.
*
* Y - COMPLEX*16 array of DIMENSION at least
* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
* and at least
* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
* Before entry with BETA non-zero, the incremented array Y
* must contain the vector y. On exit, Y is overwritten by the
* updated vector y.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y. INCY must not be zero.
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- Written on 22-October-1986.
* Jack Dongarra, Argonne National Lab.
* Jeremy Du Croz, Nag Central Office.
* Sven Hammarling, Nag Central Office.
* Richard Hanson, Sandia National Labs.
*
*
* .. Parameters ..
COMPLEX*16 ONE
PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) )
COMPLEX*16 ZERO
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
* .. Local Scalars ..
COMPLEX*16 TEMP
INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY
LOGICAL NOCONJ
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* .. External Subroutines ..
EXTERNAL XERBLA
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF ( .NOT.LSAME( TRANS, 'N' ).AND.
$ .NOT.LSAME( TRANS, 'T' ).AND.
$ .NOT.LSAME( TRANS, 'C' ) )THEN
INFO = 1
ELSE IF( M.LT.0 )THEN
INFO = 2
ELSE IF( N.LT.0 )THEN
INFO = 3
ELSE IF( LDA.LT.MAX( 1, M ) )THEN
INFO = 6
ELSE IF( INCX.EQ.0 )THEN
INFO = 8
ELSE IF( INCY.EQ.0 )THEN
INFO = 11
END IF
IF( INFO.NE.0 )THEN
CALL XERBLA( 'ZGEMV ', INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
$ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
$ RETURN
*
NOCONJ = LSAME( TRANS, 'T' )
*
* Set LENX and LENY, the lengths of the vectors x and y, and set
* up the start points in X and Y.
*
IF( LSAME( TRANS, 'N' ) )THEN
LENX = N
LENY = M
ELSE
LENX = M
LENY = N
END IF
IF( INCX.GT.0 )THEN
KX = 1
ELSE
KX = 1 - ( LENX - 1 )*INCX
END IF
IF( INCY.GT.0 )THEN
KY = 1
ELSE
KY = 1 - ( LENY - 1 )*INCY
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through A.
*
* First form y := beta*y.
*
IF( BETA.NE.ONE )THEN
IF( INCY.EQ.1 )THEN
IF( BETA.EQ.ZERO )THEN
DO 10, I = 1, LENY
Y( I ) = ZERO
10 CONTINUE
ELSE
DO 20, I = 1, LENY
Y( I ) = BETA*Y( I )
20 CONTINUE
END IF
ELSE
IY = KY
IF( BETA.EQ.ZERO )THEN
DO 30, I = 1, LENY
Y( IY ) = ZERO
IY = IY + INCY
30 CONTINUE
ELSE
DO 40, I = 1, LENY
Y( IY ) = BETA*Y( IY )
IY = IY + INCY
40 CONTINUE
END IF
END IF
END IF
IF( ALPHA.EQ.ZERO )
$ RETURN
IF( LSAME( TRANS, 'N' ) )THEN
*
* Form y := alpha*A*x + y.
*
JX = KX
IF( INCY.EQ.1 )THEN
DO 60, J = 1, N
IF( X( JX ).NE.ZERO )THEN
TEMP = ALPHA*X( JX )
DO 50, I = 1, M
Y( I ) = Y( I ) + TEMP*A( I, J )
50 CONTINUE
END IF
JX = JX + INCX
60 CONTINUE
ELSE
DO 80, J = 1, N
IF( X( JX ).NE.ZERO )THEN
TEMP = ALPHA*X( JX )
IY = KY
DO 70, I = 1, M
Y( IY ) = Y( IY ) + TEMP*A( I, J )
IY = IY + INCY
70 CONTINUE
END IF
JX = JX + INCX
80 CONTINUE
END IF
ELSE
*
* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y.
*
JY = KY
IF( INCX.EQ.1 )THEN
DO 110, J = 1, N
TEMP = ZERO
IF( NOCONJ )THEN
DO 90, I = 1, M
TEMP = TEMP + A( I, J )*X( I )
90 CONTINUE
ELSE
DO 100, I = 1, M
TEMP = TEMP + DCONJG( A( I, J ) )*X( I )
100 CONTINUE
END IF
Y( JY ) = Y( JY ) + ALPHA*TEMP
JY = JY + INCY
110 CONTINUE
ELSE
DO 140, J = 1, N
TEMP = ZERO
IX = KX
IF( NOCONJ )THEN
DO 120, I = 1, M
TEMP = TEMP + A( I, J )*X( IX )
IX = IX + INCX
120 CONTINUE
ELSE
DO 130, I = 1, M
TEMP = TEMP + DCONJG( A( I, J ) )*X( IX )
IX = IX + INCX
130 CONTINUE
END IF
Y( JY ) = Y( JY ) + ALPHA*TEMP
JY = JY + INCY
140 CONTINUE
END IF
END IF
*
RETURN
*
* End of ZGEMV .
*
END
* ======================================================================
* NIST Guide to Available Math Software.
* Source for module ZGERC from package BLAS2.
* Retrieved from NETLIB on Mon Jun 15 15:24:20 1998.
* ======================================================================
SUBROUTINE ZGERC ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
* .. Scalar Arguments ..
COMPLEX*16 ALPHA
INTEGER INCX, INCY, LDA, M, N
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), X( * ), Y( * )
* ..
*
* Purpose
* =======
*
* ZGERC performs the rank 1 operation
*
* A := alpha*x*conjg( y' ) + A,
*
* where alpha is a scalar, x is an m element vector, y is an n element
* vector and A is an m by n matrix.
*
* Parameters
* ==========
*
* M - INTEGER.
* On entry, M specifies the number of rows of the matrix A.
* M must be at least zero.
* Unchanged on exit.
*
* N - INTEGER.
* On entry, N specifies the number of columns of the matrix A.
* N must be at least zero.
* Unchanged on exit.
*
* ALPHA - COMPLEX*16 .
* On entry, ALPHA specifies the scalar alpha.
* Unchanged on exit.
*
* X - COMPLEX*16 array of dimension at least
* ( 1 + ( m - 1 )*abs( INCX ) ).
* Before entry, the incremented array X must contain the m
* element vector x.
* Unchanged on exit.
*
* INCX - INTEGER.
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
* Unchanged on exit.
*
* Y - COMPLEX*16 array of dimension at least
* ( 1 + ( n - 1 )*abs( INCY ) ).
* Before entry, the incremented array Y must contain the n
* element vector y.
* Unchanged on exit.
*
* INCY - INTEGER.
* On entry, INCY specifies the increment for the elements of
* Y. INCY must not be zero.
* Unchanged on exit.
*
* A - COMPLEX*16 array of DIMENSION ( LDA, n ).
* Before entry, the leading m by n part of the array A must
* contain the matrix of coefficients. On exit, A is
* overwritten by the updated matrix.
*
* LDA - INTEGER.
* On entry, LDA specifies the first dimension of A as declared
* in the calling (sub) program. LDA must be at least
* max( 1, m ).
* Unchanged on exit.
*
*
* Level 2 Blas routine.
*
* -- Written on 22-October-1986.
* Jack Dongarra, Argonne National Lab.
* Jeremy Du Croz, Nag Central Office.
* Sven Hammarling, Nag Central Office.
* Richard Hanson, Sandia National Labs.
*
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
* .. Local Scalars ..
COMPLEX*16 TEMP
INTEGER I, INFO, IX, J, JY, KX
* .. External Subroutines ..
EXTERNAL XERBLA
* .. Intrinsic Functions ..
INTRINSIC DCONJG, MAX
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF ( M.LT.0 )THEN
INFO = 1
ELSE IF( N.LT.0 )THEN
INFO = 2
ELSE IF( INCX.EQ.0 )THEN
INFO = 5
ELSE IF( INCY.EQ.0 )THEN
INFO = 7
ELSE IF( LDA.LT.MAX( 1, M ) )THEN
INFO = 9
END IF
IF( INFO.NE.0 )THEN
CALL XERBLA( 'ZGERC ', INFO )
RETURN
END IF
*
* Quick return if possible.
*
IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
$ RETURN
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through A.
*
IF( INCY.GT.0 )THEN
JY = 1
ELSE
JY = 1 - ( N - 1 )*INCY
END IF
IF( INCX.EQ.1 )THEN
DO 20, J = 1, N
IF( Y( JY ).NE.ZERO )THEN
TEMP = ALPHA*DCONJG( Y( JY ) )
DO 10, I = 1, M
A( I, J ) = A( I, J ) + X( I )*TEMP
10 CONTINUE
END IF
JY = JY + INCY
20 CONTINUE
ELSE
IF( INCX.GT.0 )THEN
KX = 1
ELSE
KX = 1 - ( M - 1 )*INCX
END IF
DO 40, J = 1, N
IF( Y( JY ).NE.ZERO )THEN
TEMP = ALPHA*DCONJG( Y( JY ) )
IX = KX
DO 30, I = 1, M
A( I, J ) = A( I, J ) + X( IX )*TEMP
IX = IX + INCX
30 CONTINUE
END IF
JY = JY + INCY
40 CONTINUE
END IF
*
RETURN
*
* End of ZGERC .
*
END
* ======================================================================
* NIST Guide to Available Math Software.
* Source for module DZNRM2 from package BLAS1.
* Retrieved from NETLIB on Mon Jun 15 15:24:54 1998.
* ======================================================================
DOUBLE PRECISION FUNCTION DZNRM2( N, X, INCX )
* .. Scalar Arguments ..
INTEGER INCX, N
* .. Array Arguments ..
COMPLEX*16 X( * )
* ..
*
* DZNRM2 returns the euclidean norm of a vector via the function
* name, so that
*
* DZNRM2 := sqrt( conjg( x' )*x )
*
*
*
* -- This version written on 25-October-1982.
* Modified on 14-October-1993 to inline the call to ZLASSQ.
* Sven Hammarling, Nag Ltd.
*
*
* .. Parameters ..
DOUBLE PRECISION ONE , ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* .. Local Scalars ..
INTEGER IX
DOUBLE PRECISION NORM, SCALE, SSQ, TEMP
* .. Intrinsic Functions ..
INTRINSIC ABS, DIMAG, DBLE, SQRT
* ..
* .. Executable Statements ..
IF( N.LT.1 .OR. INCX.LT.1 )THEN
NORM = ZERO
ELSE
SCALE = ZERO
SSQ = ONE
* The following loop is equivalent to this call to the LAPACK
* auxiliary routine:
* CALL ZLASSQ( N, X, INCX, SCALE, SSQ )
*
DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX
IF( DBLE( X( IX ) ).NE.ZERO )THEN
TEMP = ABS( DBLE( X( IX ) ) )
IF( SCALE.LT.TEMP )THEN
SSQ = ONE + SSQ*( SCALE/TEMP )**2
SCALE = TEMP
ELSE
SSQ = SSQ + ( TEMP/SCALE )**2
END IF
END IF
IF( DIMAG( X( IX ) ).NE.ZERO )THEN
TEMP = ABS( DIMAG( X( IX ) ) )
IF( SCALE.LT.TEMP )THEN
SSQ = ONE + SSQ*( SCALE/TEMP )**2
SCALE = TEMP
ELSE
SSQ = SSQ + ( TEMP/SCALE )**2
END IF
END IF
10 CONTINUE
NORM = SCALE * SQRT( SSQ )
END IF
*
DZNRM2 = NORM
RETURN
*
* End of DZNRM2.
*
END
* ======================================================================
* NIST Guide to Available Math Software.
* Source for module ZSCAL from package BLAS1.
* Retrieved from NETLIB on Mon Jun 15 15:25:27 1998.
* ======================================================================
subroutine zscal(n,za,zx,incx)
c
c scales a vector by a constant.
c jack dongarra, 3/11/78.
c modified 3/93 to return if incx .le. 0.
c modified 12/3/93, array(1) declarations changed to array(*)
c
double complex za,zx(*)
integer i,incx,ix,n
c
if( n.le.0 .or. incx.le.0 )return
if(incx.eq.1)go to 20
c
c code for increment not equal to 1
c
ix = 1
do 10 i = 1,n
zx(ix) = za*zx(ix)
ix = ix + incx
10 continue
return
c
c code for increment equal to 1
c
20 do 30 i = 1,n
zx(i) = za*zx(i)
30 continue
return
end
* ======================================================================
* NIST Guide to Available Math Software.
* Source for module ZSWAP from package BLAS1.
* Retrieved from NETLIB on Mon Jun 15 15:25:56 1998.
* ======================================================================
subroutine zswap (n,zx,incx,zy,incy)
c
c interchanges two vectors.
c jack dongarra, 3/11/78.
c modified 12/3/93, array(1) declarations changed to array(*)
c
double complex zx(*),zy(*),ztemp
integer i,incx,incy,ix,iy,n
c
if(n.le.0)return
if(incx.eq.1.and.incy.eq.1)go to 20
c
c code for unequal increments or equal increments not equal
c to 1
c
ix = 1
iy = 1
if(incx.lt.0)ix = (-n+1)*incx + 1
if(incy.lt.0)iy = (-n+1)*incy + 1
do 10 i = 1,n
ztemp = zx(ix)
zx(ix) = zy(iy)
zy(iy) = ztemp
ix = ix + incx
iy = iy + incy
10 continue
return
c
c code for both increments equal to 1
20 do 30 i = 1,n
ztemp = zx(i)
zx(i) = zy(i)
zy(i) = ztemp
30 continue
return
end