117 SUBROUTINE cdrvrf3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
118 + S_WORK_CLANGE, C_WORK_CGEQRF, TAU )
125 INTEGER LDA, NN, NOUT
130 REAL S_WORK_CLANGE( * )
131 COMPLEX A( LDA, * ), ARF( * ), B1( LDA, * ),
133 COMPLEX C_WORK_CGEQRF( * ), TAU( * )
140 parameter( zero = ( 0.0e+0, 0.0e+0 ) ,
141 + one = ( 1.0e+0, 0.0e+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 REAL RESULT( NTESTS )
161 EXTERNAL slamch, clarnd, clange
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 = slamch(
'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 = clarnd( 4, iseed )
240 IF ( iside.EQ.1 )
THEN
266 a( i, j) = clarnd( 4, iseed )
270 IF ( iuplo.EQ.1 )
THEN
276 CALL cgeqrf( na, na, a, lda, tau,
277 + c_work_cgeqrf, lda,
285 CALL cgelqf( na, na, a, lda, tau,
286 + c_work_cgeqrf, lda,
296 a( j, j) = a(j,j) * clarnd( 5, iseed )
302 CALL ctrttf( cform, uplo, na, a, lda, arf,
310 b1( i, j) = clarnd( 4, iseed )
311 b2( i, j) = b1( i, j)
319 CALL ctrsm( side, uplo, trans, diag, m, n,
320 + alpha, a, lda, b1, lda )
326 CALL ctfsm( cform, side, uplo, trans,
327 + diag, m, n, alpha, arf, b2,
334 b1( i, j) = b2( i, j ) - b1( i, j )
338 result(1) = clange(
'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 )
'CTFSM',
350 + cform, side, uplo, trans, diag, m,
366 IF ( nfail.EQ.0 )
THEN
367 WRITE( nout, fmt = 9996 )
'CTFSM', nrun
369 WRITE( nout, fmt = 9995 )
'CTFSM', nfail, nrun
372 9999
FORMAT( 1x,
' *** Error(s) or Failure(s) while testing CTFSM
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 ctrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
CTRSM
subroutine cdrvrf3(NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, S_WORK_CLANGE, C_WORK_CGEQRF, TAU)
CDRVRF3
subroutine cgeqlf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
CGEQLF
subroutine cgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
CGEQRF
subroutine cgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
CGELQF
subroutine ctfsm(TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, B, LDB)
CTFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
subroutine ctrttf(TRANSR, UPLO, N, A, LDA, ARF, INFO)
CTRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full packed f...