LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine cchksp ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
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, dimension( * )  IWORK,
integer  NOUT 
)

CCHKSP

Purpose: 
 CCHKSP tests CSPTRF, -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]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+1)/2)
[out]AFAC
          AFAC is COMPLEX array, dimension
                      (NMAX*(NMAX+1)/2)
[out]AINV
          AINV is COMPLEX array, dimension
                      (NMAX*(NMAX+1)/2)
[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(2,NSMAX))
[out]RWORK
          RWORK is REAL array,
                                 dimension (NMAX+2*NSMAX)
[out]IWORK
          IWORK is INTEGER array, dimension (NMAX)
[in]NOUT
          NOUT is INTEGER
          The unit number for output.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Date
November 2011

Definition at line 166 of file cchksp.f.

166 *
167 * -- LAPACK test routine (version 3.4.0) --
168 * -- LAPACK is a software package provided by Univ. of Tennessee, --
169 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
170 * November 2011
171 *
172 * .. Scalar Arguments ..
173  LOGICAL tsterr
174  INTEGER nmax, nn, nns, nout
175  REAL thresh
176 * ..
177 * .. Array Arguments ..
178  LOGICAL dotype( * )
179  INTEGER iwork( * ), nsval( * ), nval( * )
180  REAL rwork( * )
181  COMPLEX a( * ), afac( * ), ainv( * ), b( * ),
182  $ work( * ), x( * ), xact( * )
183 * ..
184 *
185 * =====================================================================
186 *
187 * .. Parameters ..
188  REAL zero
189  parameter ( zero = 0.0e+0 )
190  INTEGER ntypes
191  parameter ( ntypes = 11 )
192  INTEGER ntests
193  parameter ( ntests = 8 )
194 * ..
195 * .. Local Scalars ..
196  LOGICAL trfcon, zerot
197  CHARACTER dist, packit, TYPE, uplo, xtype
198  CHARACTER*3 path
199  INTEGER i, i1, i2, imat, in, info, ioff, irhs, iuplo,
200  $ izero, j, k, kl, ku, lda, mode, n, nerrs,
201  $ nfail, nimat, npp, nrhs, nrun, nt
202  REAL anorm, cndnum, rcond, rcondc
203 * ..
204 * .. Local Arrays ..
205  CHARACTER uplos( 2 )
206  INTEGER iseed( 4 ), iseedy( 4 )
207  REAL result( ntests )
208 * ..
209 * .. External Functions ..
210  LOGICAL lsame
211  REAL clansp, sget06
212  EXTERNAL lsame, clansp, sget06
213 * ..
214 * .. External Subroutines ..
215  EXTERNAL alaerh, alahd, alasum, ccopy, cerrsy, cget04,
216  $ clacpy, clarhs, clatb4, clatms, clatsp, cppt05,
217  $ cspcon, csprfs, cspt01, cspt02, cspt03, csptrf,
218  $ csptri, csptrs
219 * ..
220 * .. Intrinsic Functions ..
221  INTRINSIC max, min
222 * ..
223 * .. Scalars in Common ..
224  LOGICAL lerr, ok
225  CHARACTER*32 srnamt
226  INTEGER infot, nunit
227 * ..
228 * .. Common blocks ..
229  COMMON / infoc / infot, nunit, ok, lerr
230  COMMON / srnamc / srnamt
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 ) = 'SP'
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 cerrsy( path, nout )
253  infot = 0
254 *
255 * Do for each value of N in NVAL
256 *
257  DO 170 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  DO 160 imat = 1, nimat
266 *
267 * Do the tests only if DOTYPE( IMAT ) is true.
268 *
269  IF( .NOT.dotype( imat ) )
270  $ GO TO 160
271 *
272 * Skip types 3, 4, 5, or 6 if the matrix size is too small.
273 *
274  zerot = imat.GE.3 .AND. imat.LE.6
275  IF( zerot .AND. n.LT.imat-2 )
276  $ GO TO 160
277 *
278 * Do first for UPLO = 'U', then for UPLO = 'L'
279 *
280  DO 150 iuplo = 1, 2
281  uplo = uplos( iuplo )
282  IF( lsame( uplo, 'U' ) ) THEN
283  packit = 'C'
284  ELSE
285  packit = 'R'
286  END IF
287 *
288  IF( imat.NE.ntypes ) THEN
289 *
290 * Set up parameters with CLATB4 and generate a test
291 * matrix with CLATMS.
292 *
293  CALL clatb4( path, imat, n, n, TYPE, kl, ku, anorm,
294  $ mode, cndnum, dist )
295 *
296  srnamt = 'CLATMS'
297  CALL clatms( n, n, dist, iseed, TYPE, rwork, mode,
298  $ cndnum, anorm, kl, ku, packit, a, lda,
299  $ work, info )
300 *
301 * Check error code from CLATMS.
302 *
303  IF( info.NE.0 ) THEN
304  CALL alaerh( path, 'CLATMS', info, 0, uplo, n, n,
305  $ -1, -1, -1, imat, nfail, nerrs, nout )
306  GO TO 150
307  END IF
308 *
309 * For types 3-6, zero one or more rows and columns of
310 * the matrix to test that INFO is returned correctly.
311 *
312  IF( zerot ) THEN
313  IF( imat.EQ.3 ) THEN
314  izero = 1
315  ELSE IF( imat.EQ.4 ) THEN
316  izero = n
317  ELSE
318  izero = n / 2 + 1
319  END IF
320 *
321  IF( imat.LT.6 ) THEN
322 *
323 * Set row and column IZERO to zero.
324 *
325  IF( iuplo.EQ.1 ) THEN
326  ioff = ( izero-1 )*izero / 2
327  DO 20 i = 1, izero - 1
328  a( ioff+i ) = zero
329  20 CONTINUE
330  ioff = ioff + izero
331  DO 30 i = izero, n
332  a( ioff ) = zero
333  ioff = ioff + i
334  30 CONTINUE
335  ELSE
336  ioff = izero
337  DO 40 i = 1, izero - 1
338  a( ioff ) = zero
339  ioff = ioff + n - i
340  40 CONTINUE
341  ioff = ioff - izero
342  DO 50 i = izero, n
343  a( ioff+i ) = zero
344  50 CONTINUE
345  END IF
346  ELSE
347  IF( iuplo.EQ.1 ) THEN
348 *
349 * Set the first IZERO rows and columns to zero.
350 *
351  ioff = 0
352  DO 70 j = 1, n
353  i2 = min( j, izero )
354  DO 60 i = 1, i2
355  a( ioff+i ) = zero
356  60 CONTINUE
357  ioff = ioff + j
358  70 CONTINUE
359  ELSE
360 *
361 * Set the last IZERO rows and columns to zero.
362 *
363  ioff = 0
364  DO 90 j = 1, n
365  i1 = max( j, izero )
366  DO 80 i = i1, n
367  a( ioff+i ) = zero
368  80 CONTINUE
369  ioff = ioff + n - j
370  90 CONTINUE
371  END IF
372  END IF
373  ELSE
374  izero = 0
375  END IF
376  ELSE
377 *
378 * Use a special block diagonal matrix to test alternate
379 * code for the 2 x 2 blocks.
380 *
381  CALL clatsp( uplo, n, a, iseed )
382  END IF
383 *
384 * Compute the L*D*L' or U*D*U' factorization of the matrix.
385 *
386  npp = n*( n+1 ) / 2
387  CALL ccopy( npp, a, 1, afac, 1 )
388  srnamt = 'CSPTRF'
389  CALL csptrf( uplo, n, afac, iwork, info )
390 *
391 * Adjust the expected value of INFO to account for
392 * pivoting.
393 *
394  k = izero
395  IF( k.GT.0 ) THEN
396  100 CONTINUE
397  IF( iwork( k ).LT.0 ) THEN
398  IF( iwork( k ).NE.-k ) THEN
399  k = -iwork( k )
400  GO TO 100
401  END IF
402  ELSE IF( iwork( k ).NE.k ) THEN
403  k = iwork( k )
404  GO TO 100
405  END IF
406  END IF
407 *
408 * Check error code from CSPTRF.
409 *
410  IF( info.NE.k )
411  $ CALL alaerh( path, 'CSPTRF', info, k, uplo, n, n, -1,
412  $ -1, -1, imat, nfail, nerrs, nout )
413  IF( info.NE.0 ) THEN
414  trfcon = .true.
415  ELSE
416  trfcon = .false.
417  END IF
418 *
419 *+ TEST 1
420 * Reconstruct matrix from factors and compute residual.
421 *
422  CALL cspt01( uplo, n, a, afac, iwork, ainv, lda, rwork,
423  $ result( 1 ) )
424  nt = 1
425 *
426 *+ TEST 2
427 * Form the inverse and compute the residual.
428 *
429  IF( .NOT.trfcon ) THEN
430  CALL ccopy( npp, afac, 1, ainv, 1 )
431  srnamt = 'CSPTRI'
432  CALL csptri( uplo, n, ainv, iwork, work, info )
433 *
434 * Check error code from CSPTRI.
435 *
436  IF( info.NE.0 )
437  $ CALL alaerh( path, 'CSPTRI', info, 0, uplo, n, n,
438  $ -1, -1, -1, imat, nfail, nerrs, nout )
439 *
440  CALL cspt03( uplo, n, a, ainv, work, lda, rwork,
441  $ rcondc, result( 2 ) )
442  nt = 2
443  END IF
444 *
445 * Print information about the tests that did not pass
446 * the threshold.
447 *
448  DO 110 k = 1, nt
449  IF( result( k ).GE.thresh ) THEN
450  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
451  $ CALL alahd( nout, path )
452  WRITE( nout, fmt = 9999 )uplo, n, imat, k,
453  $ result( k )
454  nfail = nfail + 1
455  END IF
456  110 CONTINUE
457  nrun = nrun + nt
458 *
459 * Do only the condition estimate if INFO is not 0.
460 *
461  IF( trfcon ) THEN
462  rcondc = zero
463  GO TO 140
464  END IF
465 *
466  DO 130 irhs = 1, nns
467  nrhs = nsval( irhs )
468 *
469 *+ TEST 3
470 * Solve and compute residual for A * X = B.
471 *
472  srnamt = 'CLARHS'
473  CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
474  $ nrhs, a, lda, xact, lda, b, lda, iseed,
475  $ info )
476  CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
477 *
478  srnamt = 'CSPTRS'
479  CALL csptrs( uplo, n, nrhs, afac, iwork, x, lda,
480  $ info )
481 *
482 * Check error code from CSPTRS.
483 *
484  IF( info.NE.0 )
485  $ CALL alaerh( path, 'CSPTRS', info, 0, uplo, n, n,
486  $ -1, -1, nrhs, imat, nfail, nerrs,
487  $ nout )
488 *
489  CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
490  CALL cspt02( uplo, n, nrhs, a, x, lda, work, lda,
491  $ rwork, result( 3 ) )
492 *
493 *+ TEST 4
494 * Check solution from generated exact solution.
495 *
496  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
497  $ result( 4 ) )
498 *
499 *+ TESTS 5, 6, and 7
500 * Use iterative refinement to improve the solution.
501 *
502  srnamt = 'CSPRFS'
503  CALL csprfs( uplo, n, nrhs, a, afac, iwork, b, lda, x,
504  $ lda, rwork, rwork( nrhs+1 ), work,
505  $ rwork( 2*nrhs+1 ), info )
506 *
507 * Check error code from CSPRFS.
508 *
509  IF( info.NE.0 )
510  $ CALL alaerh( path, 'CSPRFS', info, 0, uplo, n, n,
511  $ -1, -1, nrhs, imat, nfail, nerrs,
512  $ nout )
513 *
514  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
515  $ result( 5 ) )
516  CALL cppt05( uplo, n, nrhs, a, b, lda, x, lda, xact,
517  $ lda, rwork, rwork( nrhs+1 ),
518  $ result( 6 ) )
519 *
520 * Print information about the tests that did not pass
521 * the threshold.
522 *
523  DO 120 k = 3, 7
524  IF( result( k ).GE.thresh ) THEN
525  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
526  $ CALL alahd( nout, path )
527  WRITE( nout, fmt = 9998 )uplo, n, nrhs, imat,
528  $ k, result( k )
529  nfail = nfail + 1
530  END IF
531  120 CONTINUE
532  nrun = nrun + 5
533  130 CONTINUE
534 *
535 *+ TEST 8
536 * Get an estimate of RCOND = 1/CNDNUM.
537 *
538  140 CONTINUE
539  anorm = clansp( '1', uplo, n, a, rwork )
540  srnamt = 'CSPCON'
541  CALL cspcon( uplo, n, afac, iwork, anorm, rcond, work,
542  $ info )
543 *
544 * Check error code from CSPCON.
545 *
546  IF( info.NE.0 )
547  $ CALL alaerh( path, 'CSPCON', info, 0, uplo, n, n, -1,
548  $ -1, -1, imat, nfail, nerrs, nout )
549 *
550  result( 8 ) = sget06( rcond, rcondc )
551 *
552 * Print the test ratio if it is .GE. THRESH.
553 *
554  IF( result( 8 ).GE.thresh ) THEN
555  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
556  $ CALL alahd( nout, path )
557  WRITE( nout, fmt = 9999 )uplo, n, imat, 8,
558  $ result( 8 )
559  nfail = nfail + 1
560  END IF
561  nrun = nrun + 1
562  150 CONTINUE
563  160 CONTINUE
564  170 CONTINUE
565 *
566 * Print a summary of the results.
567 *
568  CALL alasum( path, nout, nfail, nrun, nerrs )
569 *
570  9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', type ', i2, ', test ',
571  $ i2, ', ratio =', g12.5 )
572  9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
573  $ i2, ', test(', i2, ') =', g12.5 )
574  RETURN
575 *
576 * End of CCHKSP
577 *
clansp
real function clansp(NORM, UPLO, N, AP, WORK)
CLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric matrix supplied in packed form.
Definition: clansp.f:117
alahd
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:95
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
clarhs
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
Definition: clarhs.f:211
cerrsy
subroutine cerrsy(PATH, NUNIT)
CERRSY
Definition: cerrsy.f:57
cppt05
subroutine cppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CPPT05
Definition: cppt05.f:159
cspcon
subroutine cspcon(UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO)
CSPCON
Definition: cspcon.f:120
cspt02
subroutine cspt02(UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, RESID)
CSPT02
Definition: cspt02.f:125
clatsp
subroutine clatsp(UPLO, N, X, ISEED)
CLATSP
Definition: clatsp.f:86
cspt01
subroutine cspt01(UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID)
CSPT01
Definition: cspt01.f:114
sget06
real function sget06(RCOND, RCONDC)
SGET06
Definition: sget06.f:57
csptrf
subroutine csptrf(UPLO, N, AP, IPIV, INFO)
CSPTRF
Definition: csptrf.f:160
csptrs
subroutine csptrs(UPLO, N, NRHS, AP, IPIV, B, LDB, INFO)
CSPTRS
Definition: csptrs.f:117
cspt03
subroutine cspt03(UPLO, N, A, AINV, WORK, LDW, RWORK, RCOND, RESID)
CSPT03
Definition: cspt03.f:112
clatms
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
Definition: clatms.f:334
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:105
csprfs
subroutine csprfs(UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CSPRFS
Definition: csprfs.f:182
ccopy
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
Definition: ccopy.f:52
csptri
subroutine csptri(UPLO, N, AP, IPIV, WORK, INFO)
CSPTRI
Definition: csptri.f:111
clatb4
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
Definition: clatb4.f:123
cget04
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
Definition: cget04.f:104
lsame
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55
alasum
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
Definition: alasum.f:75

Here is the call graph for this function:

Here is the caller graph for this function: