OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
zdrvgb.f
Go to the documentation of this file.
1*> \brief \b ZDRVGB
2*
3* =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6* http://www.netlib.org/lapack/explore-html/
7*
8* Definition:
9* ===========
10*
11* SUBROUTINE ZDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA,
12* AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK,
13* RWORK, IWORK, NOUT )
14*
15* .. Scalar Arguments ..
16* LOGICAL TSTERR
17* INTEGER LA, LAFB, NN, NOUT, NRHS
18* DOUBLE PRECISION THRESH
19* ..
20* .. Array Arguments ..
21* LOGICAL DOTYPE( * )
22* INTEGER IWORK( * ), NVAL( * )
23* DOUBLE PRECISION RWORK( * ), S( * )
24* COMPLEX*16 A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ),
25* $ WORK( * ), X( * ), XACT( * )
26* ..
27*
28*
29*> \par Purpose:
30* =============
31*>
32*> \verbatim
33*>
34*> ZDRVGB tests the driver routines ZGBSV and -SVX.
35*> \endverbatim
36*
37* Arguments:
38* ==========
39*
40*> \param[in] DOTYPE
41*> \verbatim
42*> DOTYPE is LOGICAL array, dimension (NTYPES)
43*> The matrix types to be used for testing. Matrices of type j
44*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
45*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
46*> \endverbatim
47*>
48*> \param[in] NN
49*> \verbatim
50*> NN is INTEGER
51*> The number of values of N contained in the vector NVAL.
52*> \endverbatim
53*>
54*> \param[in] NVAL
55*> \verbatim
56*> NVAL is INTEGER array, dimension (NN)
57*> The values of the matrix column dimension N.
58*> \endverbatim
59*>
60*> \param[in] NRHS
61*> \verbatim
62*> NRHS is INTEGER
63*> The number of right hand side vectors to be generated for
64*> each linear system.
65*> \endverbatim
66*>
67*> \param[in] THRESH
68*> \verbatim
69*> THRESH is DOUBLE PRECISION
70*> The threshold value for the test ratios. A result is
71*> included in the output file if RESULT >= THRESH. To have
72*> every test ratio printed, use THRESH = 0.
73*> \endverbatim
74*>
75*> \param[in] TSTERR
76*> \verbatim
77*> TSTERR is LOGICAL
78*> Flag that indicates whether error exits are to be tested.
79*> \endverbatim
80*>
81*> \param[out] A
82*> \verbatim
83*> A is COMPLEX*16 array, dimension (LA)
84*> \endverbatim
85*>
86*> \param[in] LA
87*> \verbatim
88*> LA is INTEGER
89*> The length of the array A. LA >= (2*NMAX-1)*NMAX
90*> where NMAX is the largest entry in NVAL.
91*> \endverbatim
92*>
93*> \param[out] AFB
94*> \verbatim
95*> AFB is COMPLEX*16 array, dimension (LAFB)
96*> \endverbatim
97*>
98*> \param[in] LAFB
99*> \verbatim
100*> LAFB is INTEGER
101*> The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX
102*> where NMAX is the largest entry in NVAL.
103*> \endverbatim
104*>
105*> \param[out] ASAV
106*> \verbatim
107*> ASAV is COMPLEX*16 array, dimension (LA)
108*> \endverbatim
109*>
110*> \param[out] B
111*> \verbatim
112*> B is COMPLEX*16 array, dimension (NMAX*NRHS)
113*> \endverbatim
114*>
115*> \param[out] BSAV
116*> \verbatim
117*> BSAV is COMPLEX*16 array, dimension (NMAX*NRHS)
118*> \endverbatim
119*>
120*> \param[out] X
121*> \verbatim
122*> X is COMPLEX*16 array, dimension (NMAX*NRHS)
123*> \endverbatim
124*>
125*> \param[out] XACT
126*> \verbatim
127*> XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
128*> \endverbatim
129*>
130*> \param[out] S
131*> \verbatim
132*> S is DOUBLE PRECISION array, dimension (2*NMAX)
133*> \endverbatim
134*>
135*> \param[out] WORK
136*> \verbatim
137*> WORK is COMPLEX*16 array, dimension
138*> (NMAX*max(3,NRHS,NMAX))
139*> \endverbatim
140*>
141*> \param[out] RWORK
142*> \verbatim
143*> RWORK is DOUBLE PRECISION array, dimension
144*> (NMAX+2*NRHS)
145*> \endverbatim
146*>
147*> \param[out] IWORK
148*> \verbatim
149*> IWORK is INTEGER array, dimension (NMAX)
150*> \endverbatim
151*>
152*> \param[in] NOUT
153*> \verbatim
154*> NOUT is INTEGER
155*> The unit number for output.
156*> \endverbatim
157*
158* Authors:
159* ========
160*
161*> \author Univ. of Tennessee
162*> \author Univ. of California Berkeley
163*> \author Univ. of Colorado Denver
164*> \author NAG Ltd.
165*
166*> \ingroup complex16_lin
167*
168* =====================================================================
169 SUBROUTINE zdrvgb( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA,
170 $ AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK,
171 $ RWORK, IWORK, NOUT )
172*
173* -- LAPACK test routine --
174* -- LAPACK is a software package provided by Univ. of Tennessee, --
175* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
176*
177* .. Scalar Arguments ..
178 LOGICAL TSTERR
179 INTEGER LA, LAFB, NN, NOUT, NRHS
180 DOUBLE PRECISION THRESH
181* ..
182* .. Array Arguments ..
183 LOGICAL DOTYPE( * )
184 INTEGER IWORK( * ), NVAL( * )
185 DOUBLE PRECISION RWORK( * ), S( * )
186 COMPLEX*16 A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ),
187 $ work( * ), x( * ), xact( * )
188* ..
189*
190* =====================================================================
191*
192* .. Parameters ..
193 DOUBLE PRECISION ONE, ZERO
194 PARAMETER ( ONE = 1.0d+0, zero = 0.0d+0 )
195 INTEGER NTYPES
196 parameter( ntypes = 8 )
197 INTEGER NTESTS
198 parameter( ntests = 7 )
199 INTEGER NTRAN
200 parameter( ntran = 3 )
201* ..
202* .. Local Scalars ..
203 LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT
204 CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE
205 CHARACTER*3 PATH
206 INTEGER I, I1, I2, IEQUED, IFACT, IKL, IKU, IMAT, IN,
207 $ info, ioff, itran, izero, j, k, k1, kl, ku,
208 $ lda, ldafb, ldb, mode, n, nb, nbmin, nerrs,
209 $ nfact, nfail, nimat, nkl, nku, nrun, nt
210 DOUBLE PRECISION AINVNM, AMAX, ANORM, ANORMI, ANORMO, ANRMPV,
211 $ CNDNUM, COLCND, RCOND, RCONDC, RCONDI, RCONDO,
212 $ roldc, roldi, roldo, rowcnd, rpvgrw
213* ..
214* .. Local Arrays ..
215 CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN )
216 INTEGER ISEED( 4 ), ISEEDY( 4 )
217 DOUBLE PRECISION RDUM( 1 ), RESULT( NTESTS )
218* ..
219* .. External Functions ..
220 LOGICAL LSAME
221 DOUBLE PRECISION DGET06, DLAMCH, ZLANGB, ZLANGE, ZLANTB
222 EXTERNAL lsame, dget06, dlamch, zlangb, zlange, zlantb
223* ..
224* .. External Subroutines ..
225 EXTERNAL aladhd, alaerh, alasvm, xlaenv, zerrvx, zgbequ,
226 $ zgbsv, zgbsvx, zgbt01, zgbt02, zgbt05, zgbtrf,
227 $ zgbtrs, zget04, zlacpy, zlaqgb, zlarhs, zlaset,
228 $ zlatb4, zlatms
229* ..
230* .. Intrinsic Functions ..
231 INTRINSIC abs, dcmplx, max, min
232* ..
233* .. Scalars in Common ..
234 LOGICAL LERR, OK
235 CHARACTER*32 SRNAMT
236 INTEGER INFOT, NUNIT
237* ..
238* .. Common blocks ..
239 COMMON / infoc / infot, nunit, ok, lerr
240 COMMON / srnamc / srnamt
241* ..
242* .. Data statements ..
243 DATA iseedy / 1988, 1989, 1990, 1991 /
244 DATA transs / 'N', 'T', 'C' /
245 DATA facts / 'F', 'N', 'E' /
246 DATA equeds / 'N', 'R', 'C', 'B' /
247* ..
248* .. Executable Statements ..
249*
250* Initialize constants and the random number seed.
251*
252 path( 1: 1 ) = 'Zomplex precision'
253 path( 2: 3 ) = 'GB'
254 nrun = 0
255 nfail = 0
256 nerrs = 0
257 DO 10 i = 1, 4
258 iseed( i ) = iseedy( i )
259 10 CONTINUE
260*
261* Test the error exits
262*
263 IF( tsterr )
264 $ CALL zerrvx( path, nout )
265 infot = 0
266*
267* Set the block size and minimum block size for testing.
268*
269 nb = 1
270 nbmin = 2
271 CALL xlaenv( 1, nb )
272 CALL xlaenv( 2, nbmin )
273*
274* Do for each value of N in NVAL
275*
276 DO 150 in = 1, nn
277 n = nval( in )
278 ldb = max( n, 1 )
279 xtype = 'N'
280*
281* Set limits on the number of loop iterations.
282*
283 nkl = max( 1, min( n, 4 ) )
284 IF( n.EQ.0 )
285 $ nkl = 1
286 nku = nkl
287 nimat = ntypes
288 IF( n.LE.0 )
289 $ nimat = 1
290*
291 DO 140 ikl = 1, nkl
292*
293* Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes
294* it easier to skip redundant values for small values of N.
295*
296 IF( ikl.EQ.1 ) THEN
297 kl = 0
298 ELSE IF( ikl.EQ.2 ) THEN
299 kl = max( n-1, 0 )
300 ELSE IF( ikl.EQ.3 ) THEN
301 kl = ( 3*n-1 ) / 4
302 ELSE IF( ikl.EQ.4 ) THEN
303 kl = ( n+1 ) / 4
304 END IF
305 DO 130 iku = 1, nku
306*
307* Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order
308* makes it easier to skip redundant values for small
309* values of N.
310*
311 IF( iku.EQ.1 ) THEN
312 ku = 0
313 ELSE IF( iku.EQ.2 ) THEN
314 ku = max( n-1, 0 )
315 ELSE IF( iku.EQ.3 ) THEN
316 ku = ( 3*n-1 ) / 4
317 ELSE IF( iku.EQ.4 ) THEN
318 ku = ( n+1 ) / 4
319 END IF
320*
321* Check that A and AFB are big enough to generate this
322* matrix.
323*
324 lda = kl + ku + 1
325 ldafb = 2*kl + ku + 1
326 IF( lda*n.GT.la .OR. ldafb*n.GT.lafb ) THEN
327 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
328 $ CALL aladhd( nout, path )
329 IF( lda*n.GT.la ) THEN
330 WRITE( nout, fmt = 9999 )la, n, kl, ku,
331 $ n*( kl+ku+1 )
332 nerrs = nerrs + 1
333 END IF
334 IF( ldafb*n.GT.lafb ) THEN
335 WRITE( nout, fmt = 9998 )lafb, n, kl, ku,
336 $ n*( 2*kl+ku+1 )
337 nerrs = nerrs + 1
338 END IF
339 GO TO 130
340 END IF
341*
342 DO 120 imat = 1, nimat
343*
344* Do the tests only if DOTYPE( IMAT ) is true.
345*
346 IF( .NOT.dotype( imat ) )
347 $ GO TO 120
348*
349* Skip types 2, 3, or 4 if the matrix is too small.
350*
351 zerot = imat.GE.2 .AND. imat.LE.4
352 IF( zerot .AND. n.LT.imat-1 )
353 $ GO TO 120
354*
355* Set up parameters with ZLATB4 and generate a
356* test matrix with ZLATMS.
357*
358 CALL zlatb4( path, imat, n, n, TYPE, kl, ku, anorm,
359 $ mode, cndnum, dist )
360 rcondc = one / cndnum
361*
362 srnamt = 'ZLATMS'
363 CALL zlatms( n, n, dist, iseed, TYPE, rwork, mode,
364 $ cndnum, anorm, kl, ku, 'Z', a, lda, work,
365 $ info )
366*
367* Check the error code from ZLATMS.
368*
369 IF( info.NE.0 ) THEN
370 CALL alaerh( path, 'ZLATMS', info, 0, ' ', n, n,
371 $ kl, ku, -1, imat, nfail, nerrs, nout )
372 GO TO 120
373 END IF
374*
375* For types 2, 3, and 4, zero one or more columns of
376* the matrix to test that INFO is returned correctly.
377*
378 izero = 0
379 IF( zerot ) THEN
380 IF( imat.EQ.2 ) THEN
381 izero = 1
382 ELSE IF( imat.EQ.3 ) THEN
383 izero = n
384 ELSE
385 izero = n / 2 + 1
386 END IF
387 ioff = ( izero-1 )*lda
388 IF( imat.LT.4 ) THEN
389 i1 = max( 1, ku+2-izero )
390 i2 = min( kl+ku+1, ku+1+( n-izero ) )
391 DO 20 i = i1, i2
392 a( ioff+i ) = zero
393 20 CONTINUE
394 ELSE
395 DO 40 j = izero, n
396 DO 30 i = max( 1, ku+2-j ),
397 $ min( kl+ku+1, ku+1+( n-j ) )
398 a( ioff+i ) = zero
399 30 CONTINUE
400 ioff = ioff + lda
401 40 CONTINUE
402 END IF
403 END IF
404*
405* Save a copy of the matrix A in ASAV.
406*
407 CALL zlacpy( 'Full', kl+ku+1, n, a, lda, asav, lda )
408*
409 DO 110 iequed = 1, 4
410 equed = equeds( iequed )
411 IF( iequed.EQ.1 ) THEN
412 nfact = 3
413 ELSE
414 nfact = 1
415 END IF
416*
417 DO 100 ifact = 1, nfact
418 fact = facts( ifact )
419 prefac = lsame( fact, 'F' )
420 nofact = lsame( fact, 'N' )
421 equil = lsame( fact, 'E' )
422*
423 IF( zerot ) THEN
424 IF( prefac )
425 $ GO TO 100
426 rcondo = zero
427 rcondi = zero
428*
429 ELSE IF( .NOT.nofact ) THEN
430*
431* Compute the condition number for comparison
432* with the value returned by DGESVX (FACT =
433* 'N' reuses the condition number from the
434* previous iteration with FACT = 'F').
435*
436 CALL zlacpy( 'Full', kl+ku+1, n, asav, lda,
437 $ afb( kl+1 ), ldafb )
438 IF( equil .OR. iequed.GT.1 ) THEN
439*
440* Compute row and column scale factors to
441* equilibrate the matrix A.
442*
443 CALL zgbequ( n, n, kl, ku, afb( kl+1 ),
444 $ ldafb, s, s( n+1 ), rowcnd,
445 $ colcnd, amax, info )
446 IF( info.EQ.0 .AND. n.GT.0 ) THEN
447 IF( lsame( equed, 'R' ) ) THEN
448 rowcnd = zero
449 colcnd = one
450 ELSE IF( lsame( equed, 'C' ) ) THEN
451 rowcnd = one
452 colcnd = zero
453 ELSE IF( lsame( equed, 'B' ) ) THEN
454 rowcnd = zero
455 colcnd = zero
456 END IF
457*
458* Equilibrate the matrix.
459*
460 CALL zlaqgb( n, n, kl, ku, afb( kl+1 ),
461 $ ldafb, s, s( n+1 ),
462 $ rowcnd, colcnd, amax,
463 $ equed )
464 END IF
465 END IF
466*
467* Save the condition number of the
468* non-equilibrated system for use in ZGET04.
469*
470 IF( equil ) THEN
471 roldo = rcondo
472 roldi = rcondi
473 END IF
474*
475* Compute the 1-norm and infinity-norm of A.
476*
477 anormo = zlangb( '1', n, kl, ku, afb( kl+1 ),
478 $ ldafb, rwork )
479 anormi = zlangb( 'I', n, kl, ku, afb( kl+1 ),
480 $ ldafb, rwork )
481*
482* Factor the matrix A.
483*
484 CALL zgbtrf( n, n, kl, ku, afb, ldafb, iwork,
485 $ info )
486*
487* Form the inverse of A.
488*
489 CALL zlaset( 'Full', n, n, dcmplx( zero ),
490 $ dcmplx( one ), work, ldb )
491 srnamt = 'ZGBTRS'
492 CALL zgbtrs( 'No transpose', n, kl, ku, n,
493 $ afb, ldafb, iwork, work, ldb,
494 $ info )
495*
496* Compute the 1-norm condition number of A.
497*
498 ainvnm = zlange( '1', n, n, work, ldb,
499 $ rwork )
500 IF( anormo.LE.zero .OR. ainvnm.LE.zero ) THEN
501 rcondo = one
502 ELSE
503 rcondo = ( one / anormo ) / ainvnm
504 END IF
505*
506* Compute the infinity-norm condition number
507* of A.
508*
509 ainvnm = zlange( 'I', n, n, work, ldb,
510 $ rwork )
511 IF( anormi.LE.zero .OR. ainvnm.LE.zero ) THEN
512 rcondi = one
513 ELSE
514 rcondi = ( one / anormi ) / ainvnm
515 END IF
516 END IF
517*
518 DO 90 itran = 1, ntran
519*
520* Do for each value of TRANS.
521*
522 trans = transs( itran )
523 IF( itran.EQ.1 ) THEN
524 rcondc = rcondo
525 ELSE
526 rcondc = rcondi
527 END IF
528*
529* Restore the matrix A.
530*
531 CALL zlacpy( 'Full', kl+ku+1, n, asav, lda,
532 $ a, lda )
533*
534* Form an exact solution and set the right hand
535* side.
536*
537 srnamt = 'ZLARHS'
538 CALL zlarhs( path, xtype, 'Full', trans, n,
539 $ n, kl, ku, nrhs, a, lda, xact,
540 $ ldb, b, ldb, iseed, info )
541 xtype = 'C'
542 CALL zlacpy( 'Full', n, nrhs, b, ldb, bsav,
543 $ ldb )
544*
545 IF( nofact .AND. itran.EQ.1 ) THEN
546*
547* --- Test ZGBSV ---
548*
549* Compute the LU factorization of the matrix
550* and solve the system.
551*
552 CALL zlacpy( 'Full', kl+ku+1, n, a, lda,
553 $ afb( kl+1 ), ldafb )
554 CALL zlacpy( 'Full', n, nrhs, b, ldb, x,
555 $ ldb )
556*
557 srnamt = 'ZGBSV '
558 CALL zgbsv( n, kl, ku, nrhs, afb, ldafb,
559 $ iwork, x, ldb, info )
560*
561* Check error code from ZGBSV .
562*
563 IF( info.NE.izero )
564 $ CALL alaerh( path, 'ZGBSV ', info,
565 $ izero, ' ', n, n, kl, ku,
566 $ nrhs, imat, nfail, nerrs,
567 $ nout )
568*
569* Reconstruct matrix from factors and
570* compute residual.
571*
572 CALL zgbt01( n, n, kl, ku, a, lda, afb,
573 $ ldafb, iwork, work,
574 $ result( 1 ) )
575 nt = 1
576 IF( izero.EQ.0 ) THEN
577*
578* Compute residual of the computed
579* solution.
580*
581 CALL zlacpy( 'Full', n, nrhs, b, ldb,
582 $ work, ldb )
583 CALL zgbt02( 'No transpose', n, n, kl,
584 $ ku, nrhs, a, lda, x, ldb,
585 $ work, ldb, rwork,
586 $ result( 2 ) )
587*
588* Check solution from generated exact
589* solution.
590*
591 CALL zget04( n, nrhs, x, ldb, xact,
592 $ ldb, rcondc, result( 3 ) )
593 nt = 3
594 END IF
595*
596* Print information about the tests that did
597* not pass the threshold.
598*
599 DO 50 k = 1, nt
600 IF( result( k ).GE.thresh ) THEN
601 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
602 $ CALL aladhd( nout, path )
603 WRITE( nout, fmt = 9997 )'ZGBSV ',
604 $ n, kl, ku, imat, k, result( k )
605 nfail = nfail + 1
606 END IF
607 50 CONTINUE
608 nrun = nrun + nt
609 END IF
610*
611* --- Test ZGBSVX ---
612*
613 IF( .NOT.prefac )
614 $ CALL zlaset( 'Full', 2*kl+ku+1, n,
615 $ dcmplx( zero ),
616 $ dcmplx( zero ), afb, ldafb )
617 CALL zlaset( 'full', N, NRHS, DCMPLX( ZERO ),
618 $ DCMPLX( ZERO ), X, LDB )
619.GT..AND..GT. IF( IEQUED1 N0 ) THEN
620*
621* Equilibrate the matrix if FACT = 'F' and
622* EQUED = 'R', 'C', or 'B'.
623*
624 CALL ZLAQGB( N, N, KL, KU, A, LDA, S,
625 $ S( N+1 ), ROWCND, COLCND,
626 $ AMAX, EQUED )
627 END IF
628*
629* Solve the system and compute the condition
630* number and error bounds using ZGBSVX.
631*
632 SRNAMT = 'zgbsvx'
633 CALL ZGBSVX( FACT, TRANS, N, KL, KU, NRHS, A,
634 $ LDA, AFB, LDAFB, IWORK, EQUED,
635 $ S, S( LDB+1 ), B, LDB, X, LDB,
636 $ RCOND, RWORK, RWORK( NRHS+1 ),
637 $ WORK, RWORK( 2*NRHS+1 ), INFO )
638*
639* Check the error code from ZGBSVX.
640*
641.NE. IF( INFOIZERO )
642 $ CALL ALAERH( PATH, 'zgbsvx', INFO, IZERO,
643 $ FACT // TRANS, N, N, KL, KU,
644 $ NRHS, IMAT, NFAIL, NERRS,
645 $ NOUT )
646* Compare RWORK(2*NRHS+1) from ZGBSVX with the
647* computed reciprocal pivot growth RPVGRW
648*
649.NE..AND..LE. IF( INFO0 INFON) THEN
650 ANRMPV = ZERO
651 DO 70 J = 1, INFO
652 DO 60 I = MAX( KU+2-J, 1 ),
653 $ MIN( N+KU+1-J, KL+KU+1 )
654 ANRMPV = MAX( ANRMPV,
655 $ ABS( A( I+( J-1 )*LDA ) ) )
656 60 CONTINUE
657 70 CONTINUE
658 RPVGRW = ZLANTB( 'm', 'u', 'n', INFO,
659 $ MIN( INFO-1, KL+KU ),
660 $ AFB( MAX( 1, KL+KU+2-INFO ) ),
661 $ LDAFB, RDUM )
662.EQ. IF( RPVGRWZERO ) THEN
663 RPVGRW = ONE
664 ELSE
665 RPVGRW = ANRMPV / RPVGRW
666 END IF
667 ELSE
668 RPVGRW = ZLANTB( 'm', 'u', 'n', N, KL+KU,
669 $ AFB, LDAFB, RDUM )
670.EQ. IF( RPVGRWZERO ) THEN
671 RPVGRW = ONE
672 ELSE
673 RPVGRW = ZLANGB( 'm', N, KL, KU, A,
674 $ LDA, RDUM ) / RPVGRW
675 END IF
676 END IF
677 RESULT( 7 ) = ABS( RPVGRW-RWORK( 2*NRHS+1 ) )
678 $ / MAX( RWORK( 2*NRHS+1 ),
679 $ RPVGRW ) / DLAMCH( 'e' )
680*
681.NOT. IF( PREFAC ) THEN
682*
683* Reconstruct matrix from factors and
684* compute residual.
685*
686 CALL ZGBT01( N, N, KL, KU, A, LDA, AFB,
687 $ LDAFB, IWORK, WORK,
688 $ RESULT( 1 ) )
689 K1 = 1
690 ELSE
691 K1 = 2
692 END IF
693*
694.EQ. IF( INFO0 ) THEN
695 TRFCON = .FALSE.
696*
697* Compute residual of the computed solution.
698*
699 CALL ZLACPY( 'full', N, NRHS, BSAV, LDB,
700 $ WORK, LDB )
701 CALL ZGBT02( TRANS, N, N, KL, KU, NRHS,
702 $ ASAV, LDA, X, LDB, WORK, LDB,
703 $ RWORK( 2*NRHS+1 ),
704 $ RESULT( 2 ) )
705*
706* Check solution from generated exact
707* solution.
708*
709.OR..AND. IF( NOFACT ( PREFAC
710 $ LSAME( EQUED, 'n' ) ) ) THEN
711 CALL ZGET04( N, NRHS, X, LDB, XACT,
712 $ LDB, RCONDC, RESULT( 3 ) )
713 ELSE
714.EQ. IF( ITRAN1 ) THEN
715 ROLDC = ROLDO
716 ELSE
717 ROLDC = ROLDI
718 END IF
719 CALL ZGET04( N, NRHS, X, LDB, XACT,
720 $ LDB, ROLDC, RESULT( 3 ) )
721 END IF
722*
723* Check the error bounds from iterative
724* refinement.
725*
726 CALL ZGBT05( TRANS, N, KL, KU, NRHS, ASAV,
727 $ LDA, BSAV, LDB, X, LDB, XACT,
728 $ LDB, RWORK, RWORK( NRHS+1 ),
729 $ RESULT( 4 ) )
730 ELSE
731 TRFCON = .TRUE.
732 END IF
733*
734* Compare RCOND from ZGBSVX with the computed
735* value in RCONDC.
736*
737 RESULT( 6 ) = DGET06( RCOND, RCONDC )
738*
739* Print information about the tests that did
740* not pass the threshold.
741*
742.NOT. IF( TRFCON ) THEN
743 DO 80 K = K1, NTESTS
744.GE. IF( RESULT( K )THRESH ) THEN
745.EQ..AND..EQ. IF( NFAIL0 NERRS0 )
746 $ CALL ALADHD( NOUT, PATH )
747 IF( PREFAC ) THEN
748 WRITE( NOUT, FMT = 9995 )
749 $ 'zgbsvx', FACT, TRANS, N, KL,
750 $ KU, EQUED, IMAT, K,
751 $ RESULT( K )
752 ELSE
753 WRITE( NOUT, FMT = 9996 )
754 $ 'zgbsvx', FACT, TRANS, N, KL,
755 $ KU, IMAT, K, RESULT( K )
756 END IF
757 NFAIL = NFAIL + 1
758 END IF
759 80 CONTINUE
760 NRUN = NRUN + NTESTS - K1 + 1
761 ELSE
762.GE..AND..NOT. IF( RESULT( 1 )THRESH
763 $ PREFAC ) THEN
764.EQ..AND..EQ. IF( NFAIL0 NERRS0 )
765 $ CALL ALADHD( NOUT, PATH )
766 IF( PREFAC ) THEN
767 WRITE( NOUT, FMT = 9995 )'zgbsvx',
768 $ FACT, TRANS, N, KL, KU, EQUED,
769 $ IMAT, 1, RESULT( 1 )
770 ELSE
771 WRITE( NOUT, FMT = 9996 )'zgbsvx',
772 $ FACT, TRANS, N, KL, KU, IMAT, 1,
773 $ RESULT( 1 )
774 END IF
775 NFAIL = NFAIL + 1
776 NRUN = NRUN + 1
777 END IF
778.GE. IF( RESULT( 6 )THRESH ) THEN
779.EQ..AND..EQ. IF( NFAIL0 NERRS0 )
780 $ CALL ALADHD( NOUT, PATH )
781 IF( PREFAC ) THEN
782 WRITE( NOUT, FMT = 9995 )'zgbsvx',
783 $ FACT, TRANS, N, KL, KU, EQUED,
784 $ IMAT, 6, RESULT( 6 )
785 ELSE
786 WRITE( NOUT, FMT = 9996 )'zgbsvx',
787 $ FACT, TRANS, N, KL, KU, IMAT, 6,
788 $ RESULT( 6 )
789 END IF
790 NFAIL = NFAIL + 1
791 NRUN = NRUN + 1
792 END IF
793.GE. IF( RESULT( 7 )THRESH ) THEN
794.EQ..AND..EQ. IF( NFAIL0 NERRS0 )
795 $ CALL ALADHD( NOUT, PATH )
796 IF( PREFAC ) THEN
797 WRITE( NOUT, FMT = 9995 )'zgbsvx',
798 $ FACT, TRANS, N, KL, KU, EQUED,
799 $ IMAT, 7, RESULT( 7 )
800 ELSE
801 WRITE( NOUT, FMT = 9996 )'zgbsvx',
802 $ FACT, TRANS, N, KL, KU, IMAT, 7,
803 $ RESULT( 7 )
804 END IF
805 NFAIL = NFAIL + 1
806 NRUN = NRUN + 1
807 END IF
808 END IF
809 90 CONTINUE
810 100 CONTINUE
811 110 CONTINUE
812 120 CONTINUE
813 130 CONTINUE
814 140 CONTINUE
815 150 CONTINUE
816*
817* Print a summary of the results.
818*
819 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
820*
821 9999 FORMAT( ' *** in zdrvgb, la=', I5, ' is too small for n=', I5,
822 $ ', ku=', I5, ', kl=', I5, / ' ==> increase la to at least ',
823 $ I5 )
824 9998 FORMAT( ' *** in zdrvgb, lafb=', I5, ' is too small for n=', i5,
825 $ ', KU=', i5, ', KL=', i5, /
826 $ ' ==> Increase LAFB to at least ', i5 )
827 9997 FORMAT( 1x, a, ', N=', i5, ', KL=', i5, ', KU=', i5, ', type ',
828 $ i1, ', test(', i1, ')=', g12.5 )
829 9996 FORMAT( 1x, a, '( ''', a1, ''',''', a1, ''',', i5, ',', i5, ',',
830 $ i5, ',...), type ', i1, ', test(', i1, ')=', g12.5 )
831 9995 FORMAT( 1x, a, '( ''', a1, ''',''', a1, ''',', i5, ',', i5, ',',
832 $ i5, ',...), EQUED=''', a1, ''', type ', i1, ', test(', i1,
833 $ ')=', g12.5 )
834*
835 RETURN
836*
837* End of ZDRVGB
838*
839 END
xlaenv
subroutine xlaenv(ispec, nvalue)
XLAENV
Definition xlaenv.f:81
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
zlaqgb
subroutine zlaqgb(m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd, amax, equed)
ZLAQGB scales a general band matrix, using row and column scaling factors computed by sgbequ.
Definition zlaqgb.f:160
zgbtrs
subroutine zgbtrs(trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info)
ZGBTRS
Definition zgbtrs.f:138
zgbtrf
subroutine zgbtrf(m, n, kl, ku, ab, ldab, ipiv, info)
ZGBTRF
Definition zgbtrf.f:144
zgbequ
subroutine zgbequ(m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd, amax, info)
ZGBEQU
Definition zgbequ.f:154
zgbsvx
subroutine zgbsvx(fact, trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv, equed, r, c, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
ZGBSVX computes the solution to system of linear equations A * X = B for GB matrices
Definition zgbsvx.f:370
zgbsv
subroutine zgbsv(n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info)
ZGBSV computes the solution to system of linear equations A * X = B for GB matrices (simple driver)
Definition zgbsv.f:162
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
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
zlarhs
subroutine zlarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
ZLARHS
Definition zlarhs.f:208
zgbt02
subroutine zgbt02(trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
ZGBT02
Definition zgbt02.f:148
zdrvgb
subroutine zdrvgb(dotype, nn, nval, nrhs, thresh, tsterr, a, la, afb, lafb, asav, b, bsav, x, xact, s, work, rwork, iwork, nout)
ZDRVGB
Definition zdrvgb.f:172
zgbt01
subroutine zgbt01(m, n, kl, ku, a, lda, afac, ldafac, ipiv, work, resid)
ZGBT01
Definition zgbt01.f:126
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
zgbt05
subroutine zgbt05(trans, n, kl, ku, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
ZGBT05
Definition zgbt05.f:176
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
dget06
double precision function dget06(rcond, rcondc)
DGET06
Definition dget06.f:55
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
for
for(i8=*sizetab-1;i8 >=0;i8--)
Definition mumps_common.c:91