LAPACK 3.11.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
zdrvrf3.f
Go to the documentation of this file.
1*> \brief \b ZDRVRF3
2*
3* =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6* http://www.netlib.org/lapack/explore-html/
7*
8* Definition:
9* ===========
10*
11* SUBROUTINE ZDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
12* + D_WORK_ZLANGE, Z_WORK_ZGEQRF, TAU )
13*
14* .. Scalar Arguments ..
15* INTEGER LDA, NN, NOUT
16* DOUBLE PRECISION THRESH
17* ..
18* .. Array Arguments ..
19* INTEGER NVAL( NN )
20* DOUBLE PRECISION D_WORK_ZLANGE( * )
21* COMPLEX*16 A( LDA, * ), ARF( * ), B1( LDA, * ),
22* + B2( LDA, * )
23* COMPLEX*16 Z_WORK_ZGEQRF( * ), TAU( * )
24* ..
25*
26*
27*> \par Purpose:
28* =============
29*>
30*> \verbatim
31*>
32*> ZDRVRF3 tests the LAPACK RFP routines:
33*> ZTFSM
34*> \endverbatim
35*
36* Arguments:
37* ==========
38*
39*> \param[in] NOUT
40*> \verbatim
41*> NOUT is INTEGER
42*> The unit number for output.
43*> \endverbatim
44*>
45*> \param[in] NN
46*> \verbatim
47*> NN is INTEGER
48*> The number of values of N contained in the vector NVAL.
49*> \endverbatim
50*>
51*> \param[in] NVAL
52*> \verbatim
53*> NVAL is INTEGER array, dimension (NN)
54*> The values of the matrix dimension N.
55*> \endverbatim
56*>
57*> \param[in] THRESH
58*> \verbatim
59*> THRESH is DOUBLE PRECISION
60*> The threshold value for the test ratios. A result is
61*> included in the output file if RESULT >= THRESH. To have
62*> every test ratio printed, use THRESH = 0.
63*> \endverbatim
64*>
65*> \param[out] A
66*> \verbatim
67*> A is COMPLEX*16 array, dimension (LDA,NMAX)
68*> \endverbatim
69*>
70*> \param[in] LDA
71*> \verbatim
72*> LDA is INTEGER
73*> The leading dimension of the array A. LDA >= max(1,NMAX).
74*> \endverbatim
75*>
76*> \param[out] ARF
77*> \verbatim
78*> ARF is COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2).
79*> \endverbatim
80*>
81*> \param[out] B1
82*> \verbatim
83*> B1 is COMPLEX*16 array, dimension (LDA,NMAX)
84*> \endverbatim
85*>
86*> \param[out] B2
87*> \verbatim
88*> B2 is COMPLEX*16 array, dimension (LDA,NMAX)
89*> \endverbatim
90*>
91*> \param[out] D_WORK_ZLANGE
92*> \verbatim
93*> D_WORK_ZLANGE is DOUBLE PRECISION array, dimension (NMAX)
94*> \endverbatim
95*>
96*> \param[out] Z_WORK_ZGEQRF
97*> \verbatim
98*> Z_WORK_ZGEQRF is COMPLEX*16 array, dimension (NMAX)
99*> \endverbatim
100*>
101*> \param[out] TAU
102*> \verbatim
103*> TAU is COMPLEX*16 array, dimension (NMAX)
104*> \endverbatim
105*
106* Authors:
107* ========
108*
109*> \author Univ. of Tennessee
110*> \author Univ. of California Berkeley
111*> \author Univ. of Colorado Denver
112*> \author NAG Ltd.
113*
114*> \ingroup complex16_lin
115*
116* =====================================================================
117 SUBROUTINE zdrvrf3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
118 + D_WORK_ZLANGE, Z_WORK_ZGEQRF, TAU )
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*
386 END
subroutine ztrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
ZTRSM
Definition: ztrsm.f:180
subroutine zdrvrf3(NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, D_WORK_ZLANGE, Z_WORK_ZGEQRF, TAU)
ZDRVRF3
Definition: zdrvrf3.f:119
subroutine zgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
ZGELQF
Definition: zgelqf.f:143
subroutine zgeqlf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
ZGEQLF
Definition: zgeqlf.f:138
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
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
subroutine zgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
ZGEQRF VARIANT: left-looking Level 3 BLAS of the algorithm.
Definition: zgeqrf.f:152