123 INTEGER info, kl, ku, lda, m, n
128 COMPLEX a( lda, * ), work( * )
135 parameter ( zero = ( 0.0e+0, 0.0e+0 ),
136 $ one = ( 1.0e+0, 0.0e+0 ) )
147 INTRINSIC abs, max, min, real
160 ELSE IF( n.LT.0 )
THEN
162 ELSE IF( kl.LT.0 .OR. kl.GT.m-1 )
THEN
164 ELSE IF( ku.LT.0 .OR. ku.GT.n-1 )
THEN
166 ELSE IF( lda.LT.max( 1, m ) )
THEN
170 CALL xerbla(
'CLAGGE', -info )
181 DO 30 i = 1, min( m, n )
187 IF(( kl .EQ. 0 ).AND.( ku .EQ. 0))
RETURN
191 DO 40 i = min( m, n ), 1, -1
196 CALL clarnv( 3, iseed, m-i+1, work )
197 wn =
scnrm2( m-i+1, work, 1 )
198 wa = ( wn / abs( work( 1 ) ) )*work( 1 )
199 IF( wn.EQ.zero )
THEN
203 CALL cscal( m-i, one / wb, work( 2 ), 1 )
205 tau =
REAL( wb / wa )
210 CALL cgemv(
'Conjugate transpose', m-i+1, n-i+1, one,
211 $ a( i, i ), lda, work, 1, zero, work( m+1 ), 1 )
212 CALL cgerc( m-i+1, n-i+1, -tau, work, 1, work( m+1 ), 1,
219 CALL clarnv( 3, iseed, n-i+1, work )
220 wn =
scnrm2( n-i+1, work, 1 )
221 wa = ( wn / abs( work( 1 ) ) )*work( 1 )
222 IF( wn.EQ.zero )
THEN
226 CALL cscal( n-i, one / wb, work( 2 ), 1 )
228 tau =
REAL( wb / wa )
233 CALL cgemv(
'No transpose', m-i+1, n-i+1, one, a( i, i ),
234 $ lda, work, 1, zero, work( n+1 ), 1 )
235 CALL cgerc( m-i+1, n-i+1, -tau, work( n+1 ), 1, work, 1,
243 DO 70 i = 1, max( m-1-kl, n-1-ku )
248 IF( i.LE.min( m-1-kl, n ) )
THEN
252 wn =
scnrm2( m-kl-i+1, a( kl+i, i ), 1 )
253 wa = ( wn / abs( a( kl+i, i ) ) )*a( kl+i, i )
254 IF( wn.EQ.zero )
THEN
257 wb = a( kl+i, i ) + wa
258 CALL cscal( m-kl-i, one / wb, a( kl+i+1, i ), 1 )
260 tau =
REAL( wb / wa )
265 CALL cgemv(
'Conjugate transpose', m-kl-i+1, n-i, one,
266 $ a( kl+i, i+1 ), lda, a( kl+i, i ), 1, zero,
268 CALL cgerc( m-kl-i+1, n-i, -tau, a( kl+i, i ), 1, work,
269 $ 1, a( kl+i, i+1 ), lda )
273 IF( i.LE.min( n-1-ku, m ) )
THEN
277 wn =
scnrm2( n-ku-i+1, a( i, ku+i ), lda )
278 wa = ( wn / abs( a( i, ku+i ) ) )*a( i, ku+i )
279 IF( wn.EQ.zero )
THEN
282 wb = a( i, ku+i ) + wa
283 CALL cscal( n-ku-i, one / wb, a( i, ku+i+1 ), lda )
285 tau =
REAL( wb / wa )
290 CALL clacgv( n-ku-i+1, a( i, ku+i ), lda )
291 CALL cgemv(
'No transpose', m-i, n-ku-i+1, one,
292 $ a( i+1, ku+i ), lda, a( i, ku+i ), lda, zero,
294 CALL cgerc( m-i, n-ku-i+1, -tau, work, 1, a( i, ku+i ),
295 $ lda, a( i+1, ku+i ), lda )
303 IF( i.LE.min( n-1-ku, m ) )
THEN
307 wn =
scnrm2( n-ku-i+1, a( i, ku+i ), lda )
308 wa = ( wn / abs( a( i, ku+i ) ) )*a( i, ku+i )
309 IF( wn.EQ.zero )
THEN
312 wb = a( i, ku+i ) + wa
313 CALL cscal( n-ku-i, one / wb, a( i, ku+i+1 ), lda )
315 tau =
REAL( wb / wa )
320 CALL clacgv( n-ku-i+1, a( i, ku+i ), lda )
321 CALL cgemv(
'No transpose', m-i, n-ku-i+1, one,
322 $ a( i+1, ku+i ), lda, a( i, ku+i ), lda, zero,
324 CALL cgerc( m-i, n-ku-i+1, -tau, work, 1, a( i, ku+i ),
325 $ lda, a( i+1, ku+i ), lda )
329 IF( i.LE.min( m-1-kl, n ) )
THEN
333 wn =
scnrm2( m-kl-i+1, a( kl+i, i ), 1 )
334 wa = ( wn / abs( a( kl+i, i ) ) )*a( kl+i, i )
335 IF( wn.EQ.zero )
THEN
338 wb = a( kl+i, i ) + wa
339 CALL cscal( m-kl-i, one / wb, a( kl+i+1, i ), 1 )
341 tau =
REAL( wb / wa )
346 CALL cgemv(
'Conjugate transpose', m-kl-i+1, n-i, one,
347 $ a( kl+i, i+1 ), lda, a( kl+i, i ), 1, zero,
349 CALL cgerc( m-kl-i+1, n-i, -tau, a( kl+i, i ), 1, work,
350 $ 1, a( kl+i, i+1 ), lda )
356 DO 50 j = kl + i + 1, m
362 DO 60 j = ku + i + 1, n
real function scnrm2(N, X, INCX)
SCNRM2
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
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 xerbla(SRNAME, INFO)
XERBLA
subroutine clacgv(N, X, INCX)
CLACGV conjugates a complex vector.