LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
zdrvac.f
Go to the documentation of this file.
1 *> \brief \b ZDRVAC
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 ZDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX,
12 * A, AFAC, B, X, WORK,
13 * RWORK, SWORK, NOUT )
14 *
15 * .. Scalar Arguments ..
16 * INTEGER NMAX, NM, NNS, NOUT
17 * DOUBLE PRECISION THRESH
18 * ..
19 * .. Array Arguments ..
20 * LOGICAL DOTYPE( * )
21 * INTEGER MVAL( * ), NSVAL( * )
22 * DOUBLE PRECISION RWORK( * )
23 * COMPLEX SWORK(*)
24 * COMPLEX*16 A( * ), AFAC( * ), B( * ),
25 * $ WORK( * ), X( * )
26 * ..
27 *
28 *
29 *> \par Purpose:
30 * =============
31 *>
32 *> \verbatim
33 *>
34 *> ZDRVAC tests ZCPOSV.
35 *> \endverbatim
36 *
37 * Arguments:
38 * ==========
39 *
40 *> \param[in] DOTYPE
41 *> \verbatim
42 *> DOTYPE is LOGICAL array, dimension (NTYPES)
43 *> The matrix types to be used for testing. Matrices of type j
44 *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
45 *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
46 *> \endverbatim
47 *>
48 *> \param[in] NM
49 *> \verbatim
50 *> NM is INTEGER
51 *> The number of values of N contained in the vector MVAL.
52 *> \endverbatim
53 *>
54 *> \param[in] MVAL
55 *> \verbatim
56 *> MVAL is INTEGER array, dimension (NM)
57 *> The values of the matrix dimension N.
58 *> \endverbatim
59 *>
60 *> \param[in] NNS
61 *> \verbatim
62 *> NNS is INTEGER
63 *> The number of values of NRHS contained in the vector NSVAL.
64 *> \endverbatim
65 *>
66 *> \param[in] NSVAL
67 *> \verbatim
68 *> NSVAL is INTEGER array, dimension (NNS)
69 *> The values of the number of right hand sides NRHS.
70 *> \endverbatim
71 *>
72 *> \param[in] THRESH
73 *> \verbatim
74 *> THRESH is DOUBLE PRECISION
75 *> The threshold value for the test ratios. A result is
76 *> included in the output file if RESULT >= THRESH. To have
77 *> every test ratio printed, use THRESH = 0.
78 *> \endverbatim
79 *>
80 *> \param[in] NMAX
81 *> \verbatim
82 *> NMAX is INTEGER
83 *> The maximum value permitted for N, used in dimensioning the
84 *> work arrays.
85 *> \endverbatim
86 *>
87 *> \param[out] A
88 *> \verbatim
89 *> A is COMPLEX*16 array, dimension (NMAX*NMAX)
90 *> \endverbatim
91 *>
92 *> \param[out] AFAC
93 *> \verbatim
94 *> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
95 *> \endverbatim
96 *>
97 *> \param[out] B
98 *> \verbatim
99 *> B is COMPLEX*16 array, dimension (NMAX*NSMAX)
100 *> \endverbatim
101 *>
102 *> \param[out] X
103 *> \verbatim
104 *> X is COMPLEX*16 array, dimension (NMAX*NSMAX)
105 *> \endverbatim
106 *>
107 *> \param[out] WORK
108 *> \verbatim
109 *> WORK is COMPLEX*16 array, dimension
110 *> (NMAX*max(3,NSMAX))
111 *> \endverbatim
112 *>
113 *> \param[out] RWORK
114 *> \verbatim
115 *> RWORK is DOUBLE PRECISION array, dimension
116 *> (max(2*NMAX,2*NSMAX+NWORK))
117 *> \endverbatim
118 *>
119 *> \param[out] SWORK
120 *> \verbatim
121 *> SWORK is COMPLEX array, dimension
122 *> (NMAX*(NSMAX+NMAX))
123 *> \endverbatim
124 *>
125 *> \param[in] NOUT
126 *> \verbatim
127 *> NOUT is INTEGER
128 *> The unit number for output.
129 *> \endverbatim
130 *
131 * Authors:
132 * ========
133 *
134 *> \author Univ. of Tennessee
135 *> \author Univ. of California Berkeley
136 *> \author Univ. of Colorado Denver
137 *> \author NAG Ltd.
138 *
139 *> \date November 2011
140 *
141 *> \ingroup complex16_lin
142 *
143 * =====================================================================
144  SUBROUTINE zdrvac( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX,
145  $ a, afac, b, x, work,
146  $ rwork, swork, nout )
147 *
148 * -- LAPACK test routine (version 3.4.0) --
149 * -- LAPACK is a software package provided by Univ. of Tennessee, --
150 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
151 * November 2011
152 *
153 * .. Scalar Arguments ..
154  INTEGER nmax, nm, nns, nout
155  DOUBLE PRECISION thresh
156 * ..
157 * .. Array Arguments ..
158  LOGICAL dotype( * )
159  INTEGER mval( * ), nsval( * )
160  DOUBLE PRECISION rwork( * )
161  COMPLEX swork(*)
162  COMPLEX*16 a( * ), afac( * ), b( * ),
163  $ work( * ), x( * )
164 * ..
165 *
166 * =====================================================================
167 *
168 * .. Parameters ..
169  DOUBLE PRECISION zero
170  parameter( zero = 0.0d+0 )
171  INTEGER ntypes
172  parameter( ntypes = 9 )
173  INTEGER ntests
174  parameter( ntests = 1 )
175 * ..
176 * .. Local Scalars ..
177  LOGICAL zerot
178  CHARACTER dist, type, uplo, xtype
179  CHARACTER*3 path
180  INTEGER i, im, imat, info, ioff, irhs, iuplo,
181  $ izero, kl, ku, lda, mode, n,
182  $ nerrs, nfail, nimat, nrhs, nrun
183  DOUBLE PRECISION anorm, cndnum
184 * ..
185 * .. Local Arrays ..
186  CHARACTER uplos( 2 )
187  INTEGER iseed( 4 ), iseedy( 4 )
188  DOUBLE PRECISION result( ntests )
189 * ..
190 * .. Local Variables ..
191  INTEGER iter, kase
192 * ..
193 * .. External Subroutines ..
194  EXTERNAL alaerh, zlacpy, zlaipd,
195  $ zlarhs, zlatb4, zlatms,
196  $ zpot06, zcposv
197 * ..
198 * .. Intrinsic Functions ..
199  INTRINSIC dble, max, sqrt
200 * ..
201 * .. Scalars in Common ..
202  LOGICAL lerr, ok
203  CHARACTER*32 srnamt
204  INTEGER infot, nunit
205 * ..
206 * .. Common blocks ..
207  common / infoc / infot, nunit, ok, lerr
208  common / srnamc / srnamt
209 * ..
210 * .. Data statements ..
211  DATA iseedy / 1988, 1989, 1990, 1991 /
212  DATA uplos / 'U', 'L' /
213 * ..
214 * .. Executable Statements ..
215 *
216 * Initialize constants and the random number seed.
217 *
218  kase = 0
219  path( 1: 1 ) = 'Zomplex precision'
220  path( 2: 3 ) = 'PO'
221  nrun = 0
222  nfail = 0
223  nerrs = 0
224  DO 10 i = 1, 4
225  iseed( i ) = iseedy( i )
226  10 continue
227 *
228  infot = 0
229 *
230 * Do for each value of N in MVAL
231 *
232  DO 120 im = 1, nm
233  n = mval( im )
234  lda = max( n, 1 )
235  nimat = ntypes
236  IF( n.LE.0 )
237  $ nimat = 1
238 *
239  DO 110 imat = 1, nimat
240 *
241 * Do the tests only if DOTYPE( IMAT ) is true.
242 *
243  IF( .NOT.dotype( imat ) )
244  $ go to 110
245 *
246 * Skip types 3, 4, or 5 if the matrix size is too small.
247 *
248  zerot = imat.GE.3 .AND. imat.LE.5
249  IF( zerot .AND. n.LT.imat-2 )
250  $ go to 110
251 *
252 * Do first for UPLO = 'U', then for UPLO = 'L'
253 *
254  DO 100 iuplo = 1, 2
255  uplo = uplos( iuplo )
256 *
257 * Set up parameters with ZLATB4 and generate a test matrix
258 * with ZLATMS.
259 *
260  CALL zlatb4( path, imat, n, n, type, kl, ku, anorm, mode,
261  $ cndnum, dist )
262 *
263  srnamt = 'ZLATMS'
264  CALL zlatms( n, n, dist, iseed, type, rwork, mode,
265  $ cndnum, anorm, kl, ku, uplo, a, lda, work,
266  $ info )
267 *
268 * Check error code from ZLATMS.
269 *
270  IF( info.NE.0 ) THEN
271  CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n, -1,
272  $ -1, -1, imat, nfail, nerrs, nout )
273  go to 100
274  END IF
275 *
276 * For types 3-5, zero one row and column of the matrix to
277 * test that INFO is returned correctly.
278 *
279  IF( zerot ) THEN
280  IF( imat.EQ.3 ) THEN
281  izero = 1
282  ELSE IF( imat.EQ.4 ) THEN
283  izero = n
284  ELSE
285  izero = n / 2 + 1
286  END IF
287  ioff = ( izero-1 )*lda
288 *
289 * Set row and column IZERO of A to 0.
290 *
291  IF( iuplo.EQ.1 ) THEN
292  DO 20 i = 1, izero - 1
293  a( ioff+i ) = zero
294  20 continue
295  ioff = ioff + izero
296  DO 30 i = izero, n
297  a( ioff ) = zero
298  ioff = ioff + lda
299  30 continue
300  ELSE
301  ioff = izero
302  DO 40 i = 1, izero - 1
303  a( ioff ) = zero
304  ioff = ioff + lda
305  40 continue
306  ioff = ioff - izero
307  DO 50 i = izero, n
308  a( ioff+i ) = zero
309  50 continue
310  END IF
311  ELSE
312  izero = 0
313  END IF
314 *
315 * Set the imaginary part of the diagonals.
316 *
317  CALL zlaipd( n, a, lda+1, 0 )
318 *
319  DO 60 irhs = 1, nns
320  nrhs = nsval( irhs )
321  xtype = 'N'
322 *
323 * Form an exact solution and set the right hand side.
324 *
325  srnamt = 'ZLARHS'
326  CALL zlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
327  $ nrhs, a, lda, x, lda, b, lda,
328  $ iseed, info )
329 *
330 * Compute the L*L' or U'*U factorization of the
331 * matrix and solve the system.
332 *
333  srnamt = 'ZCPOSV '
334  kase = kase + 1
335 *
336  CALL zlacpy( 'All', n, n, a, lda, afac, lda)
337 *
338  CALL zcposv( uplo, n, nrhs, afac, lda, b, lda, x, lda,
339  $ work, swork, rwork, iter, info )
340 *
341  IF (iter.LT.0) THEN
342  CALL zlacpy( 'All', n, n, a, lda, afac, lda )
343  ENDIF
344 *
345 * Check error code from ZCPOSV .
346 *
347  IF( info.NE.izero ) THEN
348 *
349  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
350  $ CALL alahd( nout, path )
351  nerrs = nerrs + 1
352 *
353  IF( info.NE.izero .AND. izero.NE.0 ) THEN
354  WRITE( nout, fmt = 9988 )'ZCPOSV',info,izero,n,
355  $ imat
356  ELSE
357  WRITE( nout, fmt = 9975 )'ZCPOSV',info,n,imat
358  END IF
359  END IF
360 *
361 * Skip the remaining test if the matrix is singular.
362 *
363  IF( info.NE.0 )
364  $ go to 110
365 *
366 * Check the quality of the solution
367 *
368  CALL zlacpy( 'All', n, nrhs, b, lda, work, lda )
369 *
370  CALL zpot06( uplo, n, nrhs, a, lda, x, lda, work,
371  $ lda, rwork, result( 1 ) )
372 *
373 * Check if the test passes the tesing.
374 * Print information about the tests that did not
375 * pass the testing.
376 *
377 * If iterative refinement has been used and claimed to
378 * be successful (ITER>0), we want
379 * NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS*SRQT(N)) < 1
380 *
381 * If double precision has been used (ITER<0), we want
382 * NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS) < THRES
383 * (Cf. the linear solver testing routines)
384 *
385  IF ((thresh.LE.0.0e+00)
386  $ .OR.((iter.GE.0).AND.(n.GT.0)
387  $ .AND.(result(1).GE.sqrt(dble(n))))
388  $ .OR.((iter.LT.0).AND.(result(1).GE.thresh))) THEN
389 *
390  IF( nfail.EQ.0 .AND. nerrs.EQ.0 ) THEN
391  WRITE( nout, fmt = 8999 )'ZPO'
392  WRITE( nout, fmt = '( '' Matrix types:'' )' )
393  WRITE( nout, fmt = 8979 )
394  WRITE( nout, fmt = '( '' Test ratios:'' )' )
395  WRITE( nout, fmt = 8960 )1
396  WRITE( nout, fmt = '( '' Messages:'' )' )
397  END IF
398 *
399  WRITE( nout, fmt = 9998 )uplo, n, nrhs, imat, 1,
400  $ result( 1 )
401 *
402  nfail = nfail + 1
403 *
404  END IF
405 *
406  nrun = nrun + 1
407 *
408  60 continue
409  100 continue
410  110 continue
411  120 continue
412 *
413 * Print a summary of the results.
414 *
415  IF( nfail.GT.0 ) THEN
416  WRITE( nout, fmt = 9996 )'ZCPOSV', nfail, nrun
417  ELSE
418  WRITE( nout, fmt = 9995 )'ZCPOSV', nrun
419  END IF
420  IF( nerrs.GT.0 ) THEN
421  WRITE( nout, fmt = 9994 )nerrs
422  END IF
423 *
424  9998 format( ' UPLO=''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
425  $ i2, ', test(', i2, ') =', g12.5 )
426  9996 format( 1x, a6, ': ', i6, ' out of ', i6,
427  $ ' tests failed to pass the threshold' )
428  9995 format( /1x, 'All tests for ', a6,
429  $ ' routines passed the threshold ( ', i6, ' tests run)' )
430  9994 format( 6x, i6, ' error messages recorded' )
431 *
432 * SUBNAM, INFO, INFOE, N, IMAT
433 *
434  9988 format( ' *** ', a6, ' returned with INFO =', i5, ' instead of ',
435  $ i5, / ' ==> N =', i5, ', type ',
436  $ i2 )
437 *
438 * SUBNAM, INFO, N, IMAT
439 *
440  9975 format( ' *** Error code from ', a6, '=', i5, ' for M=', i5,
441  $ ', type ', i2 )
442  8999 format( / 1x, a3, ': positive definite dense matrices' )
443  8979 format( 4x, '1. Diagonal', 24x, '7. Last n/2 columns zero', / 4x,
444  $ '2. Upper triangular', 16x,
445  $ '8. Random, CNDNUM = sqrt(0.1/EPS)', / 4x,
446  $ '3. Lower triangular', 16x, '9. Random, CNDNUM = 0.1/EPS',
447  $ / 4x, '4. Random, CNDNUM = 2', 13x,
448  $ '10. Scaled near underflow', / 4x, '5. First column zero',
449  $ 14x, '11. Scaled near overflow', / 4x,
450  $ '6. Last column zero' )
451  8960 format( 3x, i2, ': norm_1( B - A * X ) / ',
452  $ '( norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF',
453  $ / 4x, 'or norm_1( B - A * X ) / ',
454  $ '( norm_1(A) * norm_1(X) * EPS ) > THRES if ZPOTRF' )
455 
456  return
457 *
458 * End of ZDRVAC
459 *
460  END