LAPACK  3.10.1
LAPACK: Linear Algebra PACKage
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:151