140 SUBROUTINE sbdt01( M, N, KD, A, LDA, Q, LDQ, D, E, PT, LDPT, WORK,
149 INTEGER KD, LDA, LDPT, LDQ, M, N
153 REAL A( lda, * ), D( * ), E( * ), PT( ldpt, * ),
154 $ q( ldq, * ), work( * )
161 parameter( zero = 0.0e+0, one = 1.0e+0 )
168 REAL SASUM, SLAMCH, SLANGE
169 EXTERNAL sasum, slamch, slange
175 INTRINSIC max, min, real
181 IF( m.LE.0 .OR. n.LE.0 )
THEN
193 IF( kd.NE.0 .AND. m.GE.n )
THEN
198 CALL
scopy( m, a( 1, j ), 1, work, 1 )
200 work( m+i ) = d( i )*pt( i, j ) + e( i )*pt( i+1, j )
202 work( m+n ) = d( n )*pt( n, j )
203 CALL
sgemv(
'No transpose', m, n, -one, q, ldq,
204 $ work( m+1 ), 1, one, work, 1 )
205 resid = max( resid, sasum( m, work, 1 ) )
207 ELSE IF( kd.LT.0 )
THEN
212 CALL
scopy( m, a( 1, j ), 1, work, 1 )
214 work( m+i ) = d( i )*pt( i, j ) + e( i )*pt( i+1, j )
216 work( m+m ) = d( m )*pt( m, j )
217 CALL
sgemv(
'No transpose', m, m, -one, q, ldq,
218 $ work( m+1 ), 1, one, work, 1 )
219 resid = max( resid, sasum( m, work, 1 ) )
226 CALL
scopy( m, a( 1, j ), 1, work, 1 )
227 work( m+1 ) = d( 1 )*pt( 1, j )
229 work( m+i ) = e( i-1 )*pt( i-1, j ) +
232 CALL
sgemv(
'No transpose', m, m, -one, q, ldq,
233 $ work( m+1 ), 1, one, work, 1 )
234 resid = max( resid, sasum( m, work, 1 ) )
243 CALL
scopy( m, a( 1, j ), 1, work, 1 )
245 work( m+i ) = d( i )*pt( i, j )
247 CALL
sgemv(
'No transpose', m, n, -one, q, ldq,
248 $ work( m+1 ), 1, one, work, 1 )
249 resid = max( resid, sasum( m, work, 1 ) )
253 CALL
scopy( m, a( 1, j ), 1, work, 1 )
255 work( m+i ) = d( i )*pt( i, j )
257 CALL
sgemv(
'No transpose', m, m, -one, q, ldq,
258 $ work( m+1 ), 1, one, work, 1 )
259 resid = max( resid, sasum( m, work, 1 ) )
266 anorm = slange(
'1', m, n, a, lda, work )
267 eps = slamch(
'Precision' )
269 IF( anorm.LE.zero )
THEN
273 IF( anorm.GE.resid )
THEN
274 resid = ( resid / anorm ) / (
REAL( n )*EPS )
276 IF( anorm.LT.one )
THEN
277 resid = ( min( resid,
REAL( n )*ANORM ) / anorm ) /
280 resid = min( resid / anorm,
REAL( N ) ) /
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine sgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
SGEMV
subroutine sbdt01(M, N, KD, A, LDA, Q, LDQ, D, E, PT, LDPT, WORK, RESID)
SBDT01