LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
cchkpo.f
Go to the documentation of this file.
1*> \brief \b CCHKPO
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 CCHKPO( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
12* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
13* XACT, WORK, RWORK, NOUT )
14*
15* .. Scalar Arguments ..
16* LOGICAL TSTERR
17* INTEGER NMAX, NN, NNB, NNS, NOUT
18* REAL THRESH
19* ..
20* .. Array Arguments ..
21* LOGICAL DOTYPE( * )
22* INTEGER NBVAL( * ), 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*> CCHKPO tests CPOTRF, -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] NNB
61*> \verbatim
62*> NNB is INTEGER
63*> The number of values of NB contained in the vector NBVAL.
64*> \endverbatim
65*>
66*> \param[in] NBVAL
67*> \verbatim
68*> NBVAL is INTEGER array, dimension (NNB)
69*> The values of the blocksize NB.
70*> \endverbatim
71*>
72*> \param[in] NNS
73*> \verbatim
74*> NNS is INTEGER
75*> The number of values of NRHS contained in the vector NSVAL.
76*> \endverbatim
77*>
78*> \param[in] NSVAL
79*> \verbatim
80*> NSVAL is INTEGER array, dimension (NNS)
81*> The values of the number of right hand sides NRHS.
82*> \endverbatim
83*>
84*> \param[in] THRESH
85*> \verbatim
86*> THRESH is REAL
87*> The threshold value for the test ratios. A result is
88*> included in the output file if RESULT >= THRESH. To have
89*> every test ratio printed, use THRESH = 0.
90*> \endverbatim
91*>
92*> \param[in] TSTERR
93*> \verbatim
94*> TSTERR is LOGICAL
95*> Flag that indicates whether error exits are to be tested.
96*> \endverbatim
97*>
98*> \param[in] NMAX
99*> \verbatim
100*> NMAX is INTEGER
101*> The maximum value permitted for N, used in dimensioning the
102*> work arrays.
103*> \endverbatim
104*>
105*> \param[out] A
106*> \verbatim
107*> A is COMPLEX array, dimension (NMAX*NMAX)
108*> \endverbatim
109*>
110*> \param[out] AFAC
111*> \verbatim
112*> AFAC is COMPLEX array, dimension (NMAX*NMAX)
113*> \endverbatim
114*>
115*> \param[out] AINV
116*> \verbatim
117*> AINV is COMPLEX array, dimension (NMAX*NMAX)
118*> \endverbatim
119*>
120*> \param[out] B
121*> \verbatim
122*> B is COMPLEX array, dimension (NMAX*NSMAX)
123*> where NSMAX is the largest entry in NSVAL.
124*> \endverbatim
125*>
126*> \param[out] X
127*> \verbatim
128*> X is COMPLEX array, dimension (NMAX*NSMAX)
129*> \endverbatim
130*>
131*> \param[out] XACT
132*> \verbatim
133*> XACT is COMPLEX array, dimension (NMAX*NSMAX)
134*> \endverbatim
135*>
136*> \param[out] WORK
137*> \verbatim
138*> WORK is COMPLEX array, dimension
139*> (NMAX*max(3,NSMAX))
140*> \endverbatim
141*>
142*> \param[out] RWORK
143*> \verbatim
144*> RWORK is REAL array, dimension
145*> (NMAX+2*NSMAX)
146*> \endverbatim
147*>
148*> \param[in] NOUT
149*> \verbatim
150*> NOUT is INTEGER
151*> The unit number for output.
152*> \endverbatim
153*
154* Authors:
155* ========
156*
157*> \author Univ. of Tennessee
158*> \author Univ. of California Berkeley
159*> \author Univ. of Colorado Denver
160*> \author NAG Ltd.
161*
162*> \ingroup complex_lin
163*
164* =====================================================================
165 SUBROUTINE cchkpo( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
166 $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
167 $ XACT, WORK, RWORK, NOUT )
168*
169* -- LAPACK test routine --
170* -- LAPACK is a software package provided by Univ. of Tennessee, --
171* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
172*
173* .. Scalar Arguments ..
174 LOGICAL TSTERR
175 INTEGER NMAX, NN, NNB, NNS, NOUT
176 REAL THRESH
177* ..
178* .. Array Arguments ..
179 LOGICAL DOTYPE( * )
180 INTEGER NBVAL( * ), NSVAL( * ), NVAL( * )
181 REAL RWORK( * )
182 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
183 $ work( * ), x( * ), xact( * )
184* ..
185*
186* =====================================================================
187*
188* .. Parameters ..
189 COMPLEX CZERO
190 PARAMETER ( CZERO = ( 0.0e+0, 0.0e+0 ) )
191 INTEGER NTYPES
192 parameter( ntypes = 9 )
193 INTEGER NTESTS
194 parameter( ntests = 8 )
195* ..
196* .. Local Scalars ..
197 LOGICAL ZEROT
198 CHARACTER DIST, TYPE, UPLO, XTYPE
199 CHARACTER*3 PATH
200 INTEGER I, IMAT, IN, INB, INFO, IOFF, IRHS, IUPLO,
201 $ izero, k, kl, ku, lda, mode, n, nb, nerrs,
202 $ nfail, nimat, nrhs, nrun
203 REAL ANORM, CNDNUM, RCOND, RCONDC
204* ..
205* .. Local Arrays ..
206 CHARACTER UPLOS( 2 )
207 INTEGER ISEED( 4 ), ISEEDY( 4 )
208 REAL RESULT( NTESTS )
209* ..
210* .. External Functions ..
211 REAL CLANHE, SGET06
212 EXTERNAL CLANHE, SGET06
213* ..
214* .. External Subroutines ..
215 EXTERNAL alaerh, alahd, alasum, cerrpo, cget04, clacpy,
218 $ cpotrs, xlaenv
219* ..
220* .. Scalars in Common ..
221 LOGICAL LERR, OK
222 CHARACTER*32 SRNAMT
223 INTEGER INFOT, NUNIT
224* ..
225* .. Common blocks ..
226 COMMON / infoc / infot, nunit, ok, lerr
227 COMMON / srnamc / srnamt
228* ..
229* .. Intrinsic Functions ..
230 INTRINSIC max
231* ..
232* .. Data statements ..
233 DATA iseedy / 1988, 1989, 1990, 1991 /
234 DATA uplos / 'U', 'L' /
235* ..
236* .. Executable Statements ..
237*
238* Initialize constants and the random number seed.
239*
240 path( 1: 1 ) = 'Complex precision'
241 path( 2: 3 ) = 'PO'
242 nrun = 0
243 nfail = 0
244 nerrs = 0
245 DO 10 i = 1, 4
246 iseed( i ) = iseedy( i )
247 10 CONTINUE
248*
249* Test the error exits
250*
251 IF( tsterr )
252 $ CALL cerrpo( path, nout )
253 infot = 0
254*
255* Do for each value of N in NVAL
256*
257 DO 120 in = 1, nn
258 n = nval( in )
259 lda = max( n, 1 )
260 xtype = 'N'
261 nimat = ntypes
262 IF( n.LE.0 )
263 $ nimat = 1
264*
265 izero = 0
266 DO 110 imat = 1, nimat
267*
268* Do the tests only if DOTYPE( IMAT ) is true.
269*
270 IF( .NOT.dotype( imat ) )
271 $ GO TO 110
272*
273* Skip types 3, 4, or 5 if the matrix size is too small.
274*
275 zerot = imat.GE.3 .AND. imat.LE.5
276 IF( zerot .AND. n.LT.imat-2 )
277 $ GO TO 110
278*
279* Do first for UPLO = 'U', then for UPLO = 'L'
280*
281 DO 100 iuplo = 1, 2
282 uplo = uplos( iuplo )
283*
284* Set up parameters with CLATB4 and generate a test matrix
285* with CLATMS.
286*
287 CALL clatb4( path, imat, n, n, TYPE, kl, ku, anorm, mode,
288 $ cndnum, dist )
289*
290 srnamt = 'CLATMS'
291 CALL clatms( n, n, dist, iseed, TYPE, rwork, mode,
292 $ cndnum, anorm, kl, ku, uplo, a, lda, work,
293 $ info )
294*
295* Check error code from CLATMS.
296*
297 IF( info.NE.0 ) THEN
298 CALL alaerh( path, 'CLATMS', info, 0, uplo, n, n, -1,
299 $ -1, -1, imat, nfail, nerrs, nout )
300 GO TO 100
301 END IF
302*
303* For types 3-5, zero one row and column of the matrix to
304* test that INFO is returned correctly.
305*
306 IF( zerot ) THEN
307 IF( imat.EQ.3 ) THEN
308 izero = 1
309 ELSE IF( imat.EQ.4 ) THEN
310 izero = n
311 ELSE
312 izero = n / 2 + 1
313 END IF
314 ioff = ( izero-1 )*lda
315*
316* Set row and column IZERO of A to 0.
317*
318 IF( iuplo.EQ.1 ) THEN
319 DO 20 i = 1, izero - 1
320 a( ioff+i ) = czero
321 20 CONTINUE
322 ioff = ioff + izero
323 DO 30 i = izero, n
324 a( ioff ) = czero
325 ioff = ioff + lda
326 30 CONTINUE
327 ELSE
328 ioff = izero
329 DO 40 i = 1, izero - 1
330 a( ioff ) = czero
331 ioff = ioff + lda
332 40 CONTINUE
333 ioff = ioff - izero
334 DO 50 i = izero, n
335 a( ioff+i ) = czero
336 50 CONTINUE
337 END IF
338 ELSE
339 izero = 0
340 END IF
341*
342* Set the imaginary part of the diagonals.
343*
344 CALL claipd( n, a, lda+1, 0 )
345*
346* Do for each value of NB in NBVAL
347*
348 DO 90 inb = 1, nnb
349 nb = nbval( inb )
350 CALL xlaenv( 1, nb )
351*
352* Compute the L*L' or U'*U factorization of the matrix.
353*
354 CALL clacpy( uplo, n, n, a, lda, afac, lda )
355 srnamt = 'CPOTRF'
356 CALL cpotrf( uplo, n, afac, lda, info )
357*
358* Check error code from CPOTRF.
359*
360 IF( info.NE.izero ) THEN
361 CALL alaerh( path, 'CPOTRF', info, izero, uplo, n,
362 $ n, -1, -1, nb, imat, nfail, nerrs,
363 $ nout )
364 GO TO 90
365 END IF
366*
367* Skip the tests if INFO is not 0.
368*
369 IF( info.NE.0 )
370 $ GO TO 90
371*
372*+ TEST 1
373* Reconstruct matrix from factors and compute residual.
374*
375 CALL clacpy( uplo, n, n, afac, lda, ainv, lda )
376 CALL cpot01( uplo, n, a, lda, ainv, lda, rwork,
377 $ result( 1 ) )
378*
379*+ TEST 2
380* Form the inverse and compute the residual.
381*
382 CALL clacpy( uplo, n, n, afac, lda, ainv, lda )
383 srnamt = 'CPOTRI'
384 CALL cpotri( uplo, n, ainv, lda, info )
385*
386* Check error code from CPOTRI.
387*
388 IF( info.NE.0 )
389 $ CALL alaerh( path, 'CPOTRI', info, 0, uplo, n, n,
390 $ -1, -1, -1, imat, nfail, nerrs, nout )
391*
392 CALL cpot03( uplo, n, a, lda, ainv, lda, work, lda,
393 $ rwork, rcondc, result( 2 ) )
394*
395* Print information about the tests that did not pass
396* the threshold.
397*
398 DO 60 k = 1, 2
399 IF( result( k ).GE.thresh ) THEN
400 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
401 $ CALL alahd( nout, path )
402 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
403 $ result( k )
404 nfail = nfail + 1
405 END IF
406 60 CONTINUE
407 nrun = nrun + 2
408*
409* Skip the rest of the tests unless this is the first
410* blocksize.
411*
412 IF( inb.NE.1 )
413 $ GO TO 90
414*
415 DO 80 irhs = 1, nns
416 nrhs = nsval( irhs )
417*
418*+ TEST 3
419* Solve and compute residual for A * X = B .
420*
421 srnamt = 'CLARHS'
422 CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
423 $ nrhs, a, lda, xact, lda, b, lda,
424 $ iseed, info )
425 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
426*
427 srnamt = 'CPOTRS'
428 CALL cpotrs( uplo, n, nrhs, afac, lda, x, lda,
429 $ info )
430*
431* Check error code from CPOTRS.
432*
433 IF( info.NE.0 )
434 $ CALL alaerh( path, 'CPOTRS', info, 0, uplo, n,
435 $ n, -1, -1, nrhs, imat, nfail,
436 $ nerrs, nout )
437*
438 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
439 CALL cpot02( uplo, n, nrhs, a, lda, x, lda, work,
440 $ lda, rwork, result( 3 ) )
441*
442*+ TEST 4
443* Check solution from generated exact solution.
444*
445 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
446 $ result( 4 ) )
447*
448*+ TESTS 5, 6, and 7
449* Use iterative refinement to improve the solution.
450*
451 srnamt = 'CPORFS'
452 CALL cporfs( uplo, n, nrhs, a, lda, afac, lda, b,
453 $ lda, x, lda, rwork, rwork( nrhs+1 ),
454 $ work, rwork( 2*nrhs+1 ), info )
455*
456* Check error code from CPORFS.
457*
458 IF( info.NE.0 )
459 $ CALL alaerh( path, 'CPORFS', info, 0, uplo, n,
460 $ n, -1, -1, nrhs, imat, nfail,
461 $ nerrs, nout )
462*
463 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
464 $ result( 5 ) )
465 CALL cpot05( uplo, n, nrhs, a, lda, b, lda, x, lda,
466 $ xact, lda, rwork, rwork( nrhs+1 ),
467 $ result( 6 ) )
468*
469* Print information about the tests that did not pass
470* the threshold.
471*
472 DO 70 k = 3, 7
473 IF( result( k ).GE.thresh ) THEN
474 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
475 $ CALL alahd( nout, path )
476 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
477 $ imat, k, result( k )
478 nfail = nfail + 1
479 END IF
480 70 CONTINUE
481 nrun = nrun + 5
482 80 CONTINUE
483*
484*+ TEST 8
485* Get an estimate of RCOND = 1/CNDNUM.
486*
487 anorm = clanhe( '1', uplo, n, a, lda, rwork )
488 srnamt = 'CPOCON'
489 CALL cpocon( uplo, n, afac, lda, anorm, rcond, work,
490 $ rwork, info )
491*
492* Check error code from CPOCON.
493*
494 IF( info.NE.0 )
495 $ CALL alaerh( path, 'CPOCON', info, 0, uplo, n, n,
496 $ -1, -1, -1, imat, nfail, nerrs, nout )
497*
498 result( 8 ) = sget06( rcond, rcondc )
499*
500* Print the test ratio if it is .GE. THRESH.
501*
502 IF( result( 8 ).GE.thresh ) THEN
503 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
504 $ CALL alahd( nout, path )
505 WRITE( nout, fmt = 9997 )uplo, n, imat, 8,
506 $ result( 8 )
507 nfail = nfail + 1
508 END IF
509 nrun = nrun + 1
510 90 CONTINUE
511 100 CONTINUE
512 110 CONTINUE
513 120 CONTINUE
514*
515* Print a summary of the results.
516*
517 CALL alasum( path, nout, nfail, nrun, nerrs )
518*
519 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
520 $ i2, ', test ', i2, ', ratio =', g12.5 )
521 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
522 $ i2, ', test(', i2, ') =', g12.5 )
523 9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
524 $ ', test(', i2, ') =', g12.5 )
525 RETURN
526*
527* End of CCHKPO
528*
529 END
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
Definition alasum.f:73
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 xlaenv(ispec, nvalue)
XLAENV
Definition xlaenv.f:81
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
Definition alaerh.f:147
subroutine alahd(iounit, path)
ALAHD
Definition alahd.f:107
subroutine cchkpo(dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, nout)
CCHKPO
Definition cchkpo.f:168
subroutine cerrpo(path, nunit)
CERRPO
Definition cerrpo.f:55
subroutine cget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
CGET04
Definition cget04.f:102
subroutine claipd(n, a, inda, vinda)
CLAIPD
Definition claipd.f:83
subroutine clatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
CLATB4
Definition clatb4.f:121
subroutine clatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
CLATMS
Definition clatms.f:332
subroutine cpot01(uplo, n, a, lda, afac, ldafac, rwork, resid)
CPOT01
Definition cpot01.f:106
subroutine cpot02(uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
CPOT02
Definition cpot02.f:127
subroutine cpot03(uplo, n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
CPOT03
Definition cpot03.f:126
subroutine cpot05(uplo, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
CPOT05
Definition cpot05.f:165
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 cpocon(uplo, n, a, lda, anorm, rcond, work, rwork, info)
CPOCON
Definition cpocon.f:121
subroutine cporfs(uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x, ldx, ferr, berr, work, rwork, info)
CPORFS
Definition cporfs.f:183
subroutine cpotrf(uplo, n, a, lda, info)
CPOTRF
Definition cpotrf.f:107
subroutine cpotri(uplo, n, a, lda, info)
CPOTRI
Definition cpotri.f:95
subroutine cpotrs(uplo, n, nrhs, a, lda, b, ldb, info)
CPOTRS
Definition cpotrs.f:110