LAPACK  3.8.0 LAPACK: Linear Algebra PACKage

## ◆ cchkgt()

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

CCHKGT

Purpose:
` CCHKGT tests CGTTRF, -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*4)` [out] AF ` AF is COMPLEX array, dimension (NMAX*4)` [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)``` [out] IWORK ` IWORK is INTEGER array, dimension (NMAX)` [in] NOUT ``` NOUT is INTEGER The unit number for output.```
Date
December 2016

Definition at line 149 of file cchkgt.f.

149 *
150 * -- LAPACK test routine (version 3.7.0) --
151 * -- LAPACK is a software package provided by Univ. of Tennessee, --
152 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
153 * December 2016
154 *
155 * .. Scalar Arguments ..
156  LOGICAL tsterr
157  INTEGER nn, nns, nout
158  REAL thresh
159 * ..
160 * .. Array Arguments ..
161  LOGICAL dotype( * )
162  INTEGER iwork( * ), nsval( * ), nval( * )
163  REAL rwork( * )
164  COMPLEX a( * ), af( * ), b( * ), work( * ), x( * ),
165  \$ xact( * )
166 * ..
167 *
168 * =====================================================================
169 *
170 * .. Parameters ..
171  REAL one, zero
172  parameter( one = 1.0e+0, zero = 0.0e+0 )
173  INTEGER ntypes
174  parameter( ntypes = 12 )
175  INTEGER ntests
176  parameter( ntests = 7 )
177 * ..
178 * .. Local Scalars ..
179  LOGICAL trfcon, zerot
180  CHARACTER dist, norm, trans, type
181  CHARACTER*3 path
182  INTEGER i, imat, in, info, irhs, itran, ix, izero, j,
183  \$ k, kl, koff, ku, lda, m, mode, n, nerrs, nfail,
184  \$ nimat, nrhs, nrun
185  REAL ainvnm, anorm, cond, rcond, rcondc, rcondi,
186  \$ rcondo
187 * ..
188 * .. Local Arrays ..
189  CHARACTER transs( 3 )
190  INTEGER iseed( 4 ), iseedy( 4 )
191  REAL result( ntests )
192  COMPLEX z( 3 )
193 * ..
194 * .. External Functions ..
195  REAL clangt, scasum, sget06
196  EXTERNAL clangt, scasum, sget06
197 * ..
198 * .. External Subroutines ..
199  EXTERNAL alaerh, alahd, alasum, ccopy, cerrge, cget04,
202  \$ csscal
203 * ..
204 * .. Intrinsic Functions ..
205  INTRINSIC max
206 * ..
207 * .. Scalars in Common ..
208  LOGICAL lerr, ok
209  CHARACTER*32 srnamt
210  INTEGER infot, nunit
211 * ..
212 * .. Common blocks ..
213  COMMON / infoc / infot, nunit, ok, lerr
214  COMMON / srnamc / srnamt
215 * ..
216 * .. Data statements ..
217  DATA iseedy / 0, 0, 0, 1 / , transs / 'N', 'T',
218  \$ 'C' /
219 * ..
220 * .. Executable Statements ..
221 *
222  path( 1: 1 ) = 'Complex precision'
223  path( 2: 3 ) = 'GT'
224  nrun = 0
225  nfail = 0
226  nerrs = 0
227  DO 10 i = 1, 4
228  iseed( i ) = iseedy( i )
229  10 CONTINUE
230 *
231 * Test the error exits
232 *
233  IF( tsterr )
234  \$ CALL cerrge( path, nout )
235  infot = 0
236 *
237  DO 110 in = 1, nn
238 *
239 * Do for each value of N in NVAL.
240 *
241  n = nval( in )
242  m = max( n-1, 0 )
243  lda = max( 1, n )
244  nimat = ntypes
245  IF( n.LE.0 )
246  \$ nimat = 1
247 *
248  DO 100 imat = 1, nimat
249 *
250 * Do the tests only if DOTYPE( IMAT ) is true.
251 *
252  IF( .NOT.dotype( imat ) )
253  \$ GO TO 100
254 *
255 * Set up parameters with CLATB4.
256 *
257  CALL clatb4( path, imat, n, n, TYPE, kl, ku, anorm, mode,
258  \$ cond, dist )
259 *
260  zerot = imat.GE.8 .AND. imat.LE.10
261  IF( imat.LE.6 ) THEN
262 *
263 * Types 1-6: generate matrices of known condition number.
264 *
265  koff = max( 2-ku, 3-max( 1, n ) )
266  srnamt = 'CLATMS'
267  CALL clatms( n, n, dist, iseed, TYPE, rwork, mode, cond,
268  \$ anorm, kl, ku, 'Z', af( koff ), 3, work,
269  \$ info )
270 *
271 * Check the error code from CLATMS.
272 *
273  IF( info.NE.0 ) THEN
274  CALL alaerh( path, 'CLATMS', info, 0, ' ', n, n, kl,
275  \$ ku, -1, imat, nfail, nerrs, nout )
276  GO TO 100
277  END IF
278  izero = 0
279 *
280  IF( n.GT.1 ) THEN
281  CALL ccopy( n-1, af( 4 ), 3, a, 1 )
282  CALL ccopy( n-1, af( 3 ), 3, a( n+m+1 ), 1 )
283  END IF
284  CALL ccopy( n, af( 2 ), 3, a( m+1 ), 1 )
285  ELSE
286 *
287 * Types 7-12: generate tridiagonal matrices with
288 * unknown condition numbers.
289 *
290  IF( .NOT.zerot .OR. .NOT.dotype( 7 ) ) THEN
291 *
292 * Generate a matrix with elements whose real and
293 * imaginary parts are from [-1,1].
294 *
295  CALL clarnv( 2, iseed, n+2*m, a )
296  IF( anorm.NE.one )
297  \$ CALL csscal( n+2*m, anorm, a, 1 )
298  ELSE IF( izero.GT.0 ) THEN
299 *
300 * Reuse the last matrix by copying back the zeroed out
301 * elements.
302 *
303  IF( izero.EQ.1 ) THEN
304  a( n ) = z( 2 )
305  IF( n.GT.1 )
306  \$ a( 1 ) = z( 3 )
307  ELSE IF( izero.EQ.n ) THEN
308  a( 3*n-2 ) = z( 1 )
309  a( 2*n-1 ) = z( 2 )
310  ELSE
311  a( 2*n-2+izero ) = z( 1 )
312  a( n-1+izero ) = z( 2 )
313  a( izero ) = z( 3 )
314  END IF
315  END IF
316 *
317 * If IMAT > 7, set one column of the matrix to 0.
318 *
319  IF( .NOT.zerot ) THEN
320  izero = 0
321  ELSE IF( imat.EQ.8 ) THEN
322  izero = 1
323  z( 2 ) = a( n )
324  a( n ) = zero
325  IF( n.GT.1 ) THEN
326  z( 3 ) = a( 1 )
327  a( 1 ) = zero
328  END IF
329  ELSE IF( imat.EQ.9 ) THEN
330  izero = n
331  z( 1 ) = a( 3*n-2 )
332  z( 2 ) = a( 2*n-1 )
333  a( 3*n-2 ) = zero
334  a( 2*n-1 ) = zero
335  ELSE
336  izero = ( n+1 ) / 2
337  DO 20 i = izero, n - 1
338  a( 2*n-2+i ) = zero
339  a( n-1+i ) = zero
340  a( i ) = zero
341  20 CONTINUE
342  a( 3*n-2 ) = zero
343  a( 2*n-1 ) = zero
344  END IF
345  END IF
346 *
347 *+ TEST 1
348 * Factor A as L*U and compute the ratio
349 * norm(L*U - A) / (n * norm(A) * EPS )
350 *
351  CALL ccopy( n+2*m, a, 1, af, 1 )
352  srnamt = 'CGTTRF'
353  CALL cgttrf( n, af, af( m+1 ), af( n+m+1 ), af( n+2*m+1 ),
354  \$ iwork, info )
355 *
356 * Check error code from CGTTRF.
357 *
358  IF( info.NE.izero )
359  \$ CALL alaerh( path, 'CGTTRF', info, izero, ' ', n, n, 1,
360  \$ 1, -1, imat, nfail, nerrs, nout )
361  trfcon = info.NE.0
362 *
363  CALL cgtt01( n, a, a( m+1 ), a( n+m+1 ), af, af( m+1 ),
364  \$ af( n+m+1 ), af( n+2*m+1 ), iwork, work, lda,
365  \$ rwork, result( 1 ) )
366 *
367 * Print the test ratio if it is .GE. THRESH.
368 *
369  IF( result( 1 ).GE.thresh ) THEN
370  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
371  \$ CALL alahd( nout, path )
372  WRITE( nout, fmt = 9999 )n, imat, 1, result( 1 )
373  nfail = nfail + 1
374  END IF
375  nrun = nrun + 1
376 *
377  DO 50 itran = 1, 2
378  trans = transs( itran )
379  IF( itran.EQ.1 ) THEN
380  norm = 'O'
381  ELSE
382  norm = 'I'
383  END IF
384  anorm = clangt( norm, n, a, a( m+1 ), a( n+m+1 ) )
385 *
386  IF( .NOT.trfcon ) THEN
387 *
388 * Use CGTTRS to solve for one column at a time of
389 * inv(A), computing the maximum column sum as we go.
390 *
391  ainvnm = zero
392  DO 40 i = 1, n
393  DO 30 j = 1, n
394  x( j ) = zero
395  30 CONTINUE
396  x( i ) = one
397  CALL cgttrs( trans, n, 1, af, af( m+1 ),
398  \$ af( n+m+1 ), af( n+2*m+1 ), iwork, x,
399  \$ lda, info )
400  ainvnm = max( ainvnm, scasum( n, x, 1 ) )
401  40 CONTINUE
402 *
403 * Compute RCONDC = 1 / (norm(A) * norm(inv(A))
404 *
405  IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
406  rcondc = one
407  ELSE
408  rcondc = ( one / anorm ) / ainvnm
409  END IF
410  IF( itran.EQ.1 ) THEN
411  rcondo = rcondc
412  ELSE
413  rcondi = rcondc
414  END IF
415  ELSE
416  rcondc = zero
417  END IF
418 *
419 *+ TEST 7
420 * Estimate the reciprocal of the condition number of the
421 * matrix.
422 *
423  srnamt = 'CGTCON'
424  CALL cgtcon( norm, n, af, af( m+1 ), af( n+m+1 ),
425  \$ af( n+2*m+1 ), iwork, anorm, rcond, work,
426  \$ info )
427 *
428 * Check error code from CGTCON.
429 *
430  IF( info.NE.0 )
431  \$ CALL alaerh( path, 'CGTCON', info, 0, norm, n, n, -1,
432  \$ -1, -1, imat, nfail, nerrs, nout )
433 *
434  result( 7 ) = sget06( rcond, rcondc )
435 *
436 * Print the test ratio if it is .GE. THRESH.
437 *
438  IF( result( 7 ).GE.thresh ) THEN
439  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
440  \$ CALL alahd( nout, path )
441  WRITE( nout, fmt = 9997 )norm, n, imat, 7,
442  \$ result( 7 )
443  nfail = nfail + 1
444  END IF
445  nrun = nrun + 1
446  50 CONTINUE
447 *
448 * Skip the remaining tests if the matrix is singular.
449 *
450  IF( trfcon )
451  \$ GO TO 100
452 *
453  DO 90 irhs = 1, nns
454  nrhs = nsval( irhs )
455 *
456 * Generate NRHS random solution vectors.
457 *
458  ix = 1
459  DO 60 j = 1, nrhs
460  CALL clarnv( 2, iseed, n, xact( ix ) )
461  ix = ix + lda
462  60 CONTINUE
463 *
464  DO 80 itran = 1, 3
465  trans = transs( itran )
466  IF( itran.EQ.1 ) THEN
467  rcondc = rcondo
468  ELSE
469  rcondc = rcondi
470  END IF
471 *
472 * Set the right hand side.
473 *
474  CALL clagtm( trans, n, nrhs, one, a,
475  \$ a( m+1 ), a( n+m+1 ), xact, lda,
476  \$ zero, b, lda )
477 *
478 *+ TEST 2
479 * Solve op(A) * X = B and compute the residual.
480 *
481  CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
482  srnamt = 'CGTTRS'
483  CALL cgttrs( trans, n, nrhs, af, af( m+1 ),
484  \$ af( n+m+1 ), af( n+2*m+1 ), iwork, x,
485  \$ lda, info )
486 *
487 * Check error code from CGTTRS.
488 *
489  IF( info.NE.0 )
490  \$ CALL alaerh( path, 'CGTTRS', info, 0, trans, n, n,
491  \$ -1, -1, nrhs, imat, nfail, nerrs,
492  \$ nout )
493 *
494  CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
495  CALL cgtt02( trans, n, nrhs, a, a( m+1 ), a( n+m+1 ),
496  \$ x, lda, work, lda, result( 2 ) )
497 *
498 *+ TEST 3
499 * Check solution from generated exact solution.
500 *
501  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
502  \$ result( 3 ) )
503 *
504 *+ TESTS 4, 5, and 6
505 * Use iterative refinement to improve the solution.
506 *
507  srnamt = 'CGTRFS'
508  CALL cgtrfs( trans, n, nrhs, a, a( m+1 ), a( n+m+1 ),
509  \$ af, af( m+1 ), af( n+m+1 ),
510  \$ af( n+2*m+1 ), iwork, b, lda, x, lda,
511  \$ rwork, rwork( nrhs+1 ), work,
512  \$ rwork( 2*nrhs+1 ), info )
513 *
514 * Check error code from CGTRFS.
515 *
516  IF( info.NE.0 )
517  \$ CALL alaerh( path, 'CGTRFS', info, 0, trans, n, n,
518  \$ -1, -1, nrhs, imat, nfail, nerrs,
519  \$ nout )
520 *
521  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
522  \$ result( 4 ) )
523  CALL cgtt05( trans, n, nrhs, a, a( m+1 ), a( n+m+1 ),
524  \$ b, lda, x, lda, xact, lda, rwork,
525  \$ rwork( nrhs+1 ), result( 5 ) )
526 *
527 * Print information about the tests that did not pass the
528 * threshold.
529 *
530  DO 70 k = 2, 6
531  IF( result( k ).GE.thresh ) THEN
532  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
533  \$ CALL alahd( nout, path )
534  WRITE( nout, fmt = 9998 )trans, n, nrhs, imat,
535  \$ k, result( k )
536  nfail = nfail + 1
537  END IF
538  70 CONTINUE
539  nrun = nrun + 5
540  80 CONTINUE
541  90 CONTINUE
542  100 CONTINUE
543  110 CONTINUE
544 *
545 * Print a summary of the results.
546 *
547  CALL alasum( path, nout, nfail, nrun, nerrs )
548 *
549  9999 FORMAT( 12x, 'N =', i5, ',', 10x, ' type ', i2, ', test(', i2,
550  \$ ') = ', g12.5 )
551  9998 FORMAT( ' TRANS=''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
552  \$ i2, ', test(', i2, ') = ', g12.5 )
553  9997 FORMAT( ' NORM =''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
554  \$ ', test(', i2, ') = ', g12.5 )
555  RETURN
556 *
557 * End of CCHKGT
558 *
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:107
real function scasum(N, CX, INCX)
SCASUM
Definition: scasum.f:74
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
subroutine cgttrf(N, DL, D, DU, DU2, IPIV, INFO)
CGTTRF
Definition: cgttrf.f:126
subroutine clarnv(IDIST, ISEED, N, X)
CLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition: clarnv.f:101
real function sget06(RCOND, RCONDC)
SGET06
Definition: sget06.f:57
subroutine cgtcon(NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, INFO)
CGTCON
Definition: cgtcon.f:143
subroutine cgtrfs(TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CGTRFS
Definition: cgtrfs.f:212
subroutine clagtm(TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB)
CLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matrix...
Definition: clagtm.f:147
subroutine cgttrs(TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO)
CGTTRS
Definition: cgttrs.f:140
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
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
Definition: clatms.f:334
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
Definition: ccopy.f:83
subroutine cgtt01(N, DL, D, DU, DLF, DF, DUF, DU2, IPIV, WORK, LDWORK, RWORK, RESID)
CGTT01
Definition: cgtt01.f:136
subroutine cerrge(PATH, NUNIT)
CERRGE
Definition: cerrge.f:57
subroutine cgtt02(TRANS, N, NRHS, DL, D, DU, X, LDX, B, LDB, RESID)
CGTT02
Definition: cgtt02.f:126
real function clangt(NORM, N, DL, D, DU)
CLANGT returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: clangt.f:108
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
Definition: cget04.f:104
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
Definition: alasum.f:75
subroutine csscal(N, SA, CX, INCX)
CSSCAL
Definition: csscal.f:80
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
Definition: clatb4.f:123
subroutine cgtt05(TRANS, N, NRHS, DL, D, DU, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CGTT05
Definition: cgtt05.f:167
Here is the call graph for this function:
Here is the caller graph for this function: