118 SUBROUTINE sdrvrf3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
119 + s_work_slange, s_work_sgeqrf, tau )
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 )
159 REAL SLAMCH, SLANGE, SLARND
160 EXTERNAL slamch, slange, slarnd
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 sdrvrf3(NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, S_WORK_SLANGE, S_WORK_SGEQRF, TAU)
SDRVRF3
subroutine sgeqlf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGEQLF
subroutine sgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGEQRF
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...
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