LAPACK  3.10.0
LAPACK: Linear Algebra PACKage
cchkpp.f
Go to the documentation of this file.
1 *> \brief \b CCHKPP
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 CCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
12 * NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK,
13 * NOUT )
14 *
15 * .. Scalar Arguments ..
16 * LOGICAL TSTERR
17 * INTEGER NMAX, NN, NNS, NOUT
18 * REAL THRESH
19 * ..
20 * .. Array Arguments ..
21 * LOGICAL DOTYPE( * )
22 * INTEGER NSVAL( * ), NVAL( * )
23 * REAL RWORK( * )
24 * COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
25 * $ WORK( * ), X( * ), XACT( * )
26 * ..
27 *
28 *
29 *> \par Purpose:
30 * =============
31 *>
32 *> \verbatim
33 *>
34 *> CCHKPP tests CPPTRF, -TRI, -TRS, -RFS, and -CON
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] NN
49 *> \verbatim
50 *> NN is INTEGER
51 *> The number of values of N contained in the vector NVAL.
52 *> \endverbatim
53 *>
54 *> \param[in] NVAL
55 *> \verbatim
56 *> NVAL is INTEGER array, dimension (NN)
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 REAL
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] TSTERR
81 *> \verbatim
82 *> TSTERR is LOGICAL
83 *> Flag that indicates whether error exits are to be tested.
84 *> \endverbatim
85 *>
86 *> \param[in] NMAX
87 *> \verbatim
88 *> NMAX is INTEGER
89 *> The maximum value permitted for N, used in dimensioning the
90 *> work arrays.
91 *> \endverbatim
92 *>
93 *> \param[out] A
94 *> \verbatim
95 *> A is COMPLEX array, dimension
96 *> (NMAX*(NMAX+1)/2)
97 *> \endverbatim
98 *>
99 *> \param[out] AFAC
100 *> \verbatim
101 *> AFAC is COMPLEX array, dimension
102 *> (NMAX*(NMAX+1)/2)
103 *> \endverbatim
104 *>
105 *> \param[out] AINV
106 *> \verbatim
107 *> AINV is COMPLEX array, dimension
108 *> (NMAX*(NMAX+1)/2)
109 *> \endverbatim
110 *>
111 *> \param[out] B
112 *> \verbatim
113 *> B is COMPLEX array, dimension (NMAX*NSMAX)
114 *> where NSMAX is the largest entry in NSVAL.
115 *> \endverbatim
116 *>
117 *> \param[out] X
118 *> \verbatim
119 *> X is COMPLEX array, dimension (NMAX*NSMAX)
120 *> \endverbatim
121 *>
122 *> \param[out] XACT
123 *> \verbatim
124 *> XACT is COMPLEX array, dimension (NMAX*NSMAX)
125 *> \endverbatim
126 *>
127 *> \param[out] WORK
128 *> \verbatim
129 *> WORK is COMPLEX array, dimension
130 *> (NMAX*max(3,NSMAX))
131 *> \endverbatim
132 *>
133 *> \param[out] RWORK
134 *> \verbatim
135 *> RWORK is REAL array, dimension
136 *> (max(NMAX,2*NSMAX))
137 *> \endverbatim
138 *>
139 *> \param[in] NOUT
140 *> \verbatim
141 *> NOUT is INTEGER
142 *> The unit number for output.
143 *> \endverbatim
144 *
145 * Authors:
146 * ========
147 *
148 *> \author Univ. of Tennessee
149 *> \author Univ. of California Berkeley
150 *> \author Univ. of Colorado Denver
151 *> \author NAG Ltd.
152 *
153 *> \ingroup complex_lin
154 *
155 * =====================================================================
156  SUBROUTINE cchkpp( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
157  $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK,
158  $ NOUT )
159 *
160 * -- LAPACK test routine --
161 * -- LAPACK is a software package provided by Univ. of Tennessee, --
162 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
163 *
164 * .. Scalar Arguments ..
165  LOGICAL TSTERR
166  INTEGER NMAX, NN, NNS, NOUT
167  REAL THRESH
168 * ..
169 * .. Array Arguments ..
170  LOGICAL DOTYPE( * )
171  INTEGER NSVAL( * ), NVAL( * )
172  REAL RWORK( * )
173  COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
174  $ work( * ), x( * ), xact( * )
175 * ..
176 *
177 * =====================================================================
178 *
179 * .. Parameters ..
180  REAL ZERO
181  PARAMETER ( ZERO = 0.0e+0 )
182  INTEGER NTYPES
183  parameter( ntypes = 9 )
184  INTEGER NTESTS
185  parameter( ntests = 8 )
186 * ..
187 * .. Local Scalars ..
188  LOGICAL ZEROT
189  CHARACTER DIST, PACKIT, TYPE, UPLO, XTYPE
190  CHARACTER*3 PATH
191  INTEGER I, IMAT, IN, INFO, IOFF, IRHS, IUPLO, IZERO, K,
192  $ kl, ku, lda, mode, n, nerrs, nfail, nimat, npp,
193  $ nrhs, nrun
194  REAL ANORM, CNDNUM, RCOND, RCONDC
195 * ..
196 * .. Local Arrays ..
197  CHARACTER PACKS( 2 ), UPLOS( 2 )
198  INTEGER ISEED( 4 ), ISEEDY( 4 )
199  REAL RESULT( NTESTS )
200 * ..
201 * .. External Functions ..
202  REAL CLANHP, SGET06
203  EXTERNAL CLANHP, SGET06
204 * ..
205 * .. External Subroutines ..
206  EXTERNAL alaerh, alahd, alasum, ccopy, cerrpo, cget04,
209  $ cpptri, cpptrs
210 * ..
211 * .. Scalars in Common ..
212  LOGICAL LERR, OK
213  CHARACTER*32 SRNAMT
214  INTEGER INFOT, NUNIT
215 * ..
216 * .. Common blocks ..
217  COMMON / infoc / infot, nunit, ok, lerr
218  COMMON / srnamc / srnamt
219 * ..
220 * .. Intrinsic Functions ..
221  INTRINSIC max
222 * ..
223 * .. Data statements ..
224  DATA iseedy / 1988, 1989, 1990, 1991 /
225  DATA uplos / 'U', 'L' / , packs / 'C', 'R' /
226 * ..
227 * .. Executable Statements ..
228 *
229 * Initialize constants and the random number seed.
230 *
231  path( 1: 1 ) = 'Complex precision'
232  path( 2: 3 ) = 'PP'
233  nrun = 0
234  nfail = 0
235  nerrs = 0
236  DO 10 i = 1, 4
237  iseed( i ) = iseedy( i )
238  10 CONTINUE
239 *
240 * Test the error exits
241 *
242  IF( tsterr )
243  $ CALL cerrpo( path, nout )
244  infot = 0
245 *
246 * Do for each value of N in NVAL
247 *
248  DO 110 in = 1, nn
249  n = nval( in )
250  lda = max( n, 1 )
251  xtype = 'N'
252  nimat = ntypes
253  IF( n.LE.0 )
254  $ nimat = 1
255 *
256  DO 100 imat = 1, nimat
257 *
258 * Do the tests only if DOTYPE( IMAT ) is true.
259 *
260  IF( .NOT.dotype( imat ) )
261  $ GO TO 100
262 *
263 * Skip types 3, 4, or 5 if the matrix size is too small.
264 *
265  zerot = imat.GE.3 .AND. imat.LE.5
266  IF( zerot .AND. n.LT.imat-2 )
267  $ GO TO 100
268 *
269 * Do first for UPLO = 'U', then for UPLO = 'L'
270 *
271  DO 90 iuplo = 1, 2
272  uplo = uplos( iuplo )
273  packit = packs( iuplo )
274 *
275 * Set up parameters with CLATB4 and generate a test matrix
276 * with CLATMS.
277 *
278  CALL clatb4( path, imat, n, n, TYPE, kl, ku, anorm, mode,
279  $ cndnum, dist )
280 *
281  srnamt = 'CLATMS'
282  CALL clatms( n, n, dist, iseed, TYPE, rwork, mode,
283  $ cndnum, anorm, kl, ku, packit, a, lda, work,
284  $ info )
285 *
286 * Check error code from CLATMS.
287 *
288  IF( info.NE.0 ) THEN
289  CALL alaerh( path, 'CLATMS', info, 0, uplo, n, n, -1,
290  $ -1, -1, imat, nfail, nerrs, nout )
291  GO TO 90
292  END IF
293 *
294 * For types 3-5, zero one row and column of the matrix to
295 * test that INFO is returned correctly.
296 *
297  IF( zerot ) THEN
298  IF( imat.EQ.3 ) THEN
299  izero = 1
300  ELSE IF( imat.EQ.4 ) THEN
301  izero = n
302  ELSE
303  izero = n / 2 + 1
304  END IF
305 *
306 * Set row and column IZERO of A to 0.
307 *
308  IF( iuplo.EQ.1 ) THEN
309  ioff = ( izero-1 )*izero / 2
310  DO 20 i = 1, izero - 1
311  a( ioff+i ) = zero
312  20 CONTINUE
313  ioff = ioff + izero
314  DO 30 i = izero, n
315  a( ioff ) = zero
316  ioff = ioff + i
317  30 CONTINUE
318  ELSE
319  ioff = izero
320  DO 40 i = 1, izero - 1
321  a( ioff ) = zero
322  ioff = ioff + n - i
323  40 CONTINUE
324  ioff = ioff - izero
325  DO 50 i = izero, n
326  a( ioff+i ) = zero
327  50 CONTINUE
328  END IF
329  ELSE
330  izero = 0
331  END IF
332 *
333 * Set the imaginary part of the diagonals.
334 *
335  IF( iuplo.EQ.1 ) THEN
336  CALL claipd( n, a, 2, 1 )
337  ELSE
338  CALL claipd( n, a, n, -1 )
339  END IF
340 *
341 * Compute the L*L' or U'*U factorization of the matrix.
342 *
343  npp = n*( n+1 ) / 2
344  CALL ccopy( npp, a, 1, afac, 1 )
345  srnamt = 'CPPTRF'
346  CALL cpptrf( uplo, n, afac, info )
347 *
348 * Check error code from CPPTRF.
349 *
350  IF( info.NE.izero ) THEN
351  CALL alaerh( path, 'CPPTRF', info, izero, uplo, n, n,
352  $ -1, -1, -1, imat, nfail, nerrs, nout )
353  GO TO 90
354  END IF
355 *
356 * Skip the tests if INFO is not 0.
357 *
358  IF( info.NE.0 )
359  $ GO TO 90
360 *
361 *+ TEST 1
362 * Reconstruct matrix from factors and compute residual.
363 *
364  CALL ccopy( npp, afac, 1, ainv, 1 )
365  CALL cppt01( uplo, n, a, ainv, rwork, result( 1 ) )
366 *
367 *+ TEST 2
368 * Form the inverse and compute the residual.
369 *
370  CALL ccopy( npp, afac, 1, ainv, 1 )
371  srnamt = 'CPPTRI'
372  CALL cpptri( uplo, n, ainv, info )
373 *
374 * Check error code from CPPTRI.
375 *
376  IF( info.NE.0 )
377  $ CALL alaerh( path, 'CPPTRI', info, 0, uplo, n, n, -1,
378  $ -1, -1, imat, nfail, nerrs, nout )
379 *
380  CALL cppt03( uplo, n, a, ainv, work, lda, rwork, rcondc,
381  $ result( 2 ) )
382 *
383 * Print information about the tests that did not pass
384 * the threshold.
385 *
386  DO 60 k = 1, 2
387  IF( result( k ).GE.thresh ) THEN
388  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
389  $ CALL alahd( nout, path )
390  WRITE( nout, fmt = 9999 )uplo, n, imat, k,
391  $ result( k )
392  nfail = nfail + 1
393  END IF
394  60 CONTINUE
395  nrun = nrun + 2
396 *
397  DO 80 irhs = 1, nns
398  nrhs = nsval( irhs )
399 *
400 *+ TEST 3
401 * Solve and compute residual for A * X = B.
402 *
403  srnamt = 'CLARHS'
404  CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
405  $ nrhs, a, lda, xact, lda, b, lda, iseed,
406  $ info )
407  CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
408 *
409  srnamt = 'CPPTRS'
410  CALL cpptrs( uplo, n, nrhs, afac, x, lda, info )
411 *
412 * Check error code from CPPTRS.
413 *
414  IF( info.NE.0 )
415  $ CALL alaerh( path, 'CPPTRS', info, 0, uplo, n, n,
416  $ -1, -1, nrhs, imat, nfail, nerrs,
417  $ nout )
418 *
419  CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
420  CALL cppt02( uplo, n, nrhs, a, x, lda, work, lda,
421  $ rwork, result( 3 ) )
422 *
423 *+ TEST 4
424 * Check solution from generated exact solution.
425 *
426  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
427  $ result( 4 ) )
428 *
429 *+ TESTS 5, 6, and 7
430 * Use iterative refinement to improve the solution.
431 *
432  srnamt = 'CPPRFS'
433  CALL cpprfs( uplo, n, nrhs, a, afac, b, lda, x, lda,
434  $ rwork, rwork( nrhs+1 ), work,
435  $ rwork( 2*nrhs+1 ), info )
436 *
437 * Check error code from CPPRFS.
438 *
439  IF( info.NE.0 )
440  $ CALL alaerh( path, 'CPPRFS', info, 0, uplo, n, n,
441  $ -1, -1, nrhs, imat, nfail, nerrs,
442  $ nout )
443 *
444  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
445  $ result( 5 ) )
446  CALL cppt05( uplo, n, nrhs, a, b, lda, x, lda, xact,
447  $ lda, rwork, rwork( nrhs+1 ),
448  $ result( 6 ) )
449 *
450 * Print information about the tests that did not pass
451 * the threshold.
452 *
453  DO 70 k = 3, 7
454  IF( result( k ).GE.thresh ) THEN
455  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
456  $ CALL alahd( nout, path )
457  WRITE( nout, fmt = 9998 )uplo, n, nrhs, imat,
458  $ k, result( k )
459  nfail = nfail + 1
460  END IF
461  70 CONTINUE
462  nrun = nrun + 5
463  80 CONTINUE
464 *
465 *+ TEST 8
466 * Get an estimate of RCOND = 1/CNDNUM.
467 *
468  anorm = clanhp( '1', uplo, n, a, rwork )
469  srnamt = 'CPPCON'
470  CALL cppcon( uplo, n, afac, anorm, rcond, work, rwork,
471  $ info )
472 *
473 * Check error code from CPPCON.
474 *
475  IF( info.NE.0 )
476  $ CALL alaerh( path, 'CPPCON', info, 0, uplo, n, n, -1,
477  $ -1, -1, imat, nfail, nerrs, nout )
478 *
479  result( 8 ) = sget06( rcond, rcondc )
480 *
481 * Print the test ratio if greater than or equal to THRESH.
482 *
483  IF( result( 8 ).GE.thresh ) THEN
484  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
485  $ CALL alahd( nout, path )
486  WRITE( nout, fmt = 9999 )uplo, n, imat, 8,
487  $ result( 8 )
488  nfail = nfail + 1
489  END IF
490  nrun = nrun + 1
491 *
492  90 CONTINUE
493  100 CONTINUE
494  110 CONTINUE
495 *
496 * Print a summary of the results.
497 *
498  CALL alasum( path, nout, nfail, nrun, nerrs )
499 *
500  9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', type ', i2, ', test ',
501  $ i2, ', ratio =', g12.5 )
502  9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
503  $ i2, ', test(', i2, ') =', g12.5 )
504  RETURN
505 *
506 * End of CCHKPP
507 *
508  END
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
Definition: alasum.f:73
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:107
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:147
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
Definition: ccopy.f:81
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
Definition: clarhs.f:208
subroutine cppt02(UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, RESID)
CPPT02
Definition: cppt02.f:123
subroutine cppt01(UPLO, N, A, AFAC, RWORK, RESID)
CPPT01
Definition: cppt01.f:95
subroutine cppt03(UPLO, N, A, AINV, WORK, LDWORK, RWORK, RCOND, RESID)
CPPT03
Definition: cppt03.f:110
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
Definition: clatb4.f:121
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
Definition: cget04.f:102
subroutine cchkpp(DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, NOUT)
CCHKPP
Definition: cchkpp.f:159
subroutine cerrpo(PATH, NUNIT)
CERRPO
Definition: cerrpo.f:55
subroutine cppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CPPT05
Definition: cppt05.f:157
subroutine claipd(N, A, INDA, VINDA)
CLAIPD
Definition: claipd.f:83
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
Definition: clatms.f:332
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
Definition: clacpy.f:103
subroutine cpptrs(UPLO, N, NRHS, AP, B, LDB, INFO)
CPPTRS
Definition: cpptrs.f:108
subroutine cppcon(UPLO, N, AP, ANORM, RCOND, WORK, RWORK, INFO)
CPPCON
Definition: cppcon.f:118
subroutine cpptri(UPLO, N, AP, INFO)
CPPTRI
Definition: cpptri.f:93
subroutine cpptrf(UPLO, N, AP, INFO)
CPPTRF
Definition: cpptrf.f:119
subroutine cpprfs(UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CPPRFS
Definition: cpprfs.f:171