156 SUBROUTINE cget54( 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 COMPLEX A( lda, * ), B( ldb, * ), S( lds, * ),
170 $ t( ldt, * ), u( ldu, * ), v( ldv, * ),
178 parameter( zero = 0.0e+0, one = 1.0e+0 )
180 parameter( czero = ( 0.0e+0, 0.0e+0 ),
181 $ cone = ( 1.0e+0, 0.0e+0 ) )
184 REAL ABNORM, ULP, UNFL, WNORM
191 EXTERNAL clange, slamch
197 INTRINSIC max, min, real
207 unfl = slamch(
'Safe minimum' )
208 ulp = slamch(
'Epsilon' )*slamch(
'Base' )
212 CALL
clacpy(
'Full', n, n, a, lda, work, n )
213 CALL
clacpy(
'Full', n, n, b, ldb, work( n*n+1 ), n )
214 abnorm = max( clange(
'1', n, 2*n, work, n, dum ), unfl )
218 CALL
clacpy(
' ', n, n, a, lda, work, n )
219 CALL
cgemm(
'N',
'N', n, n, n, cone, u, ldu, s, lds, czero,
222 CALL
cgemm(
'N',
'C', n, n, n, -cone, work( n*n+1 ), n, v, ldv,
227 CALL
clacpy(
' ', n, n, b, ldb, work( n*n+1 ), n )
228 CALL
cgemm(
'N',
'N', n, n, n, cone, u, ldu, t, ldt, czero,
229 $ work( 2*n*n+1 ), n )
231 CALL
cgemm(
'N',
'C', n, n, n, -cone, work( 2*n*n+1 ), n, v, ldv,
232 $ cone, work( n*n+1 ), n )
236 wnorm = clange(
'1', n, 2*n, work, n, dum )
238 IF( abnorm.GT.wnorm )
THEN
239 result = ( wnorm / abnorm ) / ( 2*n*ulp )
241 IF( abnorm.LT.one )
THEN
242 result = ( min( wnorm, 2*n*abnorm ) / abnorm ) / ( 2*n*ulp )
244 result = min( wnorm / abnorm,
REAL( 2*N ) ) / ( 2*N*ULP )
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine cget54(N, A, LDA, B, LDB, S, LDS, T, LDT, U, LDU, V, LDV, WORK, RESULT)
CGET54
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM