LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ cchkpo()

subroutine cchkpo ( logical, dimension( * )  dotype,
integer  nn,
integer, dimension( * )  nval,
integer  nnb,
integer, dimension( * )  nbval,
integer  nns,
integer, dimension( * )  nsval,
real  thresh,
logical  tsterr,
integer  nmax,
complex, dimension( * )  a,
complex, dimension( * )  afac,
complex, dimension( * )  ainv,
complex, dimension( * )  b,
complex, dimension( * )  x,
complex, dimension( * )  xact,
complex, dimension( * )  work,
real, dimension( * )  rwork,
integer  nout 
)

CCHKPO

Purpose:
 CCHKPO tests CPOTRF, -TRI, -TRS, -RFS, and -CON
Parameters
[in]DOTYPE
          DOTYPE is LOGICAL array, dimension (NTYPES)
          The matrix types to be used for testing.  Matrices of type j
          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
[in]NN
          NN is INTEGER
          The number of values of N contained in the vector NVAL.
[in]NVAL
          NVAL is INTEGER array, dimension (NN)
          The values of the matrix dimension N.
[in]NNB
          NNB is INTEGER
          The number of values of NB contained in the vector NBVAL.
[in]NBVAL
          NBVAL is INTEGER array, dimension (NNB)
          The values of the blocksize NB.
[in]NNS
          NNS is INTEGER
          The number of values of NRHS contained in the vector NSVAL.
[in]NSVAL
          NSVAL is INTEGER array, dimension (NNS)
          The values of the number of right hand sides NRHS.
[in]THRESH
          THRESH is REAL
          The threshold value for the test ratios.  A result is
          included in the output file if RESULT >= THRESH.  To have
          every test ratio printed, use THRESH = 0.
[in]TSTERR
          TSTERR is LOGICAL
          Flag that indicates whether error exits are to be tested.
[in]NMAX
          NMAX is INTEGER
          The maximum value permitted for N, used in dimensioning the
          work arrays.
[out]A
          A is COMPLEX array, dimension (NMAX*NMAX)
[out]AFAC
          AFAC is COMPLEX array, dimension (NMAX*NMAX)
[out]AINV
          AINV is COMPLEX array, dimension (NMAX*NMAX)
[out]B
          B is COMPLEX array, dimension (NMAX*NSMAX)
          where NSMAX is the largest entry in NSVAL.
[out]X
          X is COMPLEX array, dimension (NMAX*NSMAX)
[out]XACT
          XACT is COMPLEX array, dimension (NMAX*NSMAX)
[out]WORK
          WORK is COMPLEX array, dimension
                      (NMAX*max(3,NSMAX))
[out]RWORK
          RWORK is REAL array, dimension
                      (NMAX+2*NSMAX)
[in]NOUT
          NOUT is INTEGER
          The unit number for output.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 165 of file cchkpo.f.

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,
216 $ claipd, clarhs, clatb4, clatms, cpocon, cporfs,
217 $ cpot01, cpot02, cpot03, cpot05, cpotrf, cpotri,
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*
alasum
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
Definition alasum.f:73
clarhs
subroutine clarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
CLARHS
Definition clarhs.f:208
xlaenv
subroutine xlaenv(ispec, nvalue)
XLAENV
Definition xlaenv.f:81
alaerh
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
Definition alaerh.f:147
alahd
subroutine alahd(iounit, path)
ALAHD
Definition alahd.f:107
cerrpo
subroutine cerrpo(path, nunit)
CERRPO
Definition cerrpo.f:55
cget04
subroutine cget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
CGET04
Definition cget04.f:102
claipd
subroutine claipd(n, a, inda, vinda)
CLAIPD
Definition claipd.f:83
clatb4
subroutine clatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
CLATB4
Definition clatb4.f:121
clatms
subroutine clatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
CLATMS
Definition clatms.f:332
cpot01
subroutine cpot01(uplo, n, a, lda, afac, ldafac, rwork, resid)
CPOT01
Definition cpot01.f:106
cpot02
subroutine cpot02(uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
CPOT02
Definition cpot02.f:127
cpot03
subroutine cpot03(uplo, n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
CPOT03
Definition cpot03.f:126
cpot05
subroutine cpot05(uplo, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
CPOT05
Definition cpot05.f:165
clacpy
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
clanhe
real function clanhe(norm, uplo, n, a, lda, work)
CLANHE returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition clanhe.f:124
cpocon
subroutine cpocon(uplo, n, a, lda, anorm, rcond, work, rwork, info)
CPOCON
Definition cpocon.f:121
cporfs
subroutine cporfs(uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x, ldx, ferr, berr, work, rwork, info)
CPORFS
Definition cporfs.f:183
cpotrf
subroutine cpotrf(uplo, n, a, lda, info)
CPOTRF
Definition cpotrf.f:107
cpotri
subroutine cpotri(uplo, n, a, lda, info)
CPOTRI
Definition cpotri.f:95
cpotrs
subroutine cpotrs(uplo, n, nrhs, a, lda, b, ldb, info)
CPOTRS
Definition cpotrs.f:110
sget06
real function sget06(rcond, rcondc)
SGET06
Definition sget06.f:55
Here is the call graph for this function:
Here is the caller graph for this function: