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