3 * =========== DOCUMENTATION ===========
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
11 * SUBROUTINE ZDRVPT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, D,
12 * E, B, X, XACT, WORK, RWORK, NOUT )
14 * .. Scalar Arguments ..
16 * INTEGER NN, NOUT, NRHS
17 * DOUBLE PRECISION THRESH
19 * .. Array Arguments ..
22 * DOUBLE PRECISION D( * ), RWORK( * )
23 * COMPLEX*16 A( * ), B( * ), E( * ), WORK( * ), X( * ),
33 *> ZDRVPT tests ZPTSV and -SVX.
41 *> DOTYPE is LOGICAL array, dimension (NTYPES)
42 *> The matrix types to be used for testing. Matrices of type j
43 *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
44 *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
50 *> The number of values of N contained in the vector NVAL.
55 *> NVAL is INTEGER array, dimension (NN)
56 *> The values of the matrix dimension N.
62 *> The number of right hand side vectors to be generated for
63 *> each linear system.
68 *> THRESH is DOUBLE PRECISION
69 *> The threshold value for the test ratios. A result is
70 *> included in the output file if RESULT >= THRESH. To have
71 *> every test ratio printed, use THRESH = 0.
77 *> Flag that indicates whether error exits are to be tested.
82 *> A is COMPLEX*16 array, dimension (NMAX*2)
87 *> D is DOUBLE PRECISION array, dimension (NMAX*2)
92 *> E is COMPLEX*16 array, dimension (NMAX*2)
97 *> B is COMPLEX*16 array, dimension (NMAX*NRHS)
102 *> X is COMPLEX*16 array, dimension (NMAX*NRHS)
107 *> XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
112 *> WORK is COMPLEX*16 array, dimension
113 *> (NMAX*max(3,NRHS))
118 *> RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
124 *> The unit number for output.
130 *> \author Univ. of Tennessee
131 *> \author Univ. of California Berkeley
132 *> \author Univ. of Colorado Denver
135 *> \date November 2011
137 *> \ingroup complex16_lin
139 * =====================================================================
140 SUBROUTINE ZDRVPT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, D,
141 $ E, B, X, XACT, WORK, RWORK, NOUT )
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..--
148 * .. Scalar Arguments ..
150 INTEGER NN, NOUT, NRHS
151 DOUBLE PRECISION THRESH
153 * .. Array Arguments ..
156 DOUBLE PRECISION D( * ), RWORK( * )
157 COMPLEX*16 A( * ), B( * ), E( * ), WORK( * ), X( * ),
161 * =====================================================================
164 DOUBLE PRECISION ONE, ZERO
165 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
167 PARAMETER ( NTYPES = 12 )
169 PARAMETER ( NTESTS = 6 )
171 * .. Local Scalars ..
173 CHARACTER DIST, FACT, TYPE
175 INTEGER I, IA, IFACT, IMAT, IN, INFO, IX, IZERO, J, K,
176 $ K1, KL, KU, LDA, MODE, N, NERRS, NFAIL, NIMAT,
178 DOUBLE PRECISION AINVNM, ANORM, COND, DMAX, RCOND, RCONDC
181 INTEGER ISEED( 4 ), ISEEDY( 4 )
182 DOUBLE PRECISION RESULT( NTESTS ), Z( 3 )
184 * .. External Functions ..
186 DOUBLE PRECISION DGET06, DZASUM, ZLANHT
187 EXTERNAL IDAMAX, DGET06, DZASUM, ZLANHT
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
195 * .. Intrinsic Functions ..
196 INTRINSIC ABS, DCMPLX, MAX
198 * .. Scalars in Common ..
203 * .. Common blocks ..
204 COMMON / INFOC / INFOT, NUNIT, OK, LERR
205 COMMON / SRNAMC / SRNAMT
207 * .. Data statements ..
208 DATA ISEEDY / 0, 0, 0, 1 /
210 * .. Executable Statements ..
212 PATH( 1: 1 ) = 'Zomplex precision'
218 ISEED( I ) = ISEEDY( I )
221 * Test the error exits
224 $ CALL ZERRVX( PATH, NOUT )
229 * Do for each value of N in NVAL.
237 DO 110 IMAT = 1, NIMAT
239 * Do the tests only if DOTYPE( IMAT ) is true.
241 IF( N.GT.0 .AND. .NOT.DOTYPE( IMAT ) )
244 * Set up parameters with ZLATB4.
246 CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
249 ZEROT = IMAT.GE.8 .AND. IMAT.LE.10
252 * Type 1-6: generate a symmetric tridiagonal matrix of
253 * known condition number in lower triangular band storage.
256 CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, COND,
257 $ ANORM, KL, KU, 'B', A, 2, WORK, INFO )
259 * Check the error code from ZLATMS.
262 CALL ALAERH( PATH, 'ZLATMS', INFO, 0, ' ', N, N, KL,
263 $ KU, -1, IMAT, NFAIL, NERRS, NOUT )
268 * Copy the matrix to D and E.
280 * Type 7-12: generate a diagonally dominant matrix with
281 * unknown condition number in the vectors D and E.
283 IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 7 ) ) THEN
285 * Let D and E have values from [-1,1].
287 CALL DLARNV( 2, ISEED, N, D )
288 CALL ZLARNV( 2, ISEED, N-1, E )
290 * Make the tridiagonal matrix diagonally dominant.
293 D( 1 ) = ABS( D( 1 ) )
295 D( 1 ) = ABS( D( 1 ) ) + ABS( E( 1 ) )
296 D( N ) = ABS( D( N ) ) + ABS( E( N-1 ) )
298 D( I ) = ABS( D( I ) ) + ABS( E( I ) ) +
303 * Scale D and E so the maximum element is ANORM.
305 IX = IDAMAX( N, D, 1 )
307 CALL DSCAL( N, ANORM / DMAX, D, 1 )
309 $ CALL ZDSCAL( N-1, ANORM / DMAX, E, 1 )
311 ELSE IF( IZERO.GT.0 ) THEN
313 * Reuse the last matrix by copying back the zeroed out
316 IF( IZERO.EQ.1 ) THEN
320 ELSE IF( IZERO.EQ.N ) THEN
324 E( IZERO-1 ) = Z( 1 )
330 * For types 8-10, set one row and column of the matrix to
342 ELSE IF( IMAT.EQ.9 ) THEN
350 ELSE IF( IMAT.EQ.10 ) THEN
352 IF( IZERO.GT.1 ) THEN
353 Z( 1 ) = E( IZERO-1 )
363 * Generate NRHS random solution vectors.
367 CALL ZLARNV( 2, ISEED, N, XACT( IX ) )
371 * Set the right hand side.
373 CALL ZLAPTM( 'Lower', N, NRHS, ONE, D, E, XACT, LDA, ZERO,
377 IF( IFACT.EQ.1 ) THEN
383 * Compute the condition number for comparison with
384 * the value returned by ZPTSVX.
391 ELSE IF( IFACT.EQ.1 ) THEN
393 * Compute the 1-norm of A.
395 ANORM = ZLANHT( '1', N, D, E )
397 CALL DCOPY( N, D, 1, D( N+1 ), 1 )
399 $ CALL ZCOPY( N-1, E, 1, E( N+1 ), 1 )
401 * Factor the matrix A.
403 CALL ZPTTRF( N, D( N+1 ), E( N+1 ), INFO )
405 * Use ZPTTRS to solve for one column at a time of
406 * inv(A), computing the maximum column sum as we go.
414 CALL ZPTTRS( 'Lower', N, 1, D( N+1 ), E( N+1 ), X,
416 AINVNM = MAX( AINVNM, DZASUM( N, X, 1 ) )
419 * Compute the 1-norm condition number of A.
421 IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
424 RCONDC = ( ONE / ANORM ) / AINVNM
428 IF( IFACT.EQ.2 ) THEN
432 CALL DCOPY( N, D, 1, D( N+1 ), 1 )
434 $ CALL ZCOPY( N-1, E, 1, E( N+1 ), 1 )
435 CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
437 * Factor A as L*D*L' and solve the system A*X = B.
440 CALL ZPTSV( N, NRHS, D( N+1 ), E( N+1 ), X, LDA,
443 * Check error code from ZPTSV .
446 $ CALL ALAERH( PATH, 'ZPTSV ', INFO, IZERO, ' ', N,
447 $ N, 1, 1, NRHS, IMAT, NFAIL, NERRS,
450 IF( IZERO.EQ.0 ) THEN
452 * Check the factorization by computing the ratio
453 * norm(L*D*L' - A) / (n * norm(A) * EPS )
455 CALL ZPTT01( N, D, E, D( N+1 ), E( N+1 ), WORK,
458 * Compute the residual in the solution.
460 CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
461 CALL ZPTT02( 'Lower', N, NRHS, D, E, X, LDA, WORK,
464 * Check solution from generated exact solution.
466 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
471 * Print information about the tests that did not pass
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,
486 * --- Test ZPTSVX ---
488 IF( IFACT.GT.1 ) THEN
490 * Initialize D( N+1:2*N ) and E( N+1:2*N ) to zero.
500 CALL ZLASET( 'Full', N, NRHS, DCMPLX( ZERO ),
501 $ DCMPLX( ZERO ), X, LDA )
503 * Solve the system and compute the condition number and
504 * error bounds using 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 )
511 * Check the error code from ZPTSVX.
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
519 * Check the factorization by computing the ratio
520 * norm(L*D*L' - A) / (n * norm(A) * EPS )
523 CALL ZPTT01( N, D, E, D( N+1 ), E( N+1 ), WORK,
529 * Compute the residual in the solution.
531 CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
532 CALL ZPTT02( 'Lower', N, NRHS, D, E, X, LDA, WORK,
535 * Check solution from generated exact solution.
537 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
540 * Check error bounds from iterative refinement.
542 CALL ZPTT05( N, NRHS, D, E, B, LDA, X, LDA, XACT, LDA,
543 $ RWORK, RWORK( NRHS+1 ), RESULT( 4 ) )
548 * Check the reciprocal of the condition number.
550 RESULT( 6 ) = DGET06( RCOND, RCONDC )
552 * Print information about the tests that did not pass
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,
569 * Print a summary of the results.
571 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
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 )