LAPACK  3.8.0
LAPACK: Linear Algebra PACKage

◆ cdrvpt()

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
December 2016

Definition at line 142 of file cdrvpt.f.

142 *
143 * -- LAPACK test routine (version 3.7.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 * December 2016
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,
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 *
subroutine cpttrf(N, D, E, INFO)
CPTTRF
Definition: cpttrf.f:94
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
Definition: alasvm.f:75
subroutine claptm(UPLO, N, NRHS, ALPHA, D, E, X, LDX, BETA, B, LDB)
CLAPTM
Definition: claptm.f:131
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
subroutine cptt05(N, NRHS, D, E, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CPTT05
Definition: cptt05.f:152
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 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
subroutine cpttrs(UPLO, N, NRHS, D, E, B, LDB, INFO)
CPTTRS
Definition: cpttrs.f:123
subroutine cerrvx(PATH, NUNIT)
CERRVX
Definition: cerrvx.f:57
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
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 cptt02(UPLO, N, NRHS, D, E, X, LDX, B, LDB, RESID)
CPTT02
Definition: cptt02.f:117
integer function isamax(N, SX, INCX)
ISAMAX
Definition: isamax.f:73
subroutine cptt01(N, D, E, DF, EF, WORK, RESID)
CPTT01
Definition: cptt01.f:94
subroutine aladhd(IOUNIT, PATH)
ALADHD
Definition: aladhd.f:92
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 slarnv(IDIST, ISEED, N, X)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition: slarnv.f:99
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
Definition: clatms.f:334
subroutine sscal(N, SA, SX, INCX)
SSCAL
Definition: sscal.f:81
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
Definition: ccopy.f:83
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
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
Definition: cget04.f:104
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
Definition: scopy.f:84
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
Here is the call graph for this function:
Here is the caller graph for this function: