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 DO 40 i = min( m, n ), 1, -1
188 CALL
slarnv( 3, iseed, m-i+1, work )
189 wn = snrm2( m-i+1, work, 1 )
190 wa = sign( wn, work( 1 ) )
191 IF( wn.EQ.zero )
THEN
195 CALL
sscal( m-i, one / wb, work( 2 ), 1 )
202 CALL
sgemv(
'Transpose', m-i+1, n-i+1, one, a( i, i ), lda,
203 $ work, 1, zero, work( m+1 ), 1 )
204 CALL
sger( m-i+1, n-i+1, -tau, work, 1, work( m+1 ), 1,
211 CALL
slarnv( 3, iseed, n-i+1, work )
212 wn = snrm2( n-i+1, work, 1 )
213 wa = sign( wn, work( 1 ) )
214 IF( wn.EQ.zero )
THEN
218 CALL
sscal( n-i, one / wb, work( 2 ), 1 )
225 CALL
sgemv(
'No transpose', m-i+1, n-i+1, one, a( i, i ),
226 $ lda, work, 1, zero, work( n+1 ), 1 )
227 CALL
sger( m-i+1, n-i+1, -tau, work( n+1 ), 1, work, 1,
235 DO 70 i = 1, max( m-1-kl, n-1-ku )
240 IF( i.LE.min( m-1-kl, n ) )
THEN
244 wn = snrm2( m-kl-i+1, a( kl+i, i ), 1 )
245 wa = sign( wn, a( kl+i, i ) )
246 IF( wn.EQ.zero )
THEN
249 wb = a( kl+i, i ) + wa
250 CALL
sscal( m-kl-i, one / wb, a( kl+i+1, i ), 1 )
257 CALL
sgemv(
'Transpose', m-kl-i+1, n-i, one,
258 $ a( kl+i, i+1 ), lda, a( kl+i, i ), 1, zero,
260 CALL
sger( m-kl-i+1, n-i, -tau, a( kl+i, i ), 1, work, 1,
261 $ a( kl+i, i+1 ), lda )
265 IF( i.LE.min( n-1-ku, m ) )
THEN
269 wn = snrm2( n-ku-i+1, a( i, ku+i ), lda )
270 wa = sign( wn, a( i, ku+i ) )
271 IF( wn.EQ.zero )
THEN
274 wb = a( i, ku+i ) + wa
275 CALL
sscal( n-ku-i, one / wb, a( i, ku+i+1 ), lda )
282 CALL
sgemv(
'No transpose', m-i, n-ku-i+1, one,
283 $ a( i+1, ku+i ), lda, a( i, ku+i ), lda, zero,
285 CALL
sger( m-i, n-ku-i+1, -tau, work, 1, a( i, ku+i ),
286 $ lda, a( i+1, ku+i ), lda )
294 IF( i.LE.min( n-1-ku, m ) )
THEN
298 wn = snrm2( n-ku-i+1, a( i, ku+i ), lda )
299 wa = sign( wn, a( i, ku+i ) )
300 IF( wn.EQ.zero )
THEN
303 wb = a( i, ku+i ) + wa
304 CALL
sscal( n-ku-i, one / wb, a( i, ku+i+1 ), lda )
311 CALL
sgemv(
'No transpose', m-i, n-ku-i+1, one,
312 $ a( i+1, ku+i ), lda, a( i, ku+i ), lda, zero,
314 CALL
sger( m-i, n-ku-i+1, -tau, work, 1, a( i, ku+i ),
315 $ lda, a( i+1, ku+i ), lda )
319 IF( i.LE.min( m-1-kl, n ) )
THEN
323 wn = snrm2( m-kl-i+1, a( kl+i, i ), 1 )
324 wa = sign( wn, a( kl+i, i ) )
325 IF( wn.EQ.zero )
THEN
328 wb = a( kl+i, i ) + wa
329 CALL
sscal( m-kl-i, one / wb, a( kl+i+1, i ), 1 )
336 CALL
sgemv(
'Transpose', m-kl-i+1, n-i, one,
337 $ a( kl+i, i+1 ), lda, a( kl+i, i ), 1, zero,
339 CALL
sger( m-kl-i+1, n-i, -tau, a( kl+i, i ), 1, work, 1,
340 $ a( kl+i, i+1 ), lda )
345 DO 50 j = kl + i + 1, m
349 DO 60 j = ku + i + 1, n
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine sgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
SGEMV
subroutine slagge(M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO)
SLAGGE
subroutine slarnv(IDIST, ISEED, N, X)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine sger(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
SGER
subroutine sscal(N, SA, SX, INCX)
SSCAL