LAPACK 3.12.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 LOGICAL LSAME
160 DOUBLE PRECISION DLAMCH, ZLANGE
161 COMPLEX*16 ZLARND
162 EXTERNAL dlamch, zlarnd, zlange, lsame
163* ..
164* .. External Subroutines ..
165 EXTERNAL ztrttf, zgeqrf, zgeqlf, ztfsm, ztrsm
166* ..
167* .. Intrinsic Functions ..
168 INTRINSIC max, sqrt
169* ..
170* .. Scalars in Common ..
171 CHARACTER*32 SRNAMT
172* ..
173* .. Common blocks ..
174 COMMON / srnamc / srnamt
175* ..
176* .. Data statements ..
177 DATA iseedy / 1988, 1989, 1990, 1991 /
178 DATA uplos / 'U', 'L' /
179 DATA forms / 'N', 'C' /
180 DATA sides / 'L', 'R' /
181 DATA transs / 'N', 'C' /
182 DATA diags / 'N', 'U' /
183* ..
184* .. Executable Statements ..
185*
186* Initialize constants and the random number seed.
187*
188 nrun = 0
189 nfail = 0
190 info = 0
191 DO 10 i = 1, 4
192 iseed( i ) = iseedy( i )
193 10 CONTINUE
194 eps = dlamch( 'Precision' )
195*
196 DO 170 iim = 1, nn
197*
198 m = nval( iim )
199*
200 DO 160 iin = 1, nn
201*
202 n = nval( iin )
203*
204 DO 150 iform = 1, 2
205*
206 cform = forms( iform )
207*
208 DO 140 iuplo = 1, 2
209*
210 uplo = uplos( iuplo )
211*
212 DO 130 iside = 1, 2
213*
214 side = sides( iside )
215*
216 DO 120 itrans = 1, 2
217*
218 trans = transs( itrans )
219*
220 DO 110 idiag = 1, 2
221*
222 diag = diags( idiag )
223*
224 DO 100 ialpha = 1, 3
225*
226 IF ( ialpha.EQ.1 ) THEN
227 alpha = zero
228 ELSE IF ( ialpha.EQ.2 ) THEN
229 alpha = one
230 ELSE
231 alpha = zlarnd( 4, iseed )
232 END IF
233*
234* All the parameters are set:
235* CFORM, SIDE, UPLO, TRANS, DIAG, M, N,
236* and ALPHA
237* READY TO TEST!
238*
239 nrun = nrun + 1
240*
241 IF ( iside.EQ.1 ) THEN
242*
243* The case ISIDE.EQ.1 is when SIDE.EQ.'L'
244* -> A is M-by-M ( B is M-by-N )
245*
246 na = m
247*
248 ELSE
249*
250* The case ISIDE.EQ.2 is when SIDE.EQ.'R'
251* -> A is N-by-N ( B is M-by-N )
252*
253 na = n
254*
255 END IF
256*
257* Generate A our NA--by--NA triangular
258* matrix.
259* Our test is based on forward error so we
260* do want A to be well conditioned! To get
261* a well-conditioned triangular matrix, we
262* take the R factor of the QR/LQ factorization
263* of a random matrix.
264*
265 DO j = 1, na
266 DO i = 1, na
267 a( i, j ) = zlarnd( 4, iseed )
268 END DO
269 END DO
270*
271 IF ( iuplo.EQ.1 ) THEN
272*
273* The case IUPLO.EQ.1 is when SIDE.EQ.'U'
274* -> QR factorization.
275*
276 srnamt = 'ZGEQRF'
277 CALL zgeqrf( na, na, a, lda, tau,
278 + z_work_zgeqrf, lda,
279 + info )
280*
281* Forcing main diagonal of test matrix to
282* be unit makes it ill-conditioned for
283* some test cases
284*
285 IF ( lsame( diag, 'U' ) ) THEN
286 DO j = 1, na
287 DO i = 1, j
288 a( i, j ) = a( i, j ) /
289 + ( 2.0 * a( j, j ) )
290 END DO
291 END DO
292 END IF
293*
294 ELSE
295*
296* The case IUPLO.EQ.2 is when SIDE.EQ.'L'
297* -> QL factorization.
298*
299 srnamt = 'ZGELQF'
300 CALL zgelqf( na, na, a, lda, tau,
301 + z_work_zgeqrf, lda,
302 + info )
303*
304* Forcing main diagonal of test matrix to
305* be unit makes it ill-conditioned for
306* some test cases
307*
308 IF ( lsame( diag, 'U' ) ) THEN
309 DO i = 1, na
310 DO j = 1, i
311 a( i, j ) = a( i, j ) /
312 + ( 2.0 * a( i, i ) )
313 END DO
314 END DO
315 END IF
316*
317 END IF
318*
319* After the QR factorization, the diagonal
320* of A is made of real numbers, we multiply
321* by a random complex number of absolute
322* value 1.0E+00.
323*
324 DO j = 1, na
325 a( j, j ) = a( j, j ) *
326 + zlarnd( 5, iseed )
327 END DO
328*
329* Store a copy of A in RFP format (in ARF).
330*
331 srnamt = 'ZTRTTF'
332 CALL ztrttf( cform, uplo, na, a, lda, arf,
333 + info )
334*
335* Generate B1 our M--by--N right-hand side
336* and store a copy in B2.
337*
338 DO j = 1, n
339 DO i = 1, m
340 b1( i, j ) = zlarnd( 4, iseed )
341 b2( i, j ) = b1( i, j )
342 END DO
343 END DO
344*
345* Solve op( A ) X = B or X op( A ) = B
346* with ZTRSM
347*
348 srnamt = 'ZTRSM'
349 CALL ztrsm( side, uplo, trans, diag, m, n,
350 + alpha, a, lda, b1, lda )
351*
352* Solve op( A ) X = B or X op( A ) = B
353* with ZTFSM
354*
355 srnamt = 'ZTFSM'
356 CALL ztfsm( cform, side, uplo, trans,
357 + diag, m, n, alpha, arf, b2,
358 + lda )
359*
360* Check that the result agrees.
361*
362 DO j = 1, n
363 DO i = 1, m
364 b1( i, j ) = b2( i, j ) - b1( i, j )
365 END DO
366 END DO
367*
368 result( 1 ) = zlange( 'I', m, n, b1, lda,
369 + d_work_zlange )
370*
371 result( 1 ) = result( 1 ) / sqrt( eps )
372 + / max( max( m, n ), 1 )
373*
374 IF( result( 1 ).GE.thresh ) THEN
375 IF( nfail.EQ.0 ) THEN
376 WRITE( nout, * )
377 WRITE( nout, fmt = 9999 )
378 END IF
379 WRITE( nout, fmt = 9997 ) 'ZTFSM',
380 + cform, side, uplo, trans, diag, m,
381 + n, result( 1 )
382 nfail = nfail + 1
383 END IF
384*
385 100 CONTINUE
386 110 CONTINUE
387 120 CONTINUE
388 130 CONTINUE
389 140 CONTINUE
390 150 CONTINUE
391 160 CONTINUE
392 170 CONTINUE
393*
394* Print a summary of the results.
395*
396 IF ( nfail.EQ.0 ) THEN
397 WRITE( nout, fmt = 9996 ) 'ZTFSM', nrun
398 ELSE
399 WRITE( nout, fmt = 9995 ) 'ZTFSM', nfail, nrun
400 END IF
401*
402 9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing ZTFSM
403 + ***')
404 9997 FORMAT( 1x, ' Failure in ',a5,', CFORM=''',a1,''',',
405 + ' SIDE=''',a1,''',',' UPLO=''',a1,''',',' TRANS=''',a1,''',',
406 + ' DIAG=''',a1,''',',' M=',i3,', N =', i3,', test=',g12.5)
407 9996 FORMAT( 1x, 'All tests for ',a5,' auxiliary routine passed the ',
408 + 'threshold ( ',i5,' tests run)')
409 9995 FORMAT( 1x, a6, ' auxiliary routine:',i5,' out of ',i5,
410 + ' tests failed to pass the threshold')
411*
412 RETURN
413*
414* End of ZDRVRF3
415*
416 END
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 zgeqrf(m, n, a, lda, tau, work, lwork, info)
ZGEQRF
Definition zgeqrf.f:146
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 ztrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
ZTRSM
Definition ztrsm.f:180
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 zdrvrf3(nout, nn, nval, thresh, a, lda, arf, b1, b2, d_work_zlange, z_work_zgeqrf, tau)
ZDRVRF3
Definition zdrvrf3.f:119