123 INTEGER info, kl, ku, lda, m, n
127 DOUBLE PRECISION d( * )
128 COMPLEX*16 a( lda, * ), work( * )
135 parameter ( zero = ( 0.0d+0, 0.0d+0 ),
136 $ one = ( 1.0d+0, 0.0d+0 ) )
141 COMPLEX*16 tau, wa, wb
147 INTRINSIC abs, dble, max, min
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(
'ZLAGGE', -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 zlarnv( 3, iseed, m-i+1, work )
197 wn =
dznrm2( m-i+1, work, 1 )
198 wa = ( wn / abs( work( 1 ) ) )*work( 1 )
199 IF( wn.EQ.zero )
THEN
203 CALL zscal( m-i, one / wb, work( 2 ), 1 )
205 tau = dble( wb / wa )
210 CALL zgemv(
'Conjugate transpose', m-i+1, n-i+1, one,
211 $ a( i, i ), lda, work, 1, zero, work( m+1 ), 1 )
212 CALL zgerc( m-i+1, n-i+1, -tau, work, 1, work( m+1 ), 1,
219 CALL zlarnv( 3, iseed, n-i+1, work )
220 wn =
dznrm2( n-i+1, work, 1 )
221 wa = ( wn / abs( work( 1 ) ) )*work( 1 )
222 IF( wn.EQ.zero )
THEN
226 CALL zscal( n-i, one / wb, work( 2 ), 1 )
228 tau = dble( wb / wa )
233 CALL zgemv(
'No transpose', m-i+1, n-i+1, one, a( i, i ),
234 $ lda, work, 1, zero, work( n+1 ), 1 )
235 CALL zgerc( 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 =
dznrm2( 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 zscal( m-kl-i, one / wb, a( kl+i+1, i ), 1 )
260 tau = dble( wb / wa )
265 CALL zgemv(
'Conjugate transpose', m-kl-i+1, n-i, one,
266 $ a( kl+i, i+1 ), lda, a( kl+i, i ), 1, zero,
268 CALL zgerc( 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 =
dznrm2( 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 zscal( n-ku-i, one / wb, a( i, ku+i+1 ), lda )
285 tau = dble( wb / wa )
290 CALL zlacgv( n-ku-i+1, a( i, ku+i ), lda )
291 CALL zgemv(
'No transpose', m-i, n-ku-i+1, one,
292 $ a( i+1, ku+i ), lda, a( i, ku+i ), lda, zero,
294 CALL zgerc( 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 =
dznrm2( 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 zscal( n-ku-i, one / wb, a( i, ku+i+1 ), lda )
315 tau = dble( wb / wa )
320 CALL zlacgv( n-ku-i+1, a( i, ku+i ), lda )
321 CALL zgemv(
'No transpose', m-i, n-ku-i+1, one,
322 $ a( i+1, ku+i ), lda, a( i, ku+i ), lda, zero,
324 CALL zgerc( 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 =
dznrm2( 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 zscal( m-kl-i, one / wb, a( kl+i+1, i ), 1 )
341 tau = dble( wb / wa )
346 CALL zgemv(
'Conjugate transpose', m-kl-i+1, n-i, one,
347 $ a( kl+i, i+1 ), lda, a( kl+i, i ), 1, zero,
349 CALL zgerc( 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
subroutine zgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZGEMV
subroutine zgerc(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
ZGERC
double precision function dznrm2(N, X, INCX)
DZNRM2
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zlacgv(N, X, INCX)
ZLACGV conjugates a complex vector.
subroutine zlarnv(IDIST, ISEED, N, X)
ZLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine zscal(N, ZA, ZX, INCX)
ZSCAL