114 SUBROUTINE slagge( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO )
122 INTEGER INFO, KL, KU, LDA, M, N
126 REAL A( lda, * ), D( * ), WORK( * )
133 parameter ( zero = 0.0e+0, one = 1.0e+0 )
143 INTRINSIC max, min, sign
156 ELSE IF( n.LT.0 )
THEN
158 ELSE IF( kl.LT.0 .OR. kl.GT.m-1 )
THEN
160 ELSE IF( ku.LT.0 .OR. ku.GT.n-1 )
THEN
162 ELSE IF( lda.LT.max( 1, m ) )
THEN
166 CALL xerbla(
'SLAGGE', -info )
177 DO 30 i = 1, min( m, n )
183 IF(( kl .EQ. 0 ).AND.( ku .EQ. 0))
RETURN
187 DO 40 i = min( m, n ), 1, -1
192 CALL slarnv( 3, iseed, m-i+1, work )
193 wn = snrm2( m-i+1, work, 1 )
194 wa = sign( wn, work( 1 ) )
195 IF( wn.EQ.zero )
THEN
199 CALL sscal( m-i, one / wb, work( 2 ), 1 )
206 CALL sgemv(
'Transpose', m-i+1, n-i+1, one, a( i, i ), lda,
207 $ work, 1, zero, work( m+1 ), 1 )
208 CALL sger( m-i+1, n-i+1, -tau, work, 1, work( m+1 ), 1,
215 CALL slarnv( 3, iseed, n-i+1, work )
216 wn = snrm2( n-i+1, work, 1 )
217 wa = sign( wn, work( 1 ) )
218 IF( wn.EQ.zero )
THEN
222 CALL sscal( n-i, one / wb, work( 2 ), 1 )
229 CALL sgemv(
'No transpose', m-i+1, n-i+1, one, a( i, i ),
230 $ lda, work, 1, zero, work( n+1 ), 1 )
231 CALL sger( 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 = snrm2( m-kl-i+1, a( kl+i, i ), 1 )
249 wa = sign( wn, a( kl+i, i ) )
250 IF( wn.EQ.zero )
THEN
253 wb = a( kl+i, i ) + wa
254 CALL sscal( m-kl-i, one / wb, a( kl+i+1, i ), 1 )
261 CALL sgemv(
'Transpose', m-kl-i+1, n-i, one,
262 $ a( kl+i, i+1 ), lda, a( kl+i, i ), 1, zero,
264 CALL sger( m-kl-i+1, n-i, -tau, a( kl+i, i ), 1, work, 1,
265 $ a( kl+i, i+1 ), lda )
269 IF( i.LE.min( n-1-ku, m ) )
THEN
273 wn = snrm2( n-ku-i+1, a( i, ku+i ), lda )
274 wa = sign( wn, a( i, ku+i ) )
275 IF( wn.EQ.zero )
THEN
278 wb = a( i, ku+i ) + wa
279 CALL sscal( n-ku-i, one / wb, a( i, ku+i+1 ), lda )
286 CALL sgemv(
'No transpose', m-i, n-ku-i+1, one,
287 $ a( i+1, ku+i ), lda, a( i, ku+i ), lda, zero,
289 CALL sger( m-i, n-ku-i+1, -tau, work, 1, a( i, ku+i ),
290 $ lda, a( i+1, ku+i ), lda )
298 IF( i.LE.min( n-1-ku, m ) )
THEN
302 wn = snrm2( n-ku-i+1, a( i, ku+i ), lda )
303 wa = sign( wn, a( i, ku+i ) )
304 IF( wn.EQ.zero )
THEN
307 wb = a( i, ku+i ) + wa
308 CALL sscal( n-ku-i, one / wb, a( i, ku+i+1 ), lda )
315 CALL sgemv(
'No transpose', m-i, n-ku-i+1, one,
316 $ a( i+1, ku+i ), lda, a( i, ku+i ), lda, zero,
318 CALL sger( m-i, n-ku-i+1, -tau, work, 1, a( i, ku+i ),
319 $ lda, a( i+1, ku+i ), lda )
323 IF( i.LE.min( m-1-kl, n ) )
THEN
327 wn = snrm2( m-kl-i+1, a( kl+i, i ), 1 )
328 wa = sign( wn, a( kl+i, i ) )
329 IF( wn.EQ.zero )
THEN
332 wb = a( kl+i, i ) + wa
333 CALL sscal( m-kl-i, one / wb, a( kl+i+1, i ), 1 )
340 CALL sgemv(
'Transpose', m-kl-i+1, n-i, one,
341 $ a( kl+i, i+1 ), lda, a( kl+i, i ), 1, zero,
343 CALL sger( m-kl-i+1, n-i, -tau, a( kl+i, i ), 1, work, 1,
344 $ a( kl+i, i+1 ), lda )
350 DO 50 j = kl + i + 1, m
356 DO 60 j = ku + i + 1, n
subroutine sger(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
SGER
subroutine sgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
SGEMV
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine slarnv(IDIST, ISEED, N, X)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine sscal(N, SA, SX, INCX)
SSCAL
subroutine slagge(M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO)
SLAGGE