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