LAPACK  3.7.1
LAPACK: Linear Algebra PACKage

◆ zdrvpt()

subroutine zdrvpt ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NRHS,
double precision  THRESH,
logical  TSTERR,
complex*16, dimension( * )  A,
double precision, dimension( * )  D,
complex*16, dimension( * )  E,
complex*16, dimension( * )  B,
complex*16, dimension( * )  X,
complex*16, dimension( * )  XACT,
complex*16, dimension( * )  WORK,
double precision, dimension( * )  RWORK,
integer  NOUT 
)

ZDRVPT

Purpose: 
 ZDRVPT tests ZPTSV 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 DOUBLE PRECISION
          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*16 array, dimension (NMAX*2)
[out]D
          D is DOUBLE PRECISION array, dimension (NMAX*2)
[out]E
          E is COMPLEX*16 array, dimension (NMAX*2)
[out]B
          B is COMPLEX*16 array, dimension (NMAX*NRHS)
[out]X
          X is COMPLEX*16 array, dimension (NMAX*NRHS)
[out]XACT
          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
[out]WORK
          WORK is COMPLEX*16 array, dimension
                      (NMAX*max(3,NRHS))
[out]RWORK
          RWORK is DOUBLE PRECISION 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 zdrvpt.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  DOUBLE PRECISION thresh
152 * ..
153 * .. Array Arguments ..
154  LOGICAL dotype( * )
155  INTEGER nval( * )
156  DOUBLE PRECISION d( * ), rwork( * )
157  COMPLEX*16 a( * ), b( * ), e( * ), work( * ), x( * ),
158  $ xact( * )
159 * ..
160 *
161 * =====================================================================
162 *
163 * .. Parameters ..
164  DOUBLE PRECISION one, zero
165  parameter( one = 1.0d+0, zero = 0.0d+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  DOUBLE PRECISION ainvnm, anorm, cond, dmax, rcond, rcondc
179 * ..
180 * .. Local Arrays ..
181  INTEGER iseed( 4 ), iseedy( 4 )
182  DOUBLE PRECISION result( ntests ), z( 3 )
183 * ..
184 * .. External Functions ..
185  INTEGER idamax
186  DOUBLE PRECISION dget06, dzasum, zlanht
187  EXTERNAL idamax, dget06, dzasum, zlanht
188 * ..
189 * .. External Subroutines ..
190  EXTERNAL aladhd, alaerh, alasvm, dcopy, dlarnv, dscal,
191  $ zcopy, zdscal, zerrvx, zget04, zlacpy, zlaptm,
192  $ zlarnv, zlaset, zlatb4, zlatms, zptsv, zptsvx,
193  $ zptt01, zptt02, zptt05, zpttrf, zpttrs
194 * ..
195 * .. Intrinsic Functions ..
196  INTRINSIC abs, dcmplx, 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 ) = 'Zomplex 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 zerrvx( 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 ZLATB4.
245 *
246  CALL zlatb4( 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 = 'ZLATMS'
256  CALL zlatms( n, n, dist, iseed, TYPE, rwork, mode, cond,
257  $ anorm, kl, ku, 'B', a, 2, work, info )
258 *
259 * Check the error code from ZLATMS.
260 *
261  IF( info.NE.0 ) THEN
262  CALL alaerh( path, 'ZLATMS', 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 dlarnv( 2, iseed, n, d )
288  CALL zlarnv( 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 = idamax( n, d, 1 )
306  dmax = d( ix )
307  CALL dscal( n, anorm / dmax, d, 1 )
308  IF( n.GT.1 )
309  $ CALL zdscal( 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 zlarnv( 2, iseed, n, xact( ix ) )
368  ix = ix + lda
369  40 CONTINUE
370 *
371 * Set the right hand side.
372 *
373  CALL zlaptm( '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 ZPTSVX.
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 = zlanht( '1', n, d, e )
396 *
397  CALL dcopy( n, d, 1, d( n+1 ), 1 )
398  IF( n.GT.1 )
399  $ CALL zcopy( n-1, e, 1, e( n+1 ), 1 )
400 *
401 * Factor the matrix A.
402 *
403  CALL zpttrf( n, d( n+1 ), e( n+1 ), info )
404 *
405 * Use ZPTTRS 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 zpttrs( 'Lower', n, 1, d( n+1 ), e( n+1 ), x,
415  $ lda, info )
416  ainvnm = max( ainvnm, dzasum( 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 ZPTSV --
431 *
432  CALL dcopy( n, d, 1, d( n+1 ), 1 )
433  IF( n.GT.1 )
434  $ CALL zcopy( n-1, e, 1, e( n+1 ), 1 )
435  CALL zlacpy( '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 = 'ZPTSV '
440  CALL zptsv( n, nrhs, d( n+1 ), e( n+1 ), x, lda,
441  $ info )
442 *
443 * Check error code from ZPTSV .
444 *
445  IF( info.NE.izero )
446  $ CALL alaerh( path, 'ZPTSV ', 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 zptt01( n, d, e, d( n+1 ), e( n+1 ), work,
456  $ result( 1 ) )
457 *
458 * Compute the residual in the solution.
459 *
460  CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
461  CALL zptt02( 'Lower', n, nrhs, d, e, x, lda, work,
462  $ lda, result( 2 ) )
463 *
464 * Check solution from generated exact solution.
465 *
466  CALL zget04( 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 )'ZPTSV ', 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 ZPTSVX ---
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 zlaset( 'Full', n, nrhs, dcmplx( zero ),
501  $ dcmplx( zero ), x, lda )
502 *
503 * Solve the system and compute the condition number and
504 * error bounds using ZPTSVX.
505 *
506  srnamt = 'ZPTSVX'
507  CALL zptsvx( 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 ZPTSVX.
512 *
513  IF( info.NE.izero )
514  $ CALL alaerh( path, 'ZPTSVX', 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 zptt01( 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 zlacpy( 'Full', n, nrhs, b, lda, work, lda )
532  CALL zptt02( 'Lower', n, nrhs, d, e, x, lda, work,
533  $ lda, result( 2 ) )
534 *
535 * Check solution from generated exact solution.
536 *
537  CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
538  $ result( 3 ) )
539 *
540 * Check error bounds from iterative refinement.
541 *
542  CALL zptt05( 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 ) = dget06( 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 )'ZPTSVX', 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 ZDRVPT
580 *
zpttrs
subroutine zpttrs(UPLO, N, NRHS, D, E, B, LDB, INFO)
ZPTTRS
Definition: zpttrs.f:123
alasvm
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
Definition: alasvm.f:75
dcopy
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
Definition: dcopy.f:84
zptsvx
subroutine zptsvx(FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO)
ZPTSVX computes the solution to system of linear equations A * X = B for PT matrices ...
Definition: zptsvx.f:236
idamax
integer function idamax(N, DX, INCX)
IDAMAX
Definition: idamax.f:73
zget04
subroutine zget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
ZGET04
Definition: zget04.f:104
zcopy
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
Definition: zcopy.f:83
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
zpttrf
subroutine zpttrf(N, D, E, INFO)
ZPTTRF
Definition: zpttrf.f:94
zlacpy
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
Definition: zlacpy.f:105
dlarnv
subroutine dlarnv(IDIST, ISEED, N, X)
DLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition: dlarnv.f:99
zlatb4
subroutine zlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
ZLATB4
Definition: zlatb4.f:123
zlanht
double precision function zlanht(NORM, N, D, E)
ZLANHT 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: zlanht.f:103
zptt01
subroutine zptt01(N, D, E, DF, EF, WORK, RESID)
ZPTT01
Definition: zptt01.f:94
dzasum
double precision function dzasum(N, ZX, INCX)
DZASUM
Definition: dzasum.f:74
zlatms
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
Definition: zlatms.f:334
aladhd
subroutine aladhd(IOUNIT, PATH)
ALADHD
Definition: aladhd.f:92
zlaset
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
Definition: zlaset.f:108
zlaptm
subroutine zlaptm(UPLO, N, NRHS, ALPHA, D, E, X, LDX, BETA, B, LDB)
ZLAPTM
Definition: zlaptm.f:131
dscal
subroutine dscal(N, DA, DX, INCX)
DSCAL
Definition: dscal.f:81
zptt05
subroutine zptt05(N, NRHS, D, E, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
ZPTT05
Definition: zptt05.f:152
dget06
double precision function dget06(RCOND, RCONDC)
DGET06
Definition: dget06.f:57
zerrvx
subroutine zerrvx(PATH, NUNIT)
ZERRVX
Definition: zerrvx.f:57
zdscal
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
Definition: zdscal.f:80
zlarnv
subroutine zlarnv(IDIST, ISEED, N, X)
ZLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition: zlarnv.f:101
zptsv
subroutine zptsv(N, NRHS, D, E, B, LDB, INFO)
ZPTSV computes the solution to system of linear equations A * X = B for PT matrices ...
Definition: zptsv.f:117
zptt02
subroutine zptt02(UPLO, N, NRHS, D, E, X, LDX, B, LDB, RESID)
ZPTT02
Definition: zptt02.f:117
Here is the call graph for this function:
Here is the caller graph for this function: