115 SUBROUTINE zlagge( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO )
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 DO 40 i = min( m, n ), 1, -1
192 CALL
zlarnv( 3, iseed, m-i+1, work )
193 wn =
dznrm2( m-i+1, work, 1 )
194 wa = ( wn / abs( work( 1 ) ) )*work( 1 )
195 IF( wn.EQ.zero )
THEN
199 CALL
zscal( m-i, one / wb, work( 2 ), 1 )
201 tau = dble( wb / wa )
206 CALL
zgemv(
'Conjugate transpose', m-i+1, n-i+1, one,
207 $ a( i, i ), lda, work, 1, zero, work( m+1 ), 1 )
208 CALL
zgerc( m-i+1, n-i+1, -tau, work, 1, work( m+1 ), 1,
215 CALL
zlarnv( 3, iseed, n-i+1, work )
216 wn =
dznrm2( n-i+1, work, 1 )
217 wa = ( wn / abs( work( 1 ) ) )*work( 1 )
218 IF( wn.EQ.zero )
THEN
222 CALL
zscal( n-i, one / wb, work( 2 ), 1 )
224 tau = dble( wb / wa )
229 CALL
zgemv(
'No transpose', m-i+1, n-i+1, one, a( i, i ),
230 $ lda, work, 1, zero, work( n+1 ), 1 )
231 CALL
zgerc( m-i+1, n-i+1, -tau, work( n+1 ), 1, work, 1,
239 DO 70 i = 1, max( m-1-kl, n-1-ku )
244 IF( i.LE.min( m-1-kl, n ) )
THEN
248 wn =
dznrm2( m-kl-i+1, a( kl+i, i ), 1 )
249 wa = ( wn / abs( a( kl+i, i ) ) )*a( kl+i, i )
250 IF( wn.EQ.zero )
THEN
253 wb = a( kl+i, i ) + wa
254 CALL
zscal( m-kl-i, one / wb, a( kl+i+1, i ), 1 )
256 tau = dble( wb / wa )
261 CALL
zgemv(
'Conjugate transpose', m-kl-i+1, n-i, one,
262 $ a( kl+i, i+1 ), lda, a( kl+i, i ), 1, zero,
264 CALL
zgerc( m-kl-i+1, n-i, -tau, a( kl+i, i ), 1, work,
265 $ 1, a( kl+i, i+1 ), lda )
269 IF( i.LE.min( n-1-ku, m ) )
THEN
273 wn =
dznrm2( n-ku-i+1, a( i, ku+i ), lda )
274 wa = ( wn / abs( a( i, ku+i ) ) )*a( i, ku+i )
275 IF( wn.EQ.zero )
THEN
278 wb = a( i, ku+i ) + wa
279 CALL
zscal( n-ku-i, one / wb, a( i, ku+i+1 ), lda )
281 tau = dble( wb / wa )
286 CALL
zlacgv( n-ku-i+1, a( i, ku+i ), lda )
287 CALL
zgemv(
'No transpose', m-i, n-ku-i+1, one,
288 $ a( i+1, ku+i ), lda, a( i, ku+i ), lda, zero,
290 CALL
zgerc( m-i, n-ku-i+1, -tau, work, 1, a( i, ku+i ),
291 $ lda, a( i+1, ku+i ), lda )
299 IF( i.LE.min( n-1-ku, m ) )
THEN
303 wn =
dznrm2( n-ku-i+1, a( i, ku+i ), lda )
304 wa = ( wn / abs( a( i, ku+i ) ) )*a( i, ku+i )
305 IF( wn.EQ.zero )
THEN
308 wb = a( i, ku+i ) + wa
309 CALL
zscal( n-ku-i, one / wb, a( i, ku+i+1 ), lda )
311 tau = dble( wb / wa )
316 CALL
zlacgv( n-ku-i+1, a( i, ku+i ), lda )
317 CALL
zgemv(
'No transpose', m-i, n-ku-i+1, one,
318 $ a( i+1, ku+i ), lda, a( i, ku+i ), lda, zero,
320 CALL
zgerc( m-i, n-ku-i+1, -tau, work, 1, a( i, ku+i ),
321 $ lda, a( i+1, ku+i ), lda )
325 IF( i.LE.min( m-1-kl, n ) )
THEN
329 wn =
dznrm2( m-kl-i+1, a( kl+i, i ), 1 )
330 wa = ( wn / abs( a( kl+i, i ) ) )*a( kl+i, i )
331 IF( wn.EQ.zero )
THEN
334 wb = a( kl+i, i ) + wa
335 CALL
zscal( m-kl-i, one / wb, a( kl+i+1, i ), 1 )
337 tau = dble( wb / wa )
342 CALL
zgemv(
'Conjugate transpose', m-kl-i+1, n-i, one,
343 $ a( kl+i, i+1 ), lda, a( kl+i, i ), 1, zero,
345 CALL
zgerc( m-kl-i+1, n-i, -tau, a( kl+i, i ), 1, work,
346 $ 1, a( kl+i, i+1 ), lda )
351 DO 50
j = kl + i + 1, m
355 DO 60
j = ku + i + 1, n
subroutine zlagge(M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO)
ZLAGGE
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
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.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
double precision function dznrm2(N, X, INCX)
DZNRM2
subroutine zscal(N, ZA, ZX, INCX)
ZSCAL