LAPACK 3.11.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ zdrvrf3()

subroutine zdrvrf3 ( integer  NOUT,
integer  NN,
integer, dimension( nn )  NVAL,
double precision  THRESH,
complex*16, dimension( lda, * )  A,
integer  LDA,
complex*16, dimension( * )  ARF,
complex*16, dimension( lda, * )  B1,
complex*16, dimension( lda, * )  B2,
double precision, dimension( * )  D_WORK_ZLANGE,
complex*16, dimension( * )  Z_WORK_ZGEQRF,
complex*16, dimension( * )  TAU 
)

ZDRVRF3

Purpose:
 ZDRVRF3 tests the LAPACK RFP routines:
     ZTFSM
Parameters
[in]NOUT
          NOUT is INTEGER
                The unit number for output.
[in]NN
          NN is INTEGER
                The number of values of N contained in the vector NVAL.
[in]NVAL
          NVAL is INTEGER array, dimension (NN)
                The values of the matrix dimension N.
[in]THRESH
          THRESH is DOUBLE PRECISION
                The threshold value for the test ratios.  A result is
                included in the output file if RESULT >= THRESH.  To have
                every test ratio printed, use THRESH = 0.
[out]A
          A is COMPLEX*16 array, dimension (LDA,NMAX)
[in]LDA
          LDA is INTEGER
                The leading dimension of the array A.  LDA >= max(1,NMAX).
[out]ARF
          ARF is COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2).
[out]B1
          B1 is COMPLEX*16 array, dimension (LDA,NMAX)
[out]B2
          B2 is COMPLEX*16 array, dimension (LDA,NMAX)
[out]D_WORK_ZLANGE
          D_WORK_ZLANGE is DOUBLE PRECISION array, dimension (NMAX)
[out]Z_WORK_ZGEQRF
          Z_WORK_ZGEQRF is COMPLEX*16 array, dimension (NMAX)
[out]TAU
          TAU is COMPLEX*16 array, dimension (NMAX)
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 117 of file zdrvrf3.f.

119*
120* -- LAPACK test routine --
121* -- LAPACK is a software package provided by Univ. of Tennessee, --
122* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
123*
124* .. Scalar Arguments ..
125 INTEGER LDA, NN, NOUT
126 DOUBLE PRECISION THRESH
127* ..
128* .. Array Arguments ..
129 INTEGER NVAL( NN )
130 DOUBLE PRECISION D_WORK_ZLANGE( * )
131 COMPLEX*16 A( LDA, * ), ARF( * ), B1( LDA, * ),
132 + B2( LDA, * )
133 COMPLEX*16 Z_WORK_ZGEQRF( * ), TAU( * )
134* ..
135*
136* =====================================================================
137* ..
138* .. Parameters ..
139 COMPLEX*16 ZERO, ONE
140 parameter( zero = ( 0.0d+0, 0.0d+0 ) ,
141 + one = ( 1.0d+0, 0.0d+0 ) )
142 INTEGER NTESTS
143 parameter( ntests = 1 )
144* ..
145* .. Local Scalars ..
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
149 COMPLEX*16 ALPHA
150 DOUBLE PRECISION EPS
151* ..
152* .. Local Arrays ..
153 CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ),
154 + DIAGS( 2 ), SIDES( 2 )
155 INTEGER ISEED( 4 ), ISEEDY( 4 )
156 DOUBLE PRECISION RESULT( NTESTS )
157* ..
158* .. External Functions ..
159 DOUBLE PRECISION DLAMCH, ZLANGE
160 COMPLEX*16 ZLARND
161 EXTERNAL dlamch, zlarnd, zlange
162* ..
163* .. External Subroutines ..
164 EXTERNAL ztrttf, zgeqrf, zgeqlf, ztfsm, ztrsm
165* ..
166* .. Intrinsic Functions ..
167 INTRINSIC max, sqrt
168* ..
169* .. Scalars in Common ..
170 CHARACTER*32 SRNAMT
171* ..
172* .. Common blocks ..
173 COMMON / srnamc / srnamt
174* ..
175* .. Data statements ..
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' /
182* ..
183* .. Executable Statements ..
184*
185* Initialize constants and the random number seed.
186*
187 nrun = 0
188 nfail = 0
189 info = 0
190 DO 10 i = 1, 4
191 iseed( i ) = iseedy( i )
192 10 CONTINUE
193 eps = dlamch( 'Precision' )
194*
195 DO 170 iim = 1, nn
196*
197 m = nval( iim )
198*
199 DO 160 iin = 1, nn
200*
201 n = nval( iin )
202*
203 DO 150 iform = 1, 2
204*
205 cform = forms( iform )
206*
207 DO 140 iuplo = 1, 2
208*
209 uplo = uplos( iuplo )
210*
211 DO 130 iside = 1, 2
212*
213 side = sides( iside )
214*
215 DO 120 itrans = 1, 2
216*
217 trans = transs( itrans )
218*
219 DO 110 idiag = 1, 2
220*
221 diag = diags( idiag )
222*
223 DO 100 ialpha = 1, 3
224*
225 IF ( ialpha.EQ. 1) THEN
226 alpha = zero
227 ELSE IF ( ialpha.EQ. 2) THEN
228 alpha = one
229 ELSE
230 alpha = zlarnd( 4, iseed )
231 END IF
232*
233* All the parameters are set:
234* CFORM, SIDE, UPLO, TRANS, DIAG, M, N,
235* and ALPHA
236* READY TO TEST!
237*
238 nrun = nrun + 1
239*
240 IF ( iside.EQ.1 ) THEN
241*
242* The case ISIDE.EQ.1 is when SIDE.EQ.'L'
243* -> A is M-by-M ( B is M-by-N )
244*
245 na = m
246*
247 ELSE
248*
249* The case ISIDE.EQ.2 is when SIDE.EQ.'R'
250* -> A is N-by-N ( B is M-by-N )
251*
252 na = n
253*
254 END IF
255*
256* Generate A our NA--by--NA triangular
257* matrix.
258* Our test is based on forward error so we
259* do want A to be well conditioned! To get
260* a well-conditioned triangular matrix, we
261* take the R factor of the QR/LQ factorization
262* of a random matrix.
263*
264 DO j = 1, na
265 DO i = 1, na
266 a( i, j) = zlarnd( 4, iseed )
267 END DO
268 END DO
269*
270 IF ( iuplo.EQ.1 ) THEN
271*
272* The case IUPLO.EQ.1 is when SIDE.EQ.'U'
273* -> QR factorization.
274*
275 srnamt = 'ZGEQRF'
276 CALL zgeqrf( na, na, a, lda, tau,
277 + z_work_zgeqrf, lda,
278 + info )
279 ELSE
280*
281* The case IUPLO.EQ.2 is when SIDE.EQ.'L'
282* -> QL factorization.
283*
284 srnamt = 'ZGELQF'
285 CALL zgelqf( na, na, a, lda, tau,
286 + z_work_zgeqrf, lda,
287 + info )
288 END IF
289*
290* After the QR factorization, the diagonal
291* of A is made of real numbers, we multiply
292* by a random complex number of absolute
293* value 1.0E+00.
294*
295 DO j = 1, na
296 a( j, j) = a(j,j) * zlarnd( 5, iseed )
297 END DO
298*
299* Store a copy of A in RFP format (in ARF).
300*
301 srnamt = 'ZTRTTF'
302 CALL ztrttf( cform, uplo, na, a, lda, arf,
303 + info )
304*
305* Generate B1 our M--by--N right-hand side
306* and store a copy in B2.
307*
308 DO j = 1, n
309 DO i = 1, m
310 b1( i, j) = zlarnd( 4, iseed )
311 b2( i, j) = b1( i, j)
312 END DO
313 END DO
314*
315* Solve op( A ) X = B or X op( A ) = B
316* with ZTRSM
317*
318 srnamt = 'ZTRSM'
319 CALL ztrsm( side, uplo, trans, diag, m, n,
320 + alpha, a, lda, b1, lda )
321*
322* Solve op( A ) X = B or X op( A ) = B
323* with ZTFSM
324*
325 srnamt = 'ZTFSM'
326 CALL ztfsm( cform, side, uplo, trans,
327 + diag, m, n, alpha, arf, b2,
328 + lda )
329*
330* Check that the result agrees.
331*
332 DO j = 1, n
333 DO i = 1, m
334 b1( i, j) = b2( i, j ) - b1( i, j )
335 END DO
336 END DO
337*
338 result(1) = zlange( 'I', m, n, b1, lda,
339 + d_work_zlange )
340*
341 result(1) = result(1) / sqrt( eps )
342 + / max( max( m, n), 1 )
343*
344 IF( result(1).GE.thresh ) THEN
345 IF( nfail.EQ.0 ) THEN
346 WRITE( nout, * )
347 WRITE( nout, fmt = 9999 )
348 END IF
349 WRITE( nout, fmt = 9997 ) 'ZTFSM',
350 + cform, side, uplo, trans, diag, m,
351 + n, result(1)
352 nfail = nfail + 1
353 END IF
354*
355 100 CONTINUE
356 110 CONTINUE
357 120 CONTINUE
358 130 CONTINUE
359 140 CONTINUE
360 150 CONTINUE
361 160 CONTINUE
362 170 CONTINUE
363*
364* Print a summary of the results.
365*
366 IF ( nfail.EQ.0 ) THEN
367 WRITE( nout, fmt = 9996 ) 'ZTFSM', nrun
368 ELSE
369 WRITE( nout, fmt = 9995 ) 'ZTFSM', nfail, nrun
370 END IF
371*
372 9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing ZTFSM
373 + ***')
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')
381*
382 RETURN
383*
384* End of ZDRVRF3
385*
dlamch
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:69
ztrsm
subroutine ztrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
ZTRSM
Definition: ztrsm.f:180
zlarnd
complex *16 function zlarnd(IDIST, ISEED)
ZLARND
Definition: zlarnd.f:75
zlange
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 ...
Definition: zlange.f:115
zgelqf
subroutine zgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
ZGELQF
Definition: zgelqf.f:143
zgeqlf
subroutine zgeqlf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
ZGEQLF
Definition: zgeqlf.f:138
ztfsm
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).
Definition: ztfsm.f:298
ztrttf
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...
Definition: ztrttf.f:216
zgeqrf
subroutine zgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
ZGEQRF VARIANT: left-looking Level 3 BLAS of the algorithm.
Definition: zgeqrf.f:152
Here is the call graph for this function:
Here is the caller graph for this function: