116 SUBROUTINE sdrvrf3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
117 + S_WORK_SLANGE, S_WORK_SGEQRF, TAU )
124 INTEGER LDA, NN, NOUT
129 REAL A( LDA, * ), ARF( * ), B1( LDA, * ),
130 + b2( lda, * ), s_work_sgeqrf( * ),
131 + s_work_slange( * ), tau( * )
138 parameter( zero = ( 0.0e+0, 0.0e+0 ) ,
139 + one = ( 1.0e+0, 0.0e+0 ) )
141 parameter( ntests = 1 )
144 CHARACTER UPLO, CFORM, DIAG, TRANS, SIDE
145 INTEGER I, IFORM, IIM, IIN, INFO, IUPLO, J, M, N, NA,
146 + nfail, nrun, iside, idiag, ialpha, itrans
150 CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ),
151 + diags( 2 ), sides( 2 )
152 INTEGER ISEED( 4 ), ISEEDY( 4 )
153 REAL RESULT( NTESTS )
156 REAL SLAMCH, SLANGE, SLARND
157 EXTERNAL slamch, slange, slarnd
169 COMMON / srnamc / srnamt
172 DATA iseedy / 1988, 1989, 1990, 1991 /
173 DATA uplos /
'U',
'L' /
174 DATA forms /
'N',
'T' /
175 DATA sides /
'L',
'R' /
176 DATA transs /
'N',
'T' /
177 DATA diags /
'N',
'U' /
187 iseed( i ) = iseedy( i )
189 eps = slamch(
'Precision' )
201 cform = forms( iform )
205 uplo = uplos( iuplo )
209 side = sides( iside )
213 trans = transs( itrans )
217 diag = diags( idiag )
221 IF ( ialpha.EQ. 1)
THEN
223 ELSE IF ( ialpha.EQ. 2)
THEN
226 alpha = slarnd( 2, iseed )
236 IF ( iside.EQ.1 )
THEN
262 a( i, j) = slarnd( 2, iseed )
266 IF ( iuplo.EQ.1 )
THEN
272 CALL sgeqrf( na, na, a, lda, tau,
273 + s_work_sgeqrf, lda,
281 CALL sgelqf( na, na, a, lda, tau,
282 + s_work_sgeqrf, lda,
289 CALL strttf( cform, uplo, na, a, lda, arf,
297 b1( i, j) = slarnd( 2, iseed )
298 b2( i, j) = b1( i, j)
306 CALL strsm( side, uplo, trans, diag, m, n,
307 + alpha, a, lda, b1, lda )
313 CALL stfsm( cform, side, uplo, trans,
314 + diag, m, n, alpha, arf, b2,
321 b1( i, j) = b2( i, j ) - b1( i, j )
325 result(1) = slange(
'I', m, n, b1, lda,
328 result(1) = result(1) / sqrt( eps )
329 + / max( max( m, n), 1 )
331 IF( result(1).GE.thresh )
THEN
332 IF( nfail.EQ.0 )
THEN
334 WRITE( nout, fmt = 9999 )
336 WRITE( nout, fmt = 9997 )
'STFSM',
337 + cform, side, uplo, trans, diag, m,
353 IF ( nfail.EQ.0 )
THEN
354 WRITE( nout, fmt = 9996 )
'STFSM', nrun
356 WRITE( nout, fmt = 9995 )
'STFSM', nfail, nrun
359 9999
FORMAT( 1x,
' *** Error(s) or Failure(s) while testing STFSM
361 9997
FORMAT( 1x,
' Failure in ',a5,
', CFORM=''',a1,
''',',
362 +
' SIDE=''',a1,
''',',
' UPLO=''',a1,
''',',
' TRANS=''',a1,
''',',
363 +
' DIAG=''',a1,
''',',
' M=',i3,
', N =', i3,
', test=',g12.5)
364 9996
FORMAT( 1x,
'All tests for ',a5,
' auxiliary routine passed the ',
365 +
'threshold ( ',i5,
' tests run)')
366 9995
FORMAT( 1x, a6,
' auxiliary routine: ',i5,
' out of ',i5,
367 +
' tests failed to pass the threshold')
subroutine sgeqlf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGEQLF
subroutine sgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGEQRF
subroutine sgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGELQF
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 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 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