101 SUBROUTINE claghe( N, K, D, A, LDA, ISEED, WORK, INFO )
108 INTEGER INFO, K, LDA, N
113 COMPLEX A( LDA, * ), WORK( * )
119 COMPLEX ZERO, ONE, HALF
120 parameter( zero = ( 0.0e+0, 0.0e+0 ),
121 $ one = ( 1.0e+0, 0.0e+0 ),
122 $ half = ( 0.5e+0, 0.0e+0 ) )
127 COMPLEX ALPHA, TAU, WA, WB
136 EXTERNAL scnrm2, cdotc
139 INTRINSIC abs, conjg, max, real
148 ELSE IF( k.LT.0 .OR. k.GT.n-1 )
THEN
150 ELSE IF( lda.LT.max( 1, n ) )
THEN
154 CALL xerbla(
'CLAGHE', -info )
171 DO 40 i = n - 1, 1, -1
175 CALL clarnv( 3, iseed, n-i+1, work )
176 wn = scnrm2( n-i+1, work, 1 )
177 wa = ( wn / abs( work( 1 ) ) )*work( 1 )
178 IF( wn.EQ.zero )
THEN
182 CALL cscal( n-i, one / wb, work( 2 ), 1 )
184 tau = real( wb / wa )
192 CALL chemv(
'Lower', n-i+1, tau, a( i, i ), lda, work, 1, zero,
197 alpha = -half*tau*cdotc( n-i+1, work( n+1 ), 1, work, 1 )
198 CALL caxpy( n-i+1, alpha, work, 1, work( n+1 ), 1 )
202 CALL cher2(
'Lower', n-i+1, -one, work, 1, work( n+1 ), 1,
208 DO 60 i = 1, n - 1 - k
212 wn = scnrm2( n-k-i+1, a( k+i, i ), 1 )
213 wa = ( wn / abs( a( k+i, i ) ) )*a( k+i, i )
214 IF( wn.EQ.zero )
THEN
217 wb = a( k+i, i ) + wa
218 CALL cscal( n-k-i, one / wb, a( k+i+1, i ), 1 )
220 tau = real( wb / wa )
225 CALL cgemv(
'Conjugate transpose', n-k-i+1, k-1, one,
226 $ a( k+i, i+1 ), lda, a( k+i, i ), 1, zero, work, 1 )
227 CALL cgerc( n-k-i+1, k-1, -tau, a( k+i, i ), 1, work, 1,
228 $ a( k+i, i+1 ), lda )
234 CALL chemv(
'Lower', n-k-i+1, tau, a( k+i, k+i ), lda,
235 $ a( k+i, i ), 1, zero, work, 1 )
239 alpha = -half*tau*cdotc( n-k-i+1, work, 1, a( k+i, i ), 1 )
240 CALL caxpy( n-k-i+1, alpha, a( k+i, i ), 1, work, 1 )
244 CALL cher2(
'Lower', n-k-i+1, -one, a( k+i, i ), 1, work, 1,
245 $ a( k+i, k+i ), lda )
248 DO 50 j = k + i + 1, n
257 a( j, i ) = conjg( a( i, j ) )
subroutine xerbla(srname, info)
subroutine claghe(n, k, d, a, lda, iseed, work, info)
CLAGHE
subroutine caxpy(n, ca, cx, incx, cy, incy)
CAXPY
subroutine cgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
CGEMV
subroutine cgerc(m, n, alpha, x, incx, y, incy, a, lda)
CGERC
subroutine chemv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
CHEMV
subroutine cher2(uplo, n, alpha, x, incx, y, incy, a, lda)
CHER2
subroutine clarnv(idist, iseed, n, x)
CLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine cscal(n, ca, cx, incx)
CSCAL