127 INTEGER lda, nn, nout
128 DOUBLE PRECISION thresh
132 DOUBLE PRECISION a( lda, * ), arf( * ), b1( lda, * ),
133 + b2( lda, * ), d_work_dgeqrf( * ),
134 + d_work_dlange( * ), tau( * )
140 DOUBLE PRECISION zero, one
141 parameter ( zero = ( 0.0d+0, 0.0d+0 ) ,
142 + one = ( 1.0d+0, 0.0d+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
150 DOUBLE PRECISION eps, alpha
153 CHARACTER uplos( 2 ), forms( 2 ), transs( 2 ),
154 + diags( 2 ), sides( 2 )
155 INTEGER iseed( 4 ), iseedy( 4 )
156 DOUBLE PRECISION 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 =
dlamch(
'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 =
dlarnd( 2, iseed )
239 IF ( iside.EQ.1 )
THEN
265 a( i, j) =
dlarnd( 2, iseed )
269 IF ( iuplo.EQ.1 )
THEN
275 CALL dgeqrf( na, na, a, lda, tau,
276 + d_work_dgeqrf, lda,
284 CALL dgelqf( na, na, a, lda, tau,
285 + d_work_dgeqrf, lda,
292 CALL dtrttf( cform, uplo, na, a, lda, arf,
300 b1( i, j) =
dlarnd( 2, iseed )
301 b2( i, j) = b1( i, j)
309 CALL dtrsm( side, uplo, trans, diag, m, n,
310 + alpha, a, lda, b1, lda )
316 CALL dtfsm( cform, side, uplo, trans,
317 + diag, m, n, alpha, arf, b2,
324 b1( i, j) = b2( i, j ) - b1( i, j )
328 result(1) =
dlange(
'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 )
'DTFSM',
340 + cform, side, uplo, trans, diag, m,
356 IF ( nfail.EQ.0 )
THEN
357 WRITE( nout, fmt = 9996 )
'DTFSM', nrun
359 WRITE( nout, fmt = 9995 )
'DTFSM', nfail, nrun
362 9999
FORMAT( 1x,
' *** Error(s) or Failure(s) while testing DTFSM
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 dtrttf(TRANSR, UPLO, N, A, LDA, ARF, INFO)
DTRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full packed f...
double precision function dlamch(CMACH)
DLAMCH
subroutine dtrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
DTRSM
subroutine dgeqlf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
DGEQLF
subroutine dtfsm(TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, B, LDB)
DTFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
subroutine dgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
DGELQF
double precision function dlange(NORM, M, N, A, LDA, WORK)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
double precision function dlarnd(IDIST, ISEED)
DLARND
subroutine dgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
DGEQRF