117 SUBROUTINE zdrvrf3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
118 + D_WORK_ZLANGE, Z_WORK_ZGEQRF, TAU )
125 INTEGER LDA, NN, NOUT
126 DOUBLE PRECISION THRESH
130 DOUBLE PRECISION D_WORK_ZLANGE( * )
131 COMPLEX*16 A( LDA, * ), ARF( * ), B1( LDA, * ),
133 COMPLEX*16 Z_WORK_ZGEQRF( * ), TAU( * )
140 parameter( zero = ( 0.0d+0, 0.0d+0 ) ,
141 + one = ( 1.0d+0, 0.0d+0 ) )
143 parameter( ntests = 1 )
146 CHARACTER UPLO, CFORM, DIAG, TRANS, SIDE
147 INTEGER I, IFORM, IIM, IIN, INFO, IUPLO, J, M, N, NA,
148 + 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 DOUBLE PRECISION RESULT( NTESTS )
159 DOUBLE PRECISION DLAMCH, ZLANGE
161 EXTERNAL dlamch, zlarnd, zlange
173 COMMON / srnamc / srnamt
176 DATA iseedy / 1988, 1989, 1990, 1991 /
177 DATA uplos /
'U',
'L' /
178 DATA forms /
'N',
'C' /
179 DATA sides /
'L',
'R' /
180 DATA transs /
'N',
'C' /
181 DATA diags /
'N',
'U' /
191 iseed( i ) = iseedy( i )
193 eps = dlamch(
'Precision' )
205 cform = forms( iform )
209 uplo = uplos( iuplo )
213 side = sides( iside )
217 trans = transs( itrans )
221 diag = diags( idiag )
225 IF ( ialpha.EQ. 1)
THEN
227 ELSE IF ( ialpha.EQ. 2)
THEN
230 alpha = zlarnd( 4, iseed )
240 IF ( iside.EQ.1 )
THEN
266 a( i, j) = zlarnd( 4, iseed )
270 IF ( iuplo.EQ.1 )
THEN
276 CALL zgeqrf( na, na, a, lda, tau,
277 + z_work_zgeqrf, lda,
285 CALL zgelqf( na, na, a, lda, tau,
286 + z_work_zgeqrf, lda,
296 a( j, j) = a(j,j) * zlarnd( 5, iseed )
302 CALL ztrttf( cform, uplo, na, a, lda, arf,
310 b1( i, j) = zlarnd( 4, iseed )
311 b2( i, j) = b1( i, j)
319 CALL ztrsm( side, uplo, trans, diag, m, n,
320 + alpha, a, lda, b1, lda )
326 CALL ztfsm( cform, side, uplo, trans,
327 + diag, m, n, alpha, arf, b2,
334 b1( i, j) = b2( i, j ) - b1( i, j )
338 result(1) = zlange(
'I', m, n, b1, lda,
341 result(1) = result(1) / sqrt( eps )
342 + / max( max( m, n), 1 )
344 IF( result(1).GE.thresh )
THEN
345 IF( nfail.EQ.0 )
THEN
347 WRITE( nout, fmt = 9999 )
349 WRITE( nout, fmt = 9997 )
'ZTFSM',
350 + cform, side, uplo, trans, diag, m,
366 IF ( nfail.EQ.0 )
THEN
367 WRITE( nout, fmt = 9996 )
'ZTFSM', nrun
369 WRITE( nout, fmt = 9995 )
'ZTFSM', nfail, nrun
372 9999
FORMAT( 1x,
' *** Error(s) or Failure(s) while testing ZTFSM
374 9997
FORMAT( 1x,
' Failure in ',a5,
', CFORM=''',a1,
''',',
375 +
' SIDE=''',a1,
''',',
' UPLO=''',a1,
''',',
' TRANS=''',a1,
''',',
376 +
' DIAG=''',a1,
''',',
' M=',i3,
', N =', i3,
', test=',g12.5)
377 9996
FORMAT( 1x,
'All tests for ',a5,
' auxiliary routine passed the ',
378 +
'threshold ( ',i5,
' tests run)')
379 9995
FORMAT( 1x, a6,
' auxiliary routine:',i5,
' out of ',i5,
380 +
' tests failed to pass the threshold')
subroutine ztrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
ZTRSM
subroutine zdrvrf3(NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, D_WORK_ZLANGE, Z_WORK_ZGEQRF, TAU)
ZDRVRF3
subroutine zgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
ZGELQF
subroutine zgeqlf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
ZGEQLF
subroutine ztfsm(TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, B, LDB)
ZTFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
subroutine ztrttf(TRANSR, UPLO, N, A, LDA, ARF, INFO)
ZTRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full packed f...
subroutine zgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
ZGEQRF VARIANT: left-looking Level 3 BLAS of the algorithm.