172 SUBROUTINE ddrvgb( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA,
173 $ AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK,
174 $ RWORK, IWORK, NOUT )
182 INTEGER LA, LAFB, NN, NOUT, NRHS
183 DOUBLE PRECISION THRESH
187 INTEGER IWORK( * ), NVAL( * )
188 DOUBLE PRECISION A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ),
189 $ rwork( * ), s( * ), work( * ), x( * ),
196 DOUBLE PRECISION ONE, ZERO
197 PARAMETER ( ONE = 1.0d+0, zero = 0.0d+0 )
199 parameter( ntypes = 8 )
201 parameter( ntests = 7 )
203 parameter( ntran = 3 )
206 LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT
207 CHARACTER DIST, EQUED, FACT, TRANS,
TYPE, XTYPE
209 INTEGER I, I1, I2, IEQUED, IFACT, IKL, IKU, IMAT, IN,
210 $ info, ioff, itran, izero, j, k, k1, kl, ku,
211 $ lda, ldafb, ldb, mode, n, nb, nbmin, nerrs,
212 $ nfact, nfail, nimat, nkl, nku, nrun, nt,
214 DOUBLE PRECISION AINVNM, AMAX, ANORM, ANORMI, ANORMO, ANRMPV,
215 $ CNDNUM, COLCND, RCOND, RCONDC, RCONDI, RCONDO,
216 $ roldc, roldi, roldo, rowcnd, rpvgrw,
220 CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN )
221 INTEGER ISEED( 4 ), ISEEDY( 4 )
222 DOUBLE PRECISION RESULT( NTESTS ), BERR( NRHS ),
223 $ errbnds_n( nrhs, 3 ), errbnds_c( nrhs, 3 )
227 DOUBLE PRECISION DGET06, DLAMCH, DLANGB, DLANGE, DLANTB,
229 EXTERNAL lsame, dget06, dlamch, dlangb, dlange, dlantb,
239 INTRINSIC abs, max, min
247 COMMON / infoc / infot, nunit, ok, lerr
248 COMMON / srnamc / srnamt
251 DATA iseedy / 1988, 1989, 1990, 1991 /
252 DATA transs /
'N',
'T',
'C' /
253 DATA facts /
'F',
'N',
'E' /
254 DATA equeds /
'N',
'R',
'C',
'B' /
260 path( 1: 1 ) =
'Double precision'
266 iseed( i ) = iseedy( i )
272 $
CALL derrvx( path, nout )
291 nkl = max( 1, min( n, 4 ) )
306 ELSE IF( ikl.EQ.2 )
THEN
308 ELSE IF( ikl.EQ.3 )
THEN
310 ELSE IF( ikl.EQ.4 )
THEN
321 ELSE IF( iku.EQ.2 )
THEN
323 ELSE IF( iku.EQ.3 )
THEN
325 ELSE IF( iku.EQ.4 )
THEN
333 ldafb = 2*kl + ku + 1
334 IF( lda*n.GT.la .OR. ldafb*n.GT.lafb )
THEN
335 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
336 $
CALL aladhd( nout, path )
337 IF( lda*n.GT.la )
THEN
338 WRITE( nout, fmt = 9999 )la, n, kl, ku,
342 IF( ldafb*n.GT.lafb )
THEN
343 WRITE( nout, fmt = 9998 )lafb, n, kl, ku,
350 DO 120 imat = 1, nimat
354 IF( .NOT.dotype( imat ) )
359 zerot = imat.GE.2 .AND. imat.LE.4
360 IF( zerot .AND. n.LT.imat-1 )
366 CALL dlatb4( path, imat, n, n,
TYPE, kl, ku, anorm,
367 $ mode, cndnum, dist )
368 rcondc = one / cndnum
371 CALL dlatms( n, n, dist, iseed,
TYPE, rwork, mode,
372 $ cndnum, anorm, kl, ku,
'Z', a, lda, work,
378 CALL alaerh( path,
'DLATMS', info, 0,
' ', n, n,
379 $ kl, ku, -1, imat, nfail, nerrs, nout )
390 ELSE IF( imat.EQ.3 )
THEN
395 ioff = ( izero-1 )*lda
397 i1 = max( 1, ku+2-izero )
398 i2 = min( kl+ku+1, ku+1+( n-izero ) )
404 DO 30 i = max( 1, ku+2-j ),
405 $ min( kl+ku+1, ku+1+( n-j ) )
415 CALL dlacpy(
'Full', kl+ku+1, n, a, lda, asav, lda )
418 equed = equeds( iequed )
419 IF( iequed.EQ.1 )
THEN
425 DO 100 ifact = 1, nfact
426 fact = facts( ifact )
427 prefac = lsame( fact,
'F' )
428 nofact = lsame( fact,
'N' )
429 equil = lsame( fact,
'E' )
437 ELSE IF( .NOT.nofact )
THEN
444 CALL dlacpy(
'Full', kl+ku+1, n, asav, lda,
445 $ afb( kl+1 ), ldafb )
446 IF( equil .OR. iequed.GT.1 )
THEN
451 CALL dgbequ( n, n, kl, ku, afb( kl+1 ),
452 $ ldafb, s, s( n+1 ), rowcnd,
453 $ colcnd, amax, info )
454 IF( info.EQ.0 .AND. n.GT.0 )
THEN
455 IF( lsame( equed,
'R' ) )
THEN
458 ELSE IF( lsame( equed,
'C' ) )
THEN
461 ELSE IF( lsame( equed,
'B' ) )
THEN
468 CALL dlaqgb( n, n, kl, ku, afb( kl+1 ),
469 $ ldafb, s, s( n+1 ),
470 $ rowcnd, colcnd, amax,
485 anormo = dlangb(
'1', n, kl, ku, afb( kl+1 ),
487 anormi = dlangb(
'I', n, kl, ku, afb( kl+1 ),
492 CALL dgbtrf( n, n, kl, ku, afb, ldafb, iwork,
497 CALL dlaset(
'Full', n, n, zero, one, work,
500 CALL dgbtrs(
'No transpose', n, kl, ku, n,
501 $ afb, ldafb, iwork, work, ldb,
506 ainvnm = dlange(
'1', n, n, work, ldb,
508 IF( anormo.LE.zero .OR. ainvnm.LE.zero )
THEN
511 rcondo = ( one / anormo ) / ainvnm
517 ainvnm = dlange(
'I', n, n, work, ldb,
519 IF( anormi.LE.zero .OR. ainvnm.LE.zero )
THEN
522 rcondi = ( one / anormi ) / ainvnm
526 DO 90 itran = 1, ntran
530 trans = transs( itran )
531 IF( itran.EQ.1 )
THEN
539 CALL dlacpy(
'Full', kl+ku+1, n, asav, lda,
546 CALL dlarhs( path, xtype,
'Full', trans, n,
547 $ n, kl, ku, nrhs, a, lda, xact,
548 $ ldb, b, ldb, iseed, info )
550 CALL dlacpy(
'Full', n, nrhs, b, ldb, bsav,
553 IF( nofact .AND. itran.EQ.1 )
THEN
560 CALL dlacpy(
'Full', kl+ku+1, n, a, lda,
561 $ afb( kl+1 ), ldafb )
562 CALL dlacpy(
'Full', n, nrhs, b, ldb, x,
566 CALL dgbsv( n, kl, ku, nrhs, afb, ldafb,
567 $ iwork, x, ldb, info )
572 $
CALL alaerh( path,
'DGBSV ', info,
573 $ izero,
' ', n, n, kl, ku,
574 $ nrhs, imat, nfail, nerrs,
580 CALL dgbt01( n, n, kl, ku, a, lda, afb,
581 $ ldafb, iwork, work,
584 IF( izero.EQ.0 )
THEN
589 CALL dlacpy(
'Full', n, nrhs, b, ldb,
591 CALL dgbt02(
'No transpose', n, n, kl,
592 $ ku, nrhs, a, lda, x, ldb,
599 CALL dget04( n, nrhs, x, ldb, xact,
600 $ ldb, rcondc, result( 3 ) )
608 IF( result( k ).GE.thresh )
THEN
609 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
610 $
CALL aladhd( nout, path )
611 WRITE( nout, fmt = 9997 )
'DGBSV ',
612 $ n, kl, ku, imat, k, result( k )
622 $
CALL dlaset(
'Full', 2*kl+ku+1, n, zero,
624 CALL dlaset(
'Full', n, nrhs, zero, zero, x,
626 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
631 CALL dlaqgb( n, n, kl, ku, a, lda, s,
632 $ s( n+1 ), rowcnd, colcnd,
640 CALL dgbsvx( fact, trans, n, kl, ku, nrhs, a,
641 $ lda, afb, ldafb, iwork, equed,
642 $ s, s( n+1 ), b, ldb, x, ldb,
643 $ rcond, rwork, rwork( nrhs+1 ),
644 $ work, iwork( n+1 ), info )
649 $
CALL alaerh( path,
'DGBSVX', info, izero,
650 $ fact // trans, n, n, kl, ku,
651 $ nrhs, imat, nfail, nerrs,
660 DO 60 i = max( ku+2-j, 1 ),
661 $ min( n+ku+1-j, kl+ku+1 )
662 anrmpv = max( anrmpv,
663 $ abs( a( i+( j-1 )*lda ) ) )
666 rpvgrw = dlantb(
'M',
'U',
'N', info,
667 $ min( info-1, kl+ku ),
668 $ afb( max( 1, kl+ku+2-info ) ),
670 IF( rpvgrw.EQ.zero )
THEN
673 rpvgrw = anrmpv / rpvgrw
676 rpvgrw = dlantb(
'M',
'U',
'N', n, kl+ku,
678 IF( rpvgrw.EQ.zero )
THEN
681 rpvgrw = dlangb(
'M', n, kl, ku, a,
682 $ lda, work ) / rpvgrw
685 result( 7 ) = abs( rpvgrw-work( 1 ) ) /
686 $ max( work( 1 ), rpvgrw ) /
689 IF( .NOT.prefac )
THEN
694 CALL dgbt01( n, n, kl, ku, a, lda, afb,
695 $ ldafb, iwork, work,
707 CALL dlacpy(
'Full', n, nrhs, bsav, ldb,
709 CALL dgbt02( trans, n, n, kl, ku, nrhs,
710 $ asav, lda, x, ldb, work, ldb,
717 IF( nofact .OR. ( prefac .AND.
718 $ lsame( equed,
'N' ) ) )
THEN
719 CALL dget04( n, nrhs, x, ldb, xact,
720 $ ldb, rcondc, result( 3 ) )
722 IF( itran.EQ.1 )
THEN
727 CALL dget04( n, nrhs, x, ldb, xact,
728 $ ldb, roldc, result( 3 ) )
734 CALL dgbt05( trans, n, kl, ku, nrhs, asav,
735 $ lda, b, ldb, x, ldb, xact,
736 $ ldb, rwork, rwork( nrhs+1 ),
745 result( 6 ) = dget06( rcond, rcondc )
750 IF( .NOT.trfcon )
THEN
752 IF( result( k ).GE.thresh )
THEN
753 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
754 $
CALL aladhd( nout, path )
756 WRITE( nout, fmt = 9995 )
757 $
'DGBSVX', fact, trans, n, kl,
758 $ ku, equed, imat, k,
761 WRITE( nout, fmt = 9996 )
762 $
'DGBSVX', fact, trans, n, kl,
763 $ ku, imat, k, result( k )
770 IF( result( 1 ).GE.thresh .AND. .NOT.
772 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
773 $
CALL aladhd( nout, path )
775 WRITE( nout, fmt = 9995 )
'DGBSVX',
776 $ fact, trans, n, kl, ku, equed,
777 $ imat, 1, result( 1 )
779 WRITE( nout, fmt = 9996 )
'DGBSVX',
780 $ fact, trans, n, kl, ku, imat, 1,
786 IF( result( 6 ).GE.thresh )
THEN
787 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
788 $
CALL aladhd( nout, path )
790 WRITE( nout, fmt = 9995 )
'DGBSVX',
791 $ fact, trans, n, kl, ku, equed,
792 $ imat, 6, result( 6 )
794 WRITE( nout, fmt = 9996 )
'DGBSVX',
795 $ fact, trans, n, kl, ku, imat, 6,
801 IF( result( 7 ).GE.thresh )
THEN
802 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
803 $
CALL aladhd( nout, path )
805 WRITE( nout, fmt = 9995 )
'DGBSVX',
806 $ fact, trans, n, kl, ku, equed,
807 $ imat, 7, result( 7 )
809 WRITE( nout, fmt = 9996 )
'DGBSVX',
810 $ fact, trans, n, kl, ku, imat, 7,
823 CALL dlacpy(
'Full', kl+ku+1, n, asav, lda, a,
825 CALL dlacpy(
'Full', n, nrhs, bsav, ldb, b, ldb )
828 $
CALL dlaset(
'Full', 2*kl+ku+1, n, zero, zero,
830 CALL dlaset(
'Full', n, nrhs, zero, zero, x, ldb )
831 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
836 CALL dlaqgb( n, n, kl, ku, a, lda, s, s( n+1 ),
837 $ rowcnd, colcnd, amax, equed )
845 CALL dgbsvxx( fact, trans, n, kl, ku, nrhs, a, lda,
846 $ afb, ldafb, iwork, equed, s, s( n+1 ), b, ldb,
847 $ x, ldb, rcond, rpvgrw_svxx, berr, n_err_bnds,
848 $ errbnds_n, errbnds_c, 0, zero, work,
849 $ iwork( n+1 ), info )
853 IF( info.EQ.n+1 )
GOTO 90
854 IF( info.NE.izero )
THEN
855 CALL alaerh( path,
'DGBSVXX', info, izero,
856 $ fact // trans, n, n, -1, -1, nrhs,
857 $ imat, nfail, nerrs, nout )
865 IF ( info .GT. 0 .AND. info .LT. n+1 )
THEN
873 result( 7 ) = abs( rpvgrw-rpvgrw_svxx ) /
874 $ max( rpvgrw_svxx, rpvgrw ) /
877 IF( .NOT.prefac )
THEN
882 CALL dgbt01( n, n, kl, ku, a, lda, afb, ldafb,
883 $ iwork, work, result( 1 ) )
894 CALL dlacpy(
'Full', n, nrhs, bsav, ldb, work,
896 CALL dgbt02( trans, n, n, kl, ku, nrhs, asav,
897 $ lda, x, ldb, work, ldb, rwork,
902 IF( nofact .OR. ( prefac .AND. lsame( equed,
904 CALL dget04( n, nrhs, x, ldb, xact, ldb,
905 $ rcondc, result( 3 ) )
907 IF( itran.EQ.1 )
THEN
912 CALL dget04( n, nrhs, x, ldb, xact, ldb,
913 $ roldc, result( 3 ) )
922 result( 6 ) = dget06( rcond, rcondc )
927 IF( .NOT.trfcon )
THEN
929 IF( result( k ).GE.thresh )
THEN
930 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
931 $
CALL aladhd( nout, path )
933 WRITE( nout, fmt = 9995 )
'DGBSVXX',
934 $ fact, trans, n, kl, ku, equed,
935 $ imat, k, result( k )
937 WRITE( nout, fmt = 9996 )
'DGBSVXX',
938 $ fact, trans, n, kl, ku, imat, k,
946 IF( result( 1 ).GE.thresh .AND. .NOT.prefac )
948 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
949 $
CALL aladhd( nout, path )
951 WRITE( nout, fmt = 9995 )
'DGBSVXX', fact,
952 $ trans, n, kl, ku, equed, imat, 1,
955 WRITE( nout, fmt = 9996 )
'DGBSVXX', fact,
956 $ trans, n, kl, ku, imat, 1,
962 IF( result( 6 ).GE.thresh )
THEN
963 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
964 $
CALL aladhd( nout, path )
966 WRITE( nout, fmt = 9995 )
'DGBSVXX', fact,
967 $ trans, n, kl, ku, equed, imat, 6,
970 WRITE( nout, fmt = 9996 )
'DGBSVXX', fact,
971 $ trans, n, kl, ku, imat, 6,
977 IF( result( 7 ).GE.thresh )
THEN
978 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
979 $
CALL aladhd( nout, path )
981 WRITE( nout, fmt = 9995 )
'DGBSVXX', fact,
982 $ trans, n, kl, ku, equed, imat, 7,
985 WRITE( nout, fmt = 9996 )
'DGBSVXX', fact,
986 $ trans, n, kl, ku, imat, 7,
1004 CALL alasvm( path, nout, nfail, nrun, nerrs )
1010 9999
FORMAT(
' *** In DDRVGB, LA=', i5,
' is too small for N=', i5,
1011 $
', KU=', i5,
', KL=', i5, /
' ==> Increase LA to at least ',
1013 9998
FORMAT(
' *** In DDRVGB, LAFB=', i5,
' is too small for N=', i5,
1014 $
', KU=', i5,
', KL=', i5, /
1015 $
' ==> Increase LAFB to at least ', i5 )
1016 9997
FORMAT( 1x, a,
', N=', i5,
', KL=', i5,
', KU=', i5,
', type ',
1017 $ i1,
', test(', i1,
')=', g12.5 )
1018 9996
FORMAT( 1x, a,
'( ''', a1,
''',''', a1,
''',', i5,
',', i5,
',',
1019 $ i5,
',...), type ', i1,
', test(', i1,
')=', g12.5 )
1020 9995
FORMAT( 1x, a,
'( ''', a1,
''',''', a1,
''',', i5,
',', i5,
',',
1021 $ i5,
',...), EQUED=''', a1,
''', type ', i1,
', test(', i1,