LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ zdrvgt()

subroutine zdrvgt ( logical, dimension( * )  dotype,
integer  nn,
integer, dimension( * )  nval,
integer  nrhs,
double precision  thresh,
logical  tsterr,
complex*16, dimension( * )  a,
complex*16, dimension( * )  af,
complex*16, dimension( * )  b,
complex*16, dimension( * )  x,
complex*16, dimension( * )  xact,
complex*16, dimension( * )  work,
double precision, dimension( * )  rwork,
integer, dimension( * )  iwork,
integer  nout 
)

ZDRVGT

Purpose:
 ZDRVGT tests ZGTSV 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 sides, NRHS >= 0.
[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*4)
[out]AF
          AF is COMPLEX*16 array, dimension (NMAX*4)
[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)
[out]IWORK
          IWORK is INTEGER array, dimension (2*NMAX)
[in]NOUT
          NOUT is INTEGER
          The unit number for output.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 137 of file zdrvgt.f.

139*
140* -- LAPACK test routine --
141* -- LAPACK is a software package provided by Univ. of Tennessee, --
142* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
143*
144* .. Scalar Arguments ..
145 LOGICAL TSTERR
146 INTEGER NN, NOUT, NRHS
147 DOUBLE PRECISION THRESH
148* ..
149* .. Array Arguments ..
150 LOGICAL DOTYPE( * )
151 INTEGER IWORK( * ), NVAL( * )
152 DOUBLE PRECISION RWORK( * )
153 COMPLEX*16 A( * ), AF( * ), B( * ), WORK( * ), X( * ),
154 $ XACT( * )
155* ..
156*
157* =====================================================================
158*
159* .. Parameters ..
160 DOUBLE PRECISION ONE, ZERO
161 parameter( one = 1.0d+0, zero = 0.0d+0 )
162 INTEGER NTYPES
163 parameter( ntypes = 12 )
164 INTEGER NTESTS
165 parameter( ntests = 6 )
166* ..
167* .. Local Scalars ..
168 LOGICAL TRFCON, ZEROT
169 CHARACTER DIST, FACT, TRANS, TYPE
170 CHARACTER*3 PATH
171 INTEGER I, IFACT, IMAT, IN, INFO, ITRAN, IX, IZERO, J,
172 $ K, K1, KL, KOFF, KU, LDA, M, MODE, N, NERRS,
173 $ NFAIL, NIMAT, NRUN, NT
174 DOUBLE PRECISION AINVNM, ANORM, ANORMI, ANORMO, COND, RCOND,
175 $ RCONDC, RCONDI, RCONDO
176* ..
177* .. Local Arrays ..
178 CHARACTER TRANSS( 3 )
179 INTEGER ISEED( 4 ), ISEEDY( 4 )
180 DOUBLE PRECISION RESULT( NTESTS ), Z( 3 )
181* ..
182* .. External Functions ..
183 DOUBLE PRECISION DGET06, DZASUM, ZLANGT
184 EXTERNAL dget06, dzasum, zlangt
185* ..
186* .. External Subroutines ..
187 EXTERNAL aladhd, alaerh, alasvm, zcopy, zdscal, zerrvx,
188 $ zget04, zgtsv, zgtsvx, zgtt01, zgtt02, zgtt05,
189 $ zgttrf, zgttrs, zlacpy, zlagtm, zlarnv, zlaset,
190 $ zlatb4, zlatms
191* ..
192* .. Intrinsic Functions ..
193 INTRINSIC dcmplx, max
194* ..
195* .. Scalars in Common ..
196 LOGICAL LERR, OK
197 CHARACTER*32 SRNAMT
198 INTEGER INFOT, NUNIT
199* ..
200* .. Common blocks ..
201 COMMON / infoc / infot, nunit, ok, lerr
202 COMMON / srnamc / srnamt
203* ..
204* .. Data statements ..
205 DATA iseedy / 0, 0, 0, 1 / , transs / 'N', 'T',
206 $ 'C' /
207* ..
208* .. Executable Statements ..
209*
210 path( 1: 1 ) = 'Zomplex precision'
211 path( 2: 3 ) = 'GT'
212 nrun = 0
213 nfail = 0
214 nerrs = 0
215 DO 10 i = 1, 4
216 iseed( i ) = iseedy( i )
217 10 CONTINUE
218*
219* Test the error exits
220*
221 IF( tsterr )
222 $ CALL zerrvx( path, nout )
223 infot = 0
224*
225 DO 140 in = 1, nn
226*
227* Do for each value of N in NVAL.
228*
229 n = nval( in )
230 m = max( n-1, 0 )
231 lda = max( 1, n )
232 nimat = ntypes
233 IF( n.LE.0 )
234 $ nimat = 1
235*
236 DO 130 imat = 1, nimat
237*
238* Do the tests only if DOTYPE( IMAT ) is true.
239*
240 IF( .NOT.dotype( imat ) )
241 $ GO TO 130
242*
243* Set up parameters with ZLATB4.
244*
245 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
246 $ COND, DIST )
247*
248 zerot = imat.GE.8 .AND. imat.LE.10
249 IF( imat.LE.6 ) THEN
250*
251* Types 1-6: generate matrices of known condition number.
252*
253 koff = max( 2-ku, 3-max( 1, n ) )
254 srnamt = 'ZLATMS'
255 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE, COND,
256 $ ANORM, KL, KU, 'Z', AF( KOFF ), 3, WORK,
257 $ 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 130
265 END IF
266 izero = 0
267*
268 IF( n.GT.1 ) THEN
269 CALL zcopy( n-1, af( 4 ), 3, a, 1 )
270 CALL zcopy( n-1, af( 3 ), 3, a( n+m+1 ), 1 )
271 END IF
272 CALL zcopy( n, af( 2 ), 3, a( m+1 ), 1 )
273 ELSE
274*
275* Types 7-12: generate tridiagonal matrices with
276* unknown condition numbers.
277*
278 IF( .NOT.zerot .OR. .NOT.dotype( 7 ) ) THEN
279*
280* Generate a matrix with elements from [-1,1].
281*
282 CALL zlarnv( 2, iseed, n+2*m, a )
283 IF( anorm.NE.one )
284 $ CALL zdscal( n+2*m, anorm, a, 1 )
285 ELSE IF( izero.GT.0 ) THEN
286*
287* Reuse the last matrix by copying back the zeroed out
288* elements.
289*
290 IF( izero.EQ.1 ) THEN
291 a( n ) = z( 2 )
292 IF( n.GT.1 )
293 $ a( 1 ) = z( 3 )
294 ELSE IF( izero.EQ.n ) THEN
295 a( 3*n-2 ) = z( 1 )
296 a( 2*n-1 ) = z( 2 )
297 ELSE
298 a( 2*n-2+izero ) = z( 1 )
299 a( n-1+izero ) = z( 2 )
300 a( izero ) = z( 3 )
301 END IF
302 END IF
303*
304* If IMAT > 7, set one column of the matrix to 0.
305*
306 IF( .NOT.zerot ) THEN
307 izero = 0
308 ELSE IF( imat.EQ.8 ) THEN
309 izero = 1
310 z( 2 ) = dble( a( n ) )
311 a( n ) = zero
312 IF( n.GT.1 ) THEN
313 z( 3 ) = dble( a( 1 ) )
314 a( 1 ) = zero
315 END IF
316 ELSE IF( imat.EQ.9 ) THEN
317 izero = n
318 z( 1 ) = dble( a( 3*n-2 ) )
319 z( 2 ) = dble( a( 2*n-1 ) )
320 a( 3*n-2 ) = zero
321 a( 2*n-1 ) = zero
322 ELSE
323 izero = ( n+1 ) / 2
324 DO 20 i = izero, n - 1
325 a( 2*n-2+i ) = zero
326 a( n-1+i ) = zero
327 a( i ) = zero
328 20 CONTINUE
329 a( 3*n-2 ) = zero
330 a( 2*n-1 ) = zero
331 END IF
332 END IF
333*
334 DO 120 ifact = 1, 2
335 IF( ifact.EQ.1 ) THEN
336 fact = 'F'
337 ELSE
338 fact = 'N'
339 END IF
340*
341* Compute the condition number for comparison with
342* the value returned by ZGTSVX.
343*
344 IF( zerot ) THEN
345 IF( ifact.EQ.1 )
346 $ GO TO 120
347 rcondo = zero
348 rcondi = zero
349*
350 ELSE IF( ifact.EQ.1 ) THEN
351 CALL zcopy( n+2*m, a, 1, af, 1 )
352*
353* Compute the 1-norm and infinity-norm of A.
354*
355 anormo = zlangt( '1', n, a, a( m+1 ), a( n+m+1 ) )
356 anormi = zlangt( 'I', n, a, a( m+1 ), a( n+m+1 ) )
357*
358* Factor the matrix A.
359*
360 CALL zgttrf( n, af, af( m+1 ), af( n+m+1 ),
361 $ af( n+2*m+1 ), iwork, info )
362*
363* Use ZGTTRS to solve for one column at a time of
364* inv(A), computing the maximum column sum as we go.
365*
366 ainvnm = zero
367 DO 40 i = 1, n
368 DO 30 j = 1, n
369 x( j ) = zero
370 30 CONTINUE
371 x( i ) = one
372 CALL zgttrs( 'No transpose', n, 1, af, af( m+1 ),
373 $ af( n+m+1 ), af( n+2*m+1 ), iwork, x,
374 $ lda, info )
375 ainvnm = max( ainvnm, dzasum( n, x, 1 ) )
376 40 CONTINUE
377*
378* Compute the 1-norm condition number of A.
379*
380 IF( anormo.LE.zero .OR. ainvnm.LE.zero ) THEN
381 rcondo = one
382 ELSE
383 rcondo = ( one / anormo ) / ainvnm
384 END IF
385*
386* Use ZGTTRS to solve for one column at a time of
387* inv(A'), computing the maximum column sum as we go.
388*
389 ainvnm = zero
390 DO 60 i = 1, n
391 DO 50 j = 1, n
392 x( j ) = zero
393 50 CONTINUE
394 x( i ) = one
395 CALL zgttrs( 'Conjugate transpose', n, 1, af,
396 $ af( m+1 ), af( n+m+1 ), af( n+2*m+1 ),
397 $ iwork, x, lda, info )
398 ainvnm = max( ainvnm, dzasum( n, x, 1 ) )
399 60 CONTINUE
400*
401* Compute the infinity-norm condition number of A.
402*
403 IF( anormi.LE.zero .OR. ainvnm.LE.zero ) THEN
404 rcondi = one
405 ELSE
406 rcondi = ( one / anormi ) / ainvnm
407 END IF
408 END IF
409*
410 DO 110 itran = 1, 3
411 trans = transs( itran )
412 IF( itran.EQ.1 ) THEN
413 rcondc = rcondo
414 ELSE
415 rcondc = rcondi
416 END IF
417*
418* Generate NRHS random solution vectors.
419*
420 ix = 1
421 DO 70 j = 1, nrhs
422 CALL zlarnv( 2, iseed, n, xact( ix ) )
423 ix = ix + lda
424 70 CONTINUE
425*
426* Set the right hand side.
427*
428 CALL zlagtm( trans, n, nrhs, one, a, a( m+1 ),
429 $ a( n+m+1 ), xact, lda, zero, b, lda )
430*
431 IF( ifact.EQ.2 .AND. itran.EQ.1 ) THEN
432*
433* --- Test ZGTSV ---
434*
435* Solve the system using Gaussian elimination with
436* partial pivoting.
437*
438 CALL zcopy( n+2*m, a, 1, af, 1 )
439 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
440*
441 srnamt = 'ZGTSV '
442 CALL zgtsv( n, nrhs, af, af( m+1 ), af( n+m+1 ), x,
443 $ lda, info )
444*
445* Check error code from ZGTSV .
446*
447 IF( info.NE.izero )
448 $ CALL alaerh( path, 'ZGTSV ', info, izero, ' ',
449 $ n, n, 1, 1, nrhs, imat, nfail,
450 $ nerrs, nout )
451 nt = 1
452 IF( izero.EQ.0 ) THEN
453*
454* Check residual of computed solution.
455*
456 CALL zlacpy( 'Full', n, nrhs, b, lda, work,
457 $ lda )
458 CALL zgtt02( trans, n, nrhs, a, a( m+1 ),
459 $ a( n+m+1 ), x, lda, work, lda,
460 $ result( 2 ) )
461*
462* Check solution from generated exact solution.
463*
464 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
465 $ result( 3 ) )
466 nt = 3
467 END IF
468*
469* Print information about the tests that did not pass
470* the threshold.
471*
472 DO 80 k = 2, nt
473 IF( result( k ).GE.thresh ) THEN
474 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
475 $ CALL aladhd( nout, path )
476 WRITE( nout, fmt = 9999 )'ZGTSV ', n, imat,
477 $ k, result( k )
478 nfail = nfail + 1
479 END IF
480 80 CONTINUE
481 nrun = nrun + nt - 1
482 END IF
483*
484* --- Test ZGTSVX ---
485*
486 IF( ifact.GT.1 ) THEN
487*
488* Initialize AF to zero.
489*
490 DO 90 i = 1, 3*n - 2
491 af( i ) = zero
492 90 CONTINUE
493 END IF
494 CALL zlaset( 'Full', n, nrhs, dcmplx( zero ),
495 $ dcmplx( zero ), x, lda )
496*
497* Solve the system and compute the condition number and
498* error bounds using ZGTSVX.
499*
500 srnamt = 'ZGTSVX'
501 CALL zgtsvx( fact, trans, n, nrhs, a, a( m+1 ),
502 $ a( n+m+1 ), af, af( m+1 ), af( n+m+1 ),
503 $ af( n+2*m+1 ), iwork, b, lda, x, lda,
504 $ rcond, rwork, rwork( nrhs+1 ), work,
505 $ rwork( 2*nrhs+1 ), info )
506*
507* Check the error code from ZGTSVX.
508*
509 IF( info.NE.izero )
510 $ CALL alaerh( path, 'ZGTSVX', info, izero,
511 $ fact // trans, n, n, 1, 1, nrhs, imat,
512 $ nfail, nerrs, nout )
513*
514 IF( ifact.GE.2 ) THEN
515*
516* Reconstruct matrix from factors and compute
517* residual.
518*
519 CALL zgtt01( n, a, a( m+1 ), a( n+m+1 ), af,
520 $ af( m+1 ), af( n+m+1 ), af( n+2*m+1 ),
521 $ iwork, work, lda, rwork, result( 1 ) )
522 k1 = 1
523 ELSE
524 k1 = 2
525 END IF
526*
527 IF( info.EQ.0 ) THEN
528 trfcon = .false.
529*
530* Check residual of computed solution.
531*
532 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
533 CALL zgtt02( trans, n, nrhs, a, a( m+1 ),
534 $ a( n+m+1 ), x, lda, work, lda,
535 $ result( 2 ) )
536*
537* Check solution from generated exact solution.
538*
539 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
540 $ result( 3 ) )
541*
542* Check the error bounds from iterative refinement.
543*
544 CALL zgtt05( trans, n, nrhs, a, a( m+1 ),
545 $ a( n+m+1 ), b, lda, x, lda, xact, lda,
546 $ rwork, rwork( nrhs+1 ), result( 4 ) )
547 nt = 5
548 END IF
549*
550* Print information about the tests that did not pass
551* the threshold.
552*
553 DO 100 k = k1, nt
554 IF( result( k ).GE.thresh ) THEN
555 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
556 $ CALL aladhd( nout, path )
557 WRITE( nout, fmt = 9998 )'ZGTSVX', fact, trans,
558 $ n, imat, k, result( k )
559 nfail = nfail + 1
560 END IF
561 100 CONTINUE
562*
563* Check the reciprocal of the condition number.
564*
565 result( 6 ) = dget06( rcond, rcondc )
566 IF( result( 6 ).GE.thresh ) THEN
567 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
568 $ CALL aladhd( nout, path )
569 WRITE( nout, fmt = 9998 )'ZGTSVX', fact, trans, n,
570 $ imat, k, result( k )
571 nfail = nfail + 1
572 END IF
573 nrun = nrun + nt - k1 + 2
574*
575 110 CONTINUE
576 120 CONTINUE
577 130 CONTINUE
578 140 CONTINUE
579*
580* Print a summary of the results.
581*
582 CALL alasvm( path, nout, nfail, nrun, nerrs )
583*
584 9999 FORMAT( 1x, a, ', N =', i5, ', type ', i2, ', test ', i2,
585 $ ', ratio = ', g12.5 )
586 9998 FORMAT( 1x, a, ', FACT=''', a1, ''', TRANS=''', a1, ''', N =',
587 $ i5, ', type ', i2, ', test ', i2, ', ratio = ', g12.5 )
588 RETURN
589*
590* End of ZDRVGT
591*
alasvm
subroutine alasvm(type, nout, nfail, nrun, nerrs)
ALASVM
Definition alasvm.f:73
aladhd
subroutine aladhd(iounit, path)
ALADHD
Definition aladhd.f:90
alaerh
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
Definition alaerh.f:147
dget06
double precision function dget06(rcond, rcondc)
DGET06
Definition dget06.f:55
dzasum
double precision function dzasum(n, zx, incx)
DZASUM
Definition dzasum.f:72
zcopy
subroutine zcopy(n, zx, incx, zy, incy)
ZCOPY
Definition zcopy.f:81
zgtsv
subroutine zgtsv(n, nrhs, dl, d, du, b, ldb, info)
ZGTSV computes the solution to system of linear equations A * X = B for GT matrices
Definition zgtsv.f:124
zgtsvx
subroutine zgtsvx(fact, trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
ZGTSVX computes the solution to system of linear equations A * X = B for GT matrices
Definition zgtsvx.f:294
zgttrf
subroutine zgttrf(n, dl, d, du, du2, ipiv, info)
ZGTTRF
Definition zgttrf.f:124
zgttrs
subroutine zgttrs(trans, n, nrhs, dl, d, du, du2, ipiv, b, ldb, info)
ZGTTRS
Definition zgttrs.f:138
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:103
zlagtm
subroutine zlagtm(trans, n, nrhs, alpha, dl, d, du, x, ldx, beta, b, ldb)
ZLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matrix,...
Definition zlagtm.f:145
zlangt
double precision function zlangt(norm, n, dl, d, du)
ZLANGT returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition zlangt.f:106
zlarnv
subroutine zlarnv(idist, iseed, n, x)
ZLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition zlarnv.f:99
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:106
zdscal
subroutine zdscal(n, da, zx, incx)
ZDSCAL
Definition zdscal.f:78
zerrvx
subroutine zerrvx(path, nunit)
ZERRVX
Definition zerrvx.f:55
zget04
subroutine zget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
ZGET04
Definition zget04.f:102
zgtt01
subroutine zgtt01(n, dl, d, du, dlf, df, duf, du2, ipiv, work, ldwork, rwork, resid)
ZGTT01
Definition zgtt01.f:134
zgtt02
subroutine zgtt02(trans, n, nrhs, dl, d, du, x, ldx, b, ldb, resid)
ZGTT02
Definition zgtt02.f:124
zgtt05
subroutine zgtt05(trans, n, nrhs, dl, d, du, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
ZGTT05
Definition zgtt05.f:165
zlatb4
subroutine zlatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
ZLATB4
Definition zlatb4.f:121
zlatms
subroutine zlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
ZLATMS
Definition zlatms.f:332
Here is the call graph for this function:
Here is the caller graph for this function: