119 SUBROUTINE zdrvrf3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
120 + d_work_zlange, z_work_zgeqrf, tau )
128 INTEGER lda, nn, nout
129 DOUBLE PRECISION thresh
133 DOUBLE PRECISION d_work_zlange( * )
134 COMPLEX*16 a( lda, * ), arf( * ), b1( lda, * ),
136 COMPLEX*16 z_work_zgeqrf( * ), tau( * )
143 parameter( zero = ( 0.0d+0, 0.0d+0 ) ,
144 + one = ( 1.0d+0, 0.0d+0 ) )
146 parameter( ntests = 1 )
149 CHARACTER uplo, cform, diag, trans, side
150 INTEGER i, iform, iim, iin, info, iuplo,
j, m, n, na,
151 + nfail, nrun, iside, idiag, ialpha, itrans
156 CHARACTER uplos( 2 ),
forms( 2 ), transs( 2 ),
157 + diags( 2 ), sides( 2 )
158 INTEGER iseed( 4 ), iseedy( 4 )
159 DOUBLE PRECISION result( ntests )
176 COMMON / srnamc / srnamt
179 DATA iseedy / 1988, 1989, 1990, 1991 /
180 DATA uplos /
'U',
'L' /
181 DATA forms /
'N',
'C' /
182 DATA sides /
'L',
'R' /
183 DATA transs /
'N',
'C' /
184 DATA diags /
'N',
'U' /
194 iseed( i ) = iseedy( i )
196 eps =
dlamch(
'Precision' )
208 cform =
forms( iform )
212 uplo = uplos( iuplo )
216 side = sides( iside )
220 trans = transs( itrans )
224 diag = diags( idiag )
228 IF ( ialpha.EQ. 1)
THEN
230 ELSE IF ( ialpha.EQ. 1)
THEN
233 alpha =
zlarnd( 4, iseed )
243 IF ( iside.EQ.1 )
THEN
273 IF ( iuplo.EQ.1 )
THEN
279 CALL
zgeqrf( na, na, a, lda, tau,
280 + z_work_zgeqrf, lda,
288 CALL
zgelqf( na, na, a, lda, tau,
289 + z_work_zgeqrf, lda,
305 CALL
ztrttf( cform, uplo, na, a, lda, arf,
314 b2( i,
j) = b1( i,
j)
322 CALL
ztrsm( side, uplo, trans, diag, m, n,
323 + alpha, a, lda, b1, lda )
329 CALL
ztfsm( cform, side, uplo, trans,
330 + diag, m, n, alpha, arf, b2,
337 b1( i,
j) = b2( i,
j ) - b1( i,
j )
341 result(1) =
zlange(
'I', m, n, b1, lda,
344 result(1) = result(1) / sqrt( eps )
345 + / max( max( m, n), 1 )
347 IF( result(1).GE.thresh )
THEN
348 IF( nfail.EQ.0 )
THEN
350 WRITE( nout, fmt = 9999 )
352 WRITE( nout, fmt = 9997 )
'ZTFSM',
353 + cform, side, uplo, trans, diag, m,
369 IF ( nfail.EQ.0 )
THEN
370 WRITE( nout, fmt = 9996 )
'ZTFSM', nrun
372 WRITE( nout, fmt = 9995 )
'ZTFSM', nfail, nrun
375 9999
FORMAT( 1
x,
' *** Error(s) or Failure(s) while testing ZTFSM
377 9997
FORMAT( 1
x,
' Failure in ',a5,
', CFORM=''',a1,
''',',
378 +
' SIDE=''',a1,
''',',
' UPLO=''',a1,
''',',
' TRANS=''',a1,
''',',
379 +
' DIAG=''',a1,
''',',
' M=',i3,
', N =', i3,
', test=',g12.5)
380 9996
FORMAT( 1
x,
'All tests for ',a5,
' auxiliary routine passed the ',
381 +
'threshold ( ',i5,
' tests run)')
382 9995
FORMAT( 1
x, a6,
' auxiliary routine:',i5,
' out of ',i5,
383 +
' tests failed to pass the threshold')
subroutine zgeqlf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
ZGEQLF
subroutine ztrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
ZTRSM
COMPLEX *16 function zlarnd(IDIST, ISEED)
ZLARND
DOUBLE PRECISION function zlange(NORM, M, N, A, LDA, WORK)
ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
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 zgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
ZGELQF
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.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine zdrvrf3(NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, D_WORK_ZLANGE, Z_WORK_ZGEQRF, TAU)
ZDRVRF3
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
Intel Corp All rights reserved Redistribution and use in source and binary forms