156 SUBROUTINE zget54( 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
166 DOUBLE PRECISION result
169 COMPLEX*16 a( lda, * ), b( ldb, * ), s( lds, * ),
170 $ t( ldt, * ), u( ldu, * ), v( ldv, * ),
177 DOUBLE PRECISION zero, one
178 parameter( zero = 0.0d+0, one = 1.0d+0 )
179 COMPLEX*16 czero, cone
180 parameter( czero = ( 0.0d+0, 0.0d+0 ),
181 $ cone = ( 1.0d+0, 0.0d+0 ) )
184 DOUBLE PRECISION abnorm, ulp, unfl, wnorm
187 DOUBLE PRECISION dum( 1 )
197 INTRINSIC dble, max, min
207 unfl =
dlamch(
'Safe minimum' )
212 CALL
zlacpy(
'Full', n, n, a, lda, work, n )
213 CALL
zlacpy(
'Full', n, n, b, ldb, work( n*n+1 ), n )
214 abnorm = max(
zlange(
'1', n, 2*n, work, n, dum ), unfl )
218 CALL
zlacpy(
' ', n, n, a, lda, work, n )
219 CALL
zgemm(
'N',
'N', n, n, n, cone, u, ldu, s, lds, czero,
222 CALL
zgemm(
'N',
'C', n, n, n, -cone, work( n*n+1 ), n, v, ldv,
227 CALL
zlacpy(
' ', n, n, b, ldb, work( n*n+1 ), n )
228 CALL
zgemm(
'N',
'N', n, n, n, cone, u, ldu, t, ldt, czero,
229 $ work( 2*n*n+1 ), n )
231 CALL
zgemm(
'N',
'C', n, n, n, -cone, work( 2*n*n+1 ), n, v, ldv,
232 $ cone, work( n*n+1 ), n )
236 wnorm =
zlange(
'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, dble( 2*n ) ) / ( 2*n*ulp )