156 SUBROUTINE sget54( N, A, LDA, B, LDB, S, LDS, T, LDT, U, LDU, V,
157 $ ldv, work, result )
165 INTEGER LDA, LDB, LDS, LDT, LDU, LDV, N
169 REAL A( lda, * ), B( ldb, * ), S( lds, * ),
170 $ t( ldt, * ), u( ldu, * ), v( ldv, * ),
178 parameter( zero = 0.0e+0, one = 1.0e+0 )
181 REAL ABNORM, ULP, UNFL, WNORM
188 EXTERNAL slamch, slange
194 INTRINSIC max, min, real
204 unfl = slamch(
'Safe minimum' )
205 ulp = slamch(
'Epsilon' )*slamch(
'Base' )
209 CALL
slacpy(
'Full', n, n, a, lda, work, n )
210 CALL
slacpy(
'Full', n, n, b, ldb, work( n*n+1 ), n )
211 abnorm = max( slange(
'1', n, 2*n, work, n, dum ), unfl )
215 CALL
slacpy(
' ', n, n, a, lda, work, n )
216 CALL
sgemm(
'N',
'N', n, n, n, one, u, ldu, s, lds, zero,
219 CALL
sgemm(
'N',
'C', n, n, n, -one, work( n*n+1 ), n, v, ldv,
224 CALL
slacpy(
' ', n, n, b, ldb, work( n*n+1 ), n )
225 CALL
sgemm(
'N',
'N', n, n, n, one, u, ldu, t, ldt, zero,
226 $ work( 2*n*n+1 ), n )
228 CALL
sgemm(
'N',
'C', n, n, n, -one, work( 2*n*n+1 ), n, v, ldv,
229 $ one, work( n*n+1 ), n )
233 wnorm = slange(
'1', n, 2*n, work, n, dum )
235 IF( abnorm.GT.wnorm )
THEN
236 result = ( wnorm / abnorm ) / ( 2*n*ulp )
238 IF( abnorm.LT.one )
THEN
239 result = ( min( wnorm, 2*n*abnorm ) / abnorm ) / ( 2*n*ulp )
241 result = min( wnorm / abnorm,
REAL( 2*N ) ) / ( 2*N*ULP )
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
subroutine sget54(N, A, LDA, B, LDB, S, LDS, T, LDT, U, LDU, V, LDV, WORK, RESULT)
SGET54