127 INTEGER lda, nn, nout
132 REAL a( lda, * ), arf( * ), b1( lda, * ),
133 + b2( lda, * ), s_work_sgeqrf( * ),
134 + s_work_slange( * ), tau( * )
141 parameter ( zero = ( 0.0e+0, 0.0e+0 ) ,
142 + one = ( 1.0e+0, 0.0e+0 ) )
144 parameter ( ntests = 1 )
147 CHARACTER uplo, cform, diag, trans, side
148 INTEGER i, iform, iim, iin, info, iuplo, j, m, n, na,
149 + nfail, nrun, iside, idiag, ialpha, itrans
153 CHARACTER uplos( 2 ), forms( 2 ), transs( 2 ),
154 + diags( 2 ), sides( 2 )
155 INTEGER iseed( 4 ), iseedy( 4 )
156 REAL result( ntests )
172 COMMON / srnamc / srnamt
175 DATA iseedy / 1988, 1989, 1990, 1991 /
176 DATA uplos /
'U',
'L' /
177 DATA forms /
'N',
'T' /
178 DATA sides /
'L',
'R' /
179 DATA transs /
'N',
'T' /
180 DATA diags /
'N',
'U' /
190 iseed( i ) = iseedy( i )
192 eps =
slamch(
'Precision' )
204 cform = forms( iform )
208 uplo = uplos( iuplo )
212 side = sides( iside )
216 trans = transs( itrans )
220 diag = diags( idiag )
224 IF ( ialpha.EQ. 1)
THEN
226 ELSE IF ( ialpha.EQ. 1)
THEN
229 alpha =
slarnd( 2, iseed )
239 IF ( iside.EQ.1 )
THEN
265 a( i, j) =
slarnd( 2, iseed )
269 IF ( iuplo.EQ.1 )
THEN
275 CALL sgeqrf( na, na, a, lda, tau,
276 + s_work_sgeqrf, lda,
284 CALL sgelqf( na, na, a, lda, tau,
285 + s_work_sgeqrf, lda,
292 CALL strttf( cform, uplo, na, a, lda, arf,
300 b1( i, j) =
slarnd( 2, iseed )
301 b2( i, j) = b1( i, j)
309 CALL strsm( side, uplo, trans, diag, m, n,
310 + alpha, a, lda, b1, lda )
316 CALL stfsm( cform, side, uplo, trans,
317 + diag, m, n, alpha, arf, b2,
324 b1( i, j) = b2( i, j ) - b1( i, j )
328 result(1) =
slange(
'I', m, n, b1, lda,
331 result(1) = result(1) / sqrt( eps )
332 + / max( max( m, n), 1 )
334 IF( result(1).GE.thresh )
THEN
335 IF( nfail.EQ.0 )
THEN
337 WRITE( nout, fmt = 9999 )
339 WRITE( nout, fmt = 9997 )
'STFSM',
340 + cform, side, uplo, trans, diag, m,
356 IF ( nfail.EQ.0 )
THEN
357 WRITE( nout, fmt = 9996 )
'STFSM', nrun
359 WRITE( nout, fmt = 9995 )
'STFSM', nfail, nrun
362 9999
FORMAT( 1x,
' *** Error(s) or Failure(s) while testing STFSM
364 9997
FORMAT( 1x,
' Failure in ',a5,
', CFORM=''',a1,
''',',
365 +
' SIDE=''',a1,
''',',
' UPLO=''',a1,
''',',
' TRANS=''',a1,
''',',
366 +
' DIAG=''',a1,
''',',
' M=',i3,
', N =', i3,
', test=',g12.5)
367 9996
FORMAT( 1x,
'All tests for ',a5,
' auxiliary routine passed the ',
368 +
'threshold ( ',i5,
' tests run)')
369 9995
FORMAT( 1x, a6,
' auxiliary routine: ',i5,
' out of ',i5,
370 +
' tests failed to pass the threshold')
subroutine strsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
STRSM
subroutine sgeqlf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGEQLF
subroutine sgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGEQRF
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 ...
real function slarnd(IDIST, ISEED)
SLARND
subroutine strttf(TRANSR, UPLO, N, A, LDA, ARF, INFO)
STRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full packed f...
real function slamch(CMACH)
SLAMCH
subroutine stfsm(TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, B, LDB)
STFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
subroutine sgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGELQF