1 SUBROUTINE claghe( N, K, D, A, LDA, ISEED, WORK, INFO )
8 INTEGER INFO, K, LDA, N
13 COMPLEX A( LDA, * ), WORK( * )
59 COMPLEX ZERO, ONE, HALF
60 parameter( zero = ( 0.0e+0, 0.0e+0 ),
61 $ one = ( 1.0e+0, 0.0e+0 ),
62 $ half = ( 0.5e+0, 0.0e+0 ) )
67 COMPLEX ALPHA, TAU, WA, WB
70 EXTERNAL caxpy, cgemv, cgerc, chemv, cher2,
clarnv,
76 EXTERNAL scnrm2, cdotc
79 INTRINSIC abs, conjg,
max, real
88 ELSE IF( k.LT.0 .OR. k.GT.n-1 )
THEN
90 ELSE IF( lda.LT.
max( 1, n ) )
THEN
94 CALL xerbla(
'CLAGHE', -info )
111 DO 40 i = n - 1, 1, -1
115 CALL clarnv( 3, iseed, n-i+1, work )
116 wn = scnrm2( n-i+1, work, 1 )
117 wa = ( wn / abs( work( 1 ) ) )*work( 1 )
118 IF( wn.EQ.zero )
THEN
122 CALL cscal( n-i, one / wb, work( 2 ), 1 )
124 tau = real( wb / wa )
132 CALL chemv(
'Lower', n-i+1, tau, a( i, i ), lda, work, 1, zero,
137 alpha = -half*tau*cdotc( n-i+1, work( n+1 ), 1, work, 1 )
138 CALL caxpy( n-i+1, alpha, work, 1, work( n+1 ), 1 )
142 CALL cher2(
'Lower', n-i+1, -one, work, 1, work( n+1 ), 1,
148 DO 60 i = 1, n - 1 - k
152 wn = scnrm2( n-k-i+1, a( k+i, i ), 1 )
153 wa = ( wn / abs( a( k+i, i ) ) )*a( k+i, i )
154 IF( wn.EQ.zero )
THEN
157 wb = a( k+i, i ) + wa
158 CALL cscal( n-k-i, one / wb, a( k+i+1, i ), 1 )
160 tau = real( wb / wa )
165 CALL cgemv(
'Conjugate transpose', n-k-i+1, k-1, one,
166 $ a( k+i, i+1 ), lda, a( k+i, i ), 1, zero, work, 1 )
167 CALL cgerc( n-k-i+1, k-1, -tau, a( k+i, i ), 1, work, 1,
168 $ a( k+i, i+1 ), lda )
174 CALL chemv(
'Lower', n-k-i+1, tau, a( k+i, k+i ), lda,
175 $ a( k+i, i ), 1, zero, work, 1 )
179 alpha = -half*tau*cdotc( n-k-i+1, work, 1, a( k+i, i ), 1 )
180 CALL caxpy( n-k-i+1, alpha, a( k+i, i ), 1, work, 1 )
184 CALL cher2(
'Lower', n-k-i+1, -one, a( k+i, i ), 1, work, 1,
185 $ a( k+i, k+i ), lda )
188 DO 50 j = k + i + 1, n
197 a( j, i ) = conjg( a( i, j ) )