1
SUBROUTINE ZHER ( UPLO, N, ALPHA, X, INCX, A, LDA )
2
* .. Scalar Arguments ..
6
* .. Array Arguments ..
7
COMPLEX*16 A( LDA, * ), X( * )
13
* ZHER performs the hermitian rank 1 operation
15
* A := alpha*x*conjg( x' ) + A,
17
* where alpha is a real scalar, x is an n element vector and A is an
18
* n by n hermitian matrix.
24
* On entry, UPLO specifies whether the upper or lower
25
* triangular part of the array A is to be referenced as
28
* UPLO = 'U' or 'u' Only the upper triangular part of A
29
* is to be referenced.
31
* UPLO = 'L' or 'l' Only the lower triangular part of A
32
* is to be referenced.
37
* On entry, N specifies the order of the matrix A.
38
* N must be at least zero.
41
* ALPHA - DOUBLE PRECISION.
42
* On entry, ALPHA specifies the scalar alpha.
45
* X - COMPLEX*16 array of dimension at least
46
* ( 1 + ( n - 1 )*abs( INCX ) ).
47
* Before entry, the incremented array X must contain the n
52
* On entry, INCX specifies the increment for the elements of
53
* X. INCX must not be zero.
56
* A - COMPLEX*16 array of DIMENSION ( LDA, n ).
57
* Before entry with UPLO = 'U' or 'u', the leading n by n
58
* upper triangular part of the array A must contain the upper
59
* triangular part of the hermitian matrix and the strictly
60
* lower triangular part of A is not referenced. On exit, the
61
* upper triangular part of the array A is overwritten by the
62
* upper triangular part of the updated matrix.
63
* Before entry with UPLO = 'L' or 'l', the leading n by n
64
* lower triangular part of the array A must contain the lower
65
* triangular part of the hermitian matrix and the strictly
66
* upper triangular part of A is not referenced. On exit, the
67
* lower triangular part of the array A is overwritten by the
68
* lower triangular part of the updated matrix.
69
* Note that the imaginary parts of the diagonal elements need
70
* not be set, they are assumed to be zero, and on exit they
74
* On entry, LDA specifies the first dimension of A as declared
75
* in the calling (sub) program. LDA must be at least
80
* Level 2 Blas routine.
82
* -- Written on 22-October-1986.
83
* Jack Dongarra, Argonne National Lab.
84
* Jeremy Du Croz, Nag Central Office.
85
* Sven Hammarling, Nag Central Office.
86
* Richard Hanson, Sandia National Labs.
91
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
94
INTEGER I, INFO, IX, J, JX, KX
95
* .. External Functions ..
98
* .. External Subroutines ..
100
* .. Intrinsic Functions ..
101
INTRINSIC DCONJG, MAX, DBLE
103
* .. Executable Statements ..
105
* Test the input parameters.
108
IF ( .NOT.LSAME( UPLO, 'U' ).AND.
109
$ .NOT.LSAME( UPLO, 'L' ) )THEN
111
ELSE IF( N.LT.0 )THEN
113
ELSE IF( INCX.EQ.0 )THEN
115
ELSE IF( LDA.LT.MAX( 1, N ) )THEN
119
CALL XERBLA( 'ZHER ', INFO )
123
* Quick return if possible.
125
IF( ( N.EQ.0 ).OR.( ALPHA.EQ.DBLE( ZERO ) ) )
128
* Set the start point in X if the increment is not unity.
131
KX = 1 - ( N - 1 )*INCX
132
ELSE IF( INCX.NE.1 )THEN
136
* Start the operations. In this version the elements of A are
137
* accessed sequentially with one pass through the triangular part
140
IF( LSAME( UPLO, 'U' ) )THEN
142
* Form A when A is stored in upper triangle.
146
IF( X( J ).NE.ZERO )THEN
147
TEMP = ALPHA*DCONJG( X( J ) )
149
A( I, J ) = A( I, J ) + X( I )*TEMP
151
A( J, J ) = DBLE( A( J, J ) ) + DBLE( X( J )*TEMP )
153
A( J, J ) = DBLE( A( J, J ) )
159
IF( X( JX ).NE.ZERO )THEN
160
TEMP = ALPHA*DCONJG( X( JX ) )
163
A( I, J ) = A( I, J ) + X( IX )*TEMP
166
A( J, J ) = DBLE( A( J, J ) ) + DBLE( X( JX )*TEMP )
168
A( J, J ) = DBLE( A( J, J ) )
175
* Form A when A is stored in lower triangle.
179
IF( X( J ).NE.ZERO )THEN
180
TEMP = ALPHA*DCONJG( X( J ) )
181
A( J, J ) = DBLE( A( J, J ) ) + DBLE( TEMP*X( J ) )
183
A( I, J ) = A( I, J ) + X( I )*TEMP
186
A( J, J ) = DBLE( A( J, J ) )
192
IF( X( JX ).NE.ZERO )THEN
193
TEMP = ALPHA*DCONJG( X( JX ) )
194
A( J, J ) = DBLE( A( J, J ) ) + DBLE( TEMP*X( JX ) )
198
A( I, J ) = A( I, J ) + X( IX )*TEMP
201
A( J, J ) = DBLE( A( J, J ) )