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
194 INTRINSIC max, min, real
204 unfl =
slamch(
'Safe minimum' )
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 )
REAL function slamch(CMACH)
SLAMCH
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
REAL function slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
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