LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ cchkpt()

subroutine cchkpt ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NNS,
integer, dimension( * )  NSVAL,
real  THRESH,
logical  TSTERR,
complex, dimension( * )  A,
real, dimension( * )  D,
complex, dimension( * )  E,
complex, dimension( * )  B,
complex, dimension( * )  X,
complex, dimension( * )  XACT,
complex, dimension( * )  WORK,
real, dimension( * )  RWORK,
integer  NOUT 
)

CCHKPT

Purpose:
 CCHKPT tests CPTTRF, -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.
[out]A
          A is COMPLEX array, dimension (NMAX*2)
[out]D
          D is REAL array, dimension (NMAX*2)
[out]E
          E is COMPLEX array, dimension (NMAX*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(3,NSMAX))
[out]RWORK
          RWORK is REAL array, dimension
                      (max(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 145 of file cchkpt.f.

147 *
148 * -- LAPACK test routine --
149 * -- LAPACK is a software package provided by Univ. of Tennessee, --
150 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
151 *
152 * .. Scalar Arguments ..
153  LOGICAL TSTERR
154  INTEGER NN, NNS, NOUT
155  REAL THRESH
156 * ..
157 * .. Array Arguments ..
158  LOGICAL DOTYPE( * )
159  INTEGER NSVAL( * ), NVAL( * )
160  REAL D( * ), RWORK( * )
161  COMPLEX A( * ), B( * ), E( * ), WORK( * ), X( * ),
162  $ XACT( * )
163 * ..
164 *
165 * =====================================================================
166 *
167 * .. Parameters ..
168  REAL ONE, ZERO
169  parameter( one = 1.0e+0, zero = 0.0e+0 )
170  INTEGER NTYPES
171  parameter( ntypes = 12 )
172  INTEGER NTESTS
173  parameter( ntests = 7 )
174 * ..
175 * .. Local Scalars ..
176  LOGICAL ZEROT
177  CHARACTER DIST, TYPE, UPLO
178  CHARACTER*3 PATH
179  INTEGER I, IA, IMAT, IN, INFO, IRHS, IUPLO, IX, IZERO,
180  $ J, K, KL, KU, LDA, MODE, N, NERRS, NFAIL,
181  $ NIMAT, NRHS, NRUN
182  REAL AINVNM, ANORM, COND, DMAX, RCOND, RCONDC
183 * ..
184 * .. Local Arrays ..
185  CHARACTER UPLOS( 2 )
186  INTEGER ISEED( 4 ), ISEEDY( 4 )
187  REAL RESULT( NTESTS )
188  COMPLEX Z( 3 )
189 * ..
190 * .. External Functions ..
191  INTEGER ISAMAX
192  REAL CLANHT, SCASUM, SGET06
193  EXTERNAL isamax, clanht, scasum, sget06
194 * ..
195 * .. External Subroutines ..
196  EXTERNAL alaerh, alahd, alasum, ccopy, cerrgt, cget04,
199  $ csscal, scopy, slarnv, sscal
200 * ..
201 * .. Intrinsic Functions ..
202  INTRINSIC abs, max, real
203 * ..
204 * .. Scalars in Common ..
205  LOGICAL LERR, OK
206  CHARACTER*32 SRNAMT
207  INTEGER INFOT, NUNIT
208 * ..
209 * .. Common blocks ..
210  COMMON / infoc / infot, nunit, ok, lerr
211  COMMON / srnamc / srnamt
212 * ..
213 * .. Data statements ..
214  DATA iseedy / 0, 0, 0, 1 / , uplos / 'U', 'L' /
215 * ..
216 * .. Executable Statements ..
217 *
218  path( 1: 1 ) = 'Complex precision'
219  path( 2: 3 ) = 'PT'
220  nrun = 0
221  nfail = 0
222  nerrs = 0
223  DO 10 i = 1, 4
224  iseed( i ) = iseedy( i )
225  10 CONTINUE
226 *
227 * Test the error exits
228 *
229  IF( tsterr )
230  $ CALL cerrgt( path, nout )
231  infot = 0
232 *
233  DO 120 in = 1, nn
234 *
235 * Do for each value of N in NVAL.
236 *
237  n = nval( in )
238  lda = max( 1, n )
239  nimat = ntypes
240  IF( n.LE.0 )
241  $ nimat = 1
242 *
243  DO 110 imat = 1, nimat
244 *
245 * Do the tests only if DOTYPE( IMAT ) is true.
246 *
247  IF( n.GT.0 .AND. .NOT.dotype( imat ) )
248  $ GO TO 110
249 *
250 * Set up parameters with CLATB4.
251 *
252  CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
253  $ COND, DIST )
254 *
255  zerot = imat.GE.8 .AND. imat.LE.10
256  IF( imat.LE.6 ) THEN
257 *
258 * Type 1-6: generate a Hermitian tridiagonal matrix of
259 * known condition number in lower triangular band storage.
260 *
261  srnamt = 'CLATMS'
262  CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE, COND,
263  $ ANORM, KL, KU, 'B', A, 2, WORK, INFO )
264 *
265 * Check the error code from CLATMS.
266 *
267  IF( info.NE.0 ) THEN
268  CALL alaerh( path, 'CLATMS', info, 0, ' ', n, n, kl,
269  $ ku, -1, imat, nfail, nerrs, nout )
270  GO TO 110
271  END IF
272  izero = 0
273 *
274 * Copy the matrix to D and E.
275 *
276  ia = 1
277  DO 20 i = 1, n - 1
278  d( i ) = real( a( ia ) )
279  e( i ) = a( ia+1 )
280  ia = ia + 2
281  20 CONTINUE
282  IF( n.GT.0 )
283  $ d( n ) = real( a( ia ) )
284  ELSE
285 *
286 * Type 7-12: generate a diagonally dominant matrix with
287 * unknown condition number in the vectors D and E.
288 *
289  IF( .NOT.zerot .OR. .NOT.dotype( 7 ) ) THEN
290 *
291 * Let E be complex, D real, with values from [-1,1].
292 *
293  CALL slarnv( 2, iseed, n, d )
294  CALL clarnv( 2, iseed, n-1, e )
295 *
296 * Make the tridiagonal matrix diagonally dominant.
297 *
298  IF( n.EQ.1 ) THEN
299  d( 1 ) = abs( d( 1 ) )
300  ELSE
301  d( 1 ) = abs( d( 1 ) ) + abs( e( 1 ) )
302  d( n ) = abs( d( n ) ) + abs( e( n-1 ) )
303  DO 30 i = 2, n - 1
304  d( i ) = abs( d( i ) ) + abs( e( i ) ) +
305  $ abs( e( i-1 ) )
306  30 CONTINUE
307  END IF
308 *
309 * Scale D and E so the maximum element is ANORM.
310 *
311  ix = isamax( n, d, 1 )
312  dmax = d( ix )
313  CALL sscal( n, anorm / dmax, d, 1 )
314  CALL csscal( n-1, anorm / dmax, e, 1 )
315 *
316  ELSE IF( izero.GT.0 ) THEN
317 *
318 * Reuse the last matrix by copying back the zeroed out
319 * elements.
320 *
321  IF( izero.EQ.1 ) THEN
322  d( 1 ) = z( 2 )
323  IF( n.GT.1 )
324  $ e( 1 ) = z( 3 )
325  ELSE IF( izero.EQ.n ) THEN
326  e( n-1 ) = z( 1 )
327  d( n ) = z( 2 )
328  ELSE
329  e( izero-1 ) = z( 1 )
330  d( izero ) = z( 2 )
331  e( izero ) = z( 3 )
332  END IF
333  END IF
334 *
335 * For types 8-10, set one row and column of the matrix to
336 * zero.
337 *
338  izero = 0
339  IF( imat.EQ.8 ) THEN
340  izero = 1
341  z( 2 ) = d( 1 )
342  d( 1 ) = zero
343  IF( n.GT.1 ) THEN
344  z( 3 ) = e( 1 )
345  e( 1 ) = zero
346  END IF
347  ELSE IF( imat.EQ.9 ) THEN
348  izero = n
349  IF( n.GT.1 ) THEN
350  z( 1 ) = e( n-1 )
351  e( n-1 ) = zero
352  END IF
353  z( 2 ) = d( n )
354  d( n ) = zero
355  ELSE IF( imat.EQ.10 ) THEN
356  izero = ( n+1 ) / 2
357  IF( izero.GT.1 ) THEN
358  z( 1 ) = e( izero-1 )
359  z( 3 ) = e( izero )
360  e( izero-1 ) = zero
361  e( izero ) = zero
362  END IF
363  z( 2 ) = d( izero )
364  d( izero ) = zero
365  END IF
366  END IF
367 *
368  CALL scopy( n, d, 1, d( n+1 ), 1 )
369  IF( n.GT.1 )
370  $ CALL ccopy( n-1, e, 1, e( n+1 ), 1 )
371 *
372 *+ TEST 1
373 * Factor A as L*D*L' and compute the ratio
374 * norm(L*D*L' - A) / (n * norm(A) * EPS )
375 *
376  CALL cpttrf( n, d( n+1 ), e( n+1 ), info )
377 *
378 * Check error code from CPTTRF.
379 *
380  IF( info.NE.izero ) THEN
381  CALL alaerh( path, 'CPTTRF', info, izero, ' ', n, n, -1,
382  $ -1, -1, imat, nfail, nerrs, nout )
383  GO TO 110
384  END IF
385 *
386  IF( info.GT.0 ) THEN
387  rcondc = zero
388  GO TO 100
389  END IF
390 *
391  CALL cptt01( n, d, e, d( n+1 ), e( n+1 ), work,
392  $ result( 1 ) )
393 *
394 * Print the test ratio if greater than or equal to THRESH.
395 *
396  IF( result( 1 ).GE.thresh ) THEN
397  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
398  $ CALL alahd( nout, path )
399  WRITE( nout, fmt = 9999 )n, imat, 1, result( 1 )
400  nfail = nfail + 1
401  END IF
402  nrun = nrun + 1
403 *
404 * Compute RCONDC = 1 / (norm(A) * norm(inv(A))
405 *
406 * Compute norm(A).
407 *
408  anorm = clanht( '1', n, d, e )
409 *
410 * Use CPTTRS to solve for one column at a time of inv(A),
411 * computing the maximum column sum as we go.
412 *
413  ainvnm = zero
414  DO 50 i = 1, n
415  DO 40 j = 1, n
416  x( j ) = zero
417  40 CONTINUE
418  x( i ) = one
419  CALL cpttrs( 'Lower', n, 1, d( n+1 ), e( n+1 ), x, lda,
420  $ info )
421  ainvnm = max( ainvnm, scasum( n, x, 1 ) )
422  50 CONTINUE
423  rcondc = one / max( one, anorm*ainvnm )
424 *
425  DO 90 irhs = 1, nns
426  nrhs = nsval( irhs )
427 *
428 * Generate NRHS random solution vectors.
429 *
430  ix = 1
431  DO 60 j = 1, nrhs
432  CALL clarnv( 2, iseed, n, xact( ix ) )
433  ix = ix + lda
434  60 CONTINUE
435 *
436  DO 80 iuplo = 1, 2
437 *
438 * Do first for UPLO = 'U', then for UPLO = 'L'.
439 *
440  uplo = uplos( iuplo )
441 *
442 * Set the right hand side.
443 *
444  CALL claptm( uplo, n, nrhs, one, d, e, xact, lda,
445  $ zero, b, lda )
446 *
447 *+ TEST 2
448 * Solve A*x = b and compute the residual.
449 *
450  CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
451  CALL cpttrs( uplo, n, nrhs, d( n+1 ), e( n+1 ), x,
452  $ lda, info )
453 *
454 * Check error code from CPTTRS.
455 *
456  IF( info.NE.0 )
457  $ CALL alaerh( path, 'CPTTRS', info, 0, uplo, n, n,
458  $ -1, -1, nrhs, imat, nfail, nerrs,
459  $ nout )
460 *
461  CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
462  CALL cptt02( uplo, n, nrhs, d, e, x, lda, work, lda,
463  $ result( 2 ) )
464 *
465 *+ TEST 3
466 * Check solution from generated exact solution.
467 *
468  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
469  $ result( 3 ) )
470 *
471 *+ TESTS 4, 5, and 6
472 * Use iterative refinement to improve the solution.
473 *
474  srnamt = 'CPTRFS'
475  CALL cptrfs( uplo, n, nrhs, d, e, d( n+1 ), e( n+1 ),
476  $ b, lda, x, lda, rwork, rwork( nrhs+1 ),
477  $ work, rwork( 2*nrhs+1 ), info )
478 *
479 * Check error code from CPTRFS.
480 *
481  IF( info.NE.0 )
482  $ CALL alaerh( path, 'CPTRFS', info, 0, uplo, n, n,
483  $ -1, -1, nrhs, imat, nfail, nerrs,
484  $ nout )
485 *
486  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
487  $ result( 4 ) )
488  CALL cptt05( n, nrhs, d, e, b, lda, x, lda, xact, lda,
489  $ rwork, rwork( nrhs+1 ), result( 5 ) )
490 *
491 * Print information about the tests that did not pass the
492 * threshold.
493 *
494  DO 70 k = 2, 6
495  IF( result( k ).GE.thresh ) THEN
496  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
497  $ CALL alahd( nout, path )
498  WRITE( nout, fmt = 9998 )uplo, n, nrhs, imat,
499  $ k, result( k )
500  nfail = nfail + 1
501  END IF
502  70 CONTINUE
503  nrun = nrun + 5
504 *
505  80 CONTINUE
506  90 CONTINUE
507 *
508 *+ TEST 7
509 * Estimate the reciprocal of the condition number of the
510 * matrix.
511 *
512  100 CONTINUE
513  srnamt = 'CPTCON'
514  CALL cptcon( n, d( n+1 ), e( n+1 ), anorm, rcond, rwork,
515  $ info )
516 *
517 * Check error code from CPTCON.
518 *
519  IF( info.NE.0 )
520  $ CALL alaerh( path, 'CPTCON', info, 0, ' ', n, n, -1, -1,
521  $ -1, imat, nfail, nerrs, nout )
522 *
523  result( 7 ) = sget06( rcond, rcondc )
524 *
525 * Print the test ratio if greater than or equal to THRESH.
526 *
527  IF( result( 7 ).GE.thresh ) THEN
528  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
529  $ CALL alahd( nout, path )
530  WRITE( nout, fmt = 9999 )n, imat, 7, result( 7 )
531  nfail = nfail + 1
532  END IF
533  nrun = nrun + 1
534  110 CONTINUE
535  120 CONTINUE
536 *
537 * Print a summary of the results.
538 *
539  CALL alasum( path, nout, nfail, nrun, nerrs )
540 *
541  9999 FORMAT( ' N =', i5, ', type ', i2, ', test ', i2, ', ratio = ',
542  $ g12.5 )
543  9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS =', i3,
544  $ ', type ', i2, ', test ', i2, ', ratio = ', g12.5 )
545  RETURN
546 *
547 * End of CCHKPT
548 *
subroutine slarnv(IDIST, ISEED, N, X)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition: slarnv.f:97
integer function isamax(N, SX, INCX)
ISAMAX
Definition: isamax.f:71
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 csscal(N, SA, CX, INCX)
CSSCAL
Definition: csscal.f:78
subroutine claptm(UPLO, N, NRHS, ALPHA, D, E, X, LDX, BETA, B, LDB)
CLAPTM
Definition: claptm.f:129
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 cptt05(N, NRHS, D, E, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CPTT05
Definition: cptt05.f:150
subroutine cerrgt(PATH, NUNIT)
CERRGT
Definition: cerrgt.f:55
subroutine cptt02(UPLO, N, NRHS, D, E, X, LDX, B, LDB, RESID)
CPTT02
Definition: cptt02.f:115
subroutine cptt01(N, D, E, DF, EF, WORK, RESID)
CPTT01
Definition: cptt01.f:92
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
Definition: clatms.f:332
real function clanht(NORM, N, D, E)
CLANHT returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition: clanht.f:101
subroutine clarnv(IDIST, ISEED, N, X)
CLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition: clarnv.f:99
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 cptrfs(UPLO, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CPTRFS
Definition: cptrfs.f:183
subroutine cptcon(N, D, E, ANORM, RCOND, RWORK, INFO)
CPTCON
Definition: cptcon.f:119
subroutine cpttrs(UPLO, N, NRHS, D, E, B, LDB, INFO)
CPTTRS
Definition: cpttrs.f:121
subroutine cpttrf(N, D, E, INFO)
CPTTRF
Definition: cpttrf.f:92
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
Definition: scopy.f:82
subroutine sscal(N, SA, SX, INCX)
SSCAL
Definition: sscal.f:79
real function scasum(N, CX, INCX)
SCASUM
Definition: scasum.f:72
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: