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

CDRVPT

Purpose: 
 CDRVPT tests CPTSV and -SVX.
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]NRHS
          NRHS is INTEGER
          The number of right hand side vectors to be generated for
          each linear system.
[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*NRHS)
[out]X
          X is COMPLEX array, dimension (NMAX*NRHS)
[out]XACT
          XACT is COMPLEX array, dimension (NMAX*NRHS)
[out]WORK
          WORK is COMPLEX array, dimension
                      (NMAX*max(3,NRHS))
[out]RWORK
          RWORK is REAL array, dimension (NMAX+2*NRHS)
[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 142 of file cdrvpt.f.

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

Here is the call graph for this function:

Here is the caller graph for this function: