174 SUBROUTINE cdrvgb( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA,
175 $ afb, lafb, asav,
b, bsav, x, xact, s, work,
176 $ rwork, iwork, nout )
185 INTEGER la, lafb, nn, nout, nrhs
190 INTEGER iwork( * ), nval( * )
191 REAL rwork( * ), s( * )
192 COMPLEX a( * ), afb( * ), asav( * ),
b( * ), bsav( * ),
193 $ work( * ), x( * ), xact( * )
200 parameter( one = 1.0e+0, zero = 0.0e+0 )
202 parameter( ntypes = 8 )
204 parameter( ntests = 7 )
206 parameter( ntran = 3 )
209 LOGICAL equil, nofact, prefac, trfcon, zerot
210 CHARACTER dist, equed, fact, trans, type, xtype
212 INTEGER i, i1, i2, iequed, ifact, ikl, iku, imat, in,
213 $ info, ioff, itran, izero,
j, k, k1, kl, ku,
214 $ lda, ldafb, ldb, mode, n, nb, nbmin, nerrs,
215 $ nfact, nfail, nimat, nkl, nku, nrun, nt,
217 REAL ainvnm, amax, anorm, anormi, anormo, anrmpv,
218 $ cndnum, colcnd, rcond, rcondc, rcondi, rcondo,
219 $ roldc, roldi, roldo, rowcnd, rpvgrw,
223 CHARACTER equeds( 4 ), facts( 3 ), transs( ntran )
224 INTEGER iseed( 4 ), iseedy( 4 )
225 REAL rdum( 1 ), result( ntests ), berr( nrhs ),
226 $ errbnds_n( nrhs,3 ), errbnds_c( nrhs, 3 )
242 INTRINSIC abs, cmplx, max, min
250 COMMON / infoc / infot, nunit, ok, lerr
251 COMMON / srnamc / srnamt
254 DATA iseedy / 1988, 1989, 1990, 1991 /
255 DATA transs /
'N',
'T',
'C' /
256 DATA facts /
'F',
'N',
'E' /
257 DATA equeds /
'N',
'R',
'C',
'B' /
263 path( 1: 1 ) =
'Complex precision'
269 iseed( i ) = iseedy( i )
275 $ CALL
cerrvx( path, nout )
294 nkl = max( 1, min( n, 4 ) )
309 ELSE IF( ikl.EQ.2 )
THEN
311 ELSE IF( ikl.EQ.3 )
THEN
313 ELSE IF( ikl.EQ.4 )
THEN
324 ELSE IF( iku.EQ.2 )
THEN
326 ELSE IF( iku.EQ.3 )
THEN
328 ELSE IF( iku.EQ.4 )
THEN
336 ldafb = 2*kl + ku + 1
337 IF( lda*n.GT.la .OR. ldafb*n.GT.lafb )
THEN
338 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
339 $ CALL
aladhd( nout, path )
340 IF( lda*n.GT.la )
THEN
341 WRITE( nout, fmt = 9999 )la, n, kl, ku,
345 IF( ldafb*n.GT.lafb )
THEN
346 WRITE( nout, fmt = 9998 )lafb, n, kl, ku,
353 DO 120 imat = 1, nimat
357 IF( .NOT.dotype( imat ) )
362 zerot = imat.GE.2 .AND. imat.LE.4
363 IF( zerot .AND. n.LT.imat-1 )
369 CALL
clatb4( path, imat, n, n, type, kl, ku, anorm,
370 $ mode, cndnum, dist )
371 rcondc = one / cndnum
374 CALL
clatms( n, n, dist, iseed, type, rwork, mode,
375 $ cndnum, anorm, kl, ku,
'Z', a, lda, work,
381 CALL
alaerh( path,
'CLATMS', info, 0,
' ', n, n,
382 $ kl, ku, -1, imat, nfail, nerrs, nout )
393 ELSE IF( imat.EQ.3 )
THEN
398 ioff = ( izero-1 )*lda
400 i1 = max( 1, ku+2-izero )
401 i2 = min( kl+ku+1, ku+1+( n-izero ) )
407 DO 30 i = max( 1, ku+2-
j ),
408 $ min( kl+ku+1, ku+1+( n-
j ) )
418 CALL
clacpy(
'Full', kl+ku+1, n, a, lda, asav, lda )
421 equed = equeds( iequed )
422 IF( iequed.EQ.1 )
THEN
428 DO 100 ifact = 1, nfact
429 fact = facts( ifact )
430 prefac =
lsame( fact,
'F' )
431 nofact =
lsame( fact,
'N' )
432 equil =
lsame( fact,
'E' )
440 ELSE IF( .NOT.nofact )
THEN
447 CALL
clacpy(
'Full', kl+ku+1, n, asav, lda,
448 $ afb( kl+1 ), ldafb )
449 IF( equil .OR. iequed.GT.1 )
THEN
454 CALL
cgbequ( n, n, kl, ku, afb( kl+1 ),
455 $ ldafb, s, s( n+1 ), rowcnd,
456 $ colcnd, amax, info )
457 IF( info.EQ.0 .AND. n.GT.0 )
THEN
458 IF(
lsame( equed,
'R' ) )
THEN
461 ELSE IF(
lsame( equed,
'C' ) )
THEN
464 ELSE IF(
lsame( equed,
'B' ) )
THEN
471 CALL
claqgb( n, n, kl, ku, afb( kl+1 ),
472 $ ldafb, s, s( n+1 ),
473 $ rowcnd, colcnd, amax,
488 anormo =
clangb(
'1', n, kl, ku, afb( kl+1 ),
490 anormi =
clangb(
'I', n, kl, ku, afb( kl+1 ),
495 CALL
cgbtrf( n, n, kl, ku, afb, ldafb, iwork,
500 CALL
claset(
'Full', n, n, cmplx( zero ),
501 $ cmplx( one ), work, ldb )
503 CALL
cgbtrs(
'No transpose', n, kl, ku, n,
504 $ afb, ldafb, iwork, work, ldb,
509 ainvnm =
clange(
'1', n, n, work, ldb,
511 IF( anormo.LE.zero .OR. ainvnm.LE.zero )
THEN
514 rcondo = ( one / anormo ) / ainvnm
520 ainvnm =
clange(
'I', n, n, work, ldb,
522 IF( anormi.LE.zero .OR. ainvnm.LE.zero )
THEN
525 rcondi = ( one / anormi ) / ainvnm
529 DO 90 itran = 1, ntran
533 trans = transs( itran )
534 IF( itran.EQ.1 )
THEN
542 CALL
clacpy(
'Full', kl+ku+1, n, asav, lda,
549 CALL
clarhs( path, xtype,
'Full', trans, n,
550 $ n, kl, ku, nrhs, a, lda, xact,
551 $ ldb,
b, ldb, iseed, info )
553 CALL
clacpy(
'Full', n, nrhs,
b, ldb, bsav,
556 IF( nofact .AND. itran.EQ.1 )
THEN
563 CALL
clacpy(
'Full', kl+ku+1, n, a, lda,
564 $ afb( kl+1 ), ldafb )
565 CALL
clacpy(
'Full', n, nrhs,
b, ldb, x,
569 CALL
cgbsv( n, kl, ku, nrhs, afb, ldafb,
570 $ iwork, x, ldb, info )
575 $ CALL
alaerh( path,
'CGBSV ', info,
576 $ izero,
' ', n, n, kl, ku,
577 $ nrhs, imat, nfail, nerrs,
583 CALL
cgbt01( n, n, kl, ku, a, lda, afb,
584 $ ldafb, iwork, work,
587 IF( izero.EQ.0 )
THEN
592 CALL
clacpy(
'Full', n, nrhs,
b, ldb,
594 CALL
cgbt02(
'No transpose', n, n, kl,
595 $ ku, nrhs, a, lda, x, ldb,
596 $ work, ldb, result( 2 ) )
601 CALL
cget04( n, nrhs, x, ldb, xact,
602 $ ldb, rcondc, result( 3 ) )
610 IF( result( k ).GE.thresh )
THEN
611 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
612 $ CALL
aladhd( nout, path )
613 WRITE( nout, fmt = 9997 )
'CGBSV ',
614 $ n, kl, ku, imat, k, result( k )
624 $ CALL
claset(
'Full', 2*kl+ku+1, n,
625 $ cmplx( zero ), cmplx( zero ),
627 CALL
claset(
'Full', n, nrhs, cmplx( zero ),
628 $ cmplx( zero ), x, ldb )
629 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
634 CALL
claqgb( n, n, kl, ku, a, lda, s,
635 $ s( n+1 ), rowcnd, colcnd,
643 CALL
cgbsvx( fact, trans, n, kl, ku, nrhs, a,
644 $ lda, afb, ldafb, iwork, equed,
645 $ s, s( ldb+1 ),
b, ldb, x, ldb,
646 $ rcond, rwork, rwork( nrhs+1 ),
647 $ work, rwork( 2*nrhs+1 ), info )
652 $ CALL
alaerh( path,
'CGBSVX', info, izero,
653 $ fact // trans, n, n, kl, ku,
654 $ nrhs, imat, nfail, nerrs,
663 DO 60 i = max( ku+2-
j, 1 ),
664 $ min( n+ku+1-
j, kl+ku+1 )
665 anrmpv = max( anrmpv,
666 $ abs( a( i+(
j-1 )*lda ) ) )
669 rpvgrw =
clantb(
'M',
'U',
'N', info,
670 $ min( info-1, kl+ku ),
671 $ afb( max( 1, kl+ku+2-info ) ),
673 IF( rpvgrw.EQ.zero )
THEN
676 rpvgrw = anrmpv / rpvgrw
679 rpvgrw =
clantb(
'M',
'U',
'N', n, kl+ku,
681 IF( rpvgrw.EQ.zero )
THEN
684 rpvgrw =
clangb(
'M', n, kl, ku, a,
685 $ lda, rdum ) / rpvgrw
688 result( 7 ) = abs( rpvgrw-rwork( 2*nrhs+1 ) )
689 $ / max( rwork( 2*nrhs+1 ),
690 $ rpvgrw ) /
slamch(
'E' )
692 IF( .NOT.prefac )
THEN
697 CALL
cgbt01( n, n, kl, ku, a, lda, afb,
698 $ ldafb, iwork, work,
710 CALL
clacpy(
'Full', n, nrhs, bsav, ldb,
712 CALL
cgbt02( trans, n, n, kl, ku, nrhs,
713 $ asav, lda, x, ldb, work, ldb,
719 IF( nofact .OR. ( prefac .AND.
720 $
lsame( equed,
'N' ) ) )
THEN
721 CALL
cget04( n, nrhs, x, ldb, xact,
722 $ ldb, rcondc, result( 3 ) )
724 IF( itran.EQ.1 )
THEN
729 CALL
cget04( n, nrhs, x, ldb, xact,
730 $ ldb, roldc, result( 3 ) )
736 CALL
cgbt05( trans, n, kl, ku, nrhs, asav,
737 $ lda, bsav, ldb, x, ldb, xact,
738 $ ldb, rwork, rwork( nrhs+1 ),
747 result( 6 ) =
sget06( rcond, rcondc )
752 IF( .NOT.trfcon )
THEN
754 IF( result( k ).GE.thresh )
THEN
755 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
756 $ CALL
aladhd( nout, path )
758 WRITE( nout, fmt = 9995 )
759 $
'CGBSVX', fact, trans, n, kl,
760 $ ku, equed, imat, k,
763 WRITE( nout, fmt = 9996 )
764 $
'CGBSVX', fact, trans, n, kl,
765 $ ku, imat, k, result( k )
772 IF( result( 1 ).GE.thresh .AND. .NOT.
774 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
775 $ CALL
aladhd( nout, path )
777 WRITE( nout, fmt = 9995 )
'CGBSVX',
778 $ fact, trans, n, kl, ku, equed,
779 $ imat, 1, result( 1 )
781 WRITE( nout, fmt = 9996 )
'CGBSVX',
782 $ fact, trans, n, kl, ku, imat, 1,
788 IF( result( 6 ).GE.thresh )
THEN
789 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
790 $ CALL
aladhd( nout, path )
792 WRITE( nout, fmt = 9995 )
'CGBSVX',
793 $ fact, trans, n, kl, ku, equed,
794 $ imat, 6, result( 6 )
796 WRITE( nout, fmt = 9996 )
'CGBSVX',
797 $ fact, trans, n, kl, ku, imat, 6,
803 IF( result( 7 ).GE.thresh )
THEN
804 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
805 $ CALL
aladhd( nout, path )
807 WRITE( nout, fmt = 9995 )
'CGBSVX',
808 $ fact, trans, n, kl, ku, equed,
809 $ imat, 7, result( 7 )
811 WRITE( nout, fmt = 9996 )
'CGBSVX',
812 $ fact, trans, n, kl, ku, imat, 7,
826 CALL
clacpy(
'Full', kl+ku+1, n, asav, lda, a,
828 CALL
clacpy(
'Full', n, nrhs, bsav, ldb,
b, ldb )
831 $ CALL
claset(
'Full', 2*kl+ku+1, n,
832 $ cmplx( zero ), cmplx( zero ),
834 CALL
claset(
'Full', n, nrhs,
835 $ cmplx( zero ), cmplx( zero ),
837 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
842 CALL
claqgb( n, n, kl, ku, a, lda, s,
843 $ s( n+1 ), rowcnd, colcnd, amax, equed )
851 CALL
cgbsvxx( fact, trans, n, kl, ku, nrhs, a, lda,
852 $ afb, ldafb, iwork, equed, s, s( n+1 ),
b, ldb,
853 $ x, ldb, rcond, rpvgrw_svxx, berr, n_err_bnds,
854 $ errbnds_n, errbnds_c, 0, zero, work,
859 IF( info.EQ.n+1 ) goto 90
860 IF( info.NE.izero )
THEN
861 CALL
alaerh( path,
'CGBSVXX', info, izero,
862 $ fact // trans, n, n, -1, -1, nrhs,
863 $ imat, nfail, nerrs, nout )
871 IF ( info .GT. 0 .AND. info .LT. n+1 )
THEN
879 result( 7 ) = abs( rpvgrw-rpvgrw_svxx ) /
880 $ max( rpvgrw_svxx, rpvgrw ) /
883 IF( .NOT.prefac )
THEN
888 CALL
cgbt01( n, n, kl, ku, a, lda, afb, ldafb,
889 $ iwork, work( 2*nrhs+1 ), result( 1 ) )
900 CALL
clacpy(
'Full', n, nrhs, bsav, ldb, work,
902 CALL
cgbt02( trans, n, n, kl, ku, nrhs, asav,
903 $ lda, x, ldb, work, ldb, result( 2 ) )
907 IF( nofact .OR. ( prefac .AND.
lsame( equed,
909 CALL
cget04( n, nrhs, x, ldb, xact, ldb,
910 $ rcondc, result( 3 ) )
912 IF( itran.EQ.1 )
THEN
917 CALL
cget04( n, nrhs, x, ldb, xact, ldb,
918 $ roldc, result( 3 ) )
927 result( 6 ) =
sget06( rcond, rcondc )
932 IF( .NOT.trfcon )
THEN
934 IF( result( k ).GE.thresh )
THEN
935 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
936 $ CALL
aladhd( nout, path )
938 WRITE( nout, fmt = 9995 )
'CGBSVXX',
939 $ fact, trans, n, kl, ku, equed,
940 $ imat, k, result( k )
942 WRITE( nout, fmt = 9996 )
'CGBSVXX',
943 $ fact, trans, n, kl, ku, imat, k,
951 IF( result( 1 ).GE.thresh .AND. .NOT.prefac )
953 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
954 $ CALL
aladhd( nout, path )
956 WRITE( nout, fmt = 9995 )
'CGBSVXX', fact,
957 $ trans, n, kl, ku, equed, imat, 1,
960 WRITE( nout, fmt = 9996 )
'CGBSVXX', fact,
961 $ trans, n, kl, ku, imat, 1,
967 IF( result( 6 ).GE.thresh )
THEN
968 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
969 $ CALL
aladhd( nout, path )
971 WRITE( nout, fmt = 9995 )
'CGBSVXX', fact,
972 $ trans, n, kl, ku, equed, imat, 6,
975 WRITE( nout, fmt = 9996 )
'CGBSVXX', fact,
976 $ trans, n, kl, ku, imat, 6,
982 IF( result( 7 ).GE.thresh )
THEN
983 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
984 $ CALL
aladhd( nout, path )
986 WRITE( nout, fmt = 9995 )
'CGBSVXX', fact,
987 $ trans, n, kl, ku, equed, imat, 7,
990 WRITE( nout, fmt = 9996 )
'CGBSVXX', fact,
991 $ trans, n, kl, ku, imat, 7,
1010 CALL
alasvm( path, nout, nfail, nrun, nerrs )
1017 9999
FORMAT(
' *** In CDRVGB, LA=', i5,
' is too small for N=', i5,
1018 $
', KU=', i5,
', KL=', i5, /
' ==> Increase LA to at least ',
1020 9998
FORMAT(
' *** In CDRVGB, LAFB=', i5,
' is too small for N=', i5,
1021 $
', KU=', i5,
', KL=', i5, /
1022 $
' ==> Increase LAFB to at least ', i5 )
1023 9997
FORMAT( 1x, a,
', N=', i5,
', KL=', i5,
', KU=', i5,
', type ',
1024 $ i1,
', test(', i1,
')=', g12.5 )
1025 9996
FORMAT( 1x, a,
'( ''', a1,
''',''', a1,
''',', i5,
',', i5,
',',
1026 $ i5,
',...), type ', i1,
', test(', i1,
')=', g12.5 )
1027 9995
FORMAT( 1x, a,
'( ''', a1,
''',''', a1,
''',', i5,
',', i5,
',',
1028 $ i5,
',...), EQUED=''', a1,
''', type ', i1,
', test(', i1,
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine cgbt05(TRANS, N, KL, KU, NRHS, AB, LDAB, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CGBT05
real function clange(NORM, M, N, A, LDA, WORK)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
real function clantb(NORM, UPLO, DIAG, N, K, AB, LDAB, WORK)
CLANTB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a triangular band matrix.
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine cdrvgb(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, IWORK, NOUT)
CDRVGB
subroutine claqgb(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED)
CLAQGB scales a general band matrix, using row and column scaling factors computed by sgbequ...
real function sget06(RCOND, RCONDC)
SGET06
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine cgbsvx(FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO)
CGBSVX computes the solution to system of linear equations A * X = B for GB matrices ...
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
logical function lsame(CA, CB)
LSAME
subroutine cgbsvxx(FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO)
CGBSVXX computes the solution to system of linear equations A * X = B for GB matrices ...
subroutine cgbsv(N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
CGBSV computes the solution to system of linear equations A * X = B for GB matrices (simple driver) ...
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine cgbt01(M, N, KL, KU, A, LDA, AFAC, LDAFAC, IPIV, WORK, RESID)
CGBT01
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
real function slamch(CMACH)
SLAMCH
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine aladhd(IOUNIT, PATH)
ALADHD
subroutine cebchvxx(THRESH, PATH)
CEBCHVXX
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine cerrvx(PATH, NUNIT)
CERRVX
subroutine cgbequ(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO)
CGBEQU
real function cla_gbrpvgrw(N, KL, KU, NCOLS, AB, LDAB, AFB, LDAFB)
CLA_GBRPVGRW computes the reciprocal pivot growth factor norm(A)/norm(U) for a general banded matrix...
subroutine cgbtrs(TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
CGBTRS
subroutine cgbtrf(M, N, KL, KU, AB, LDAB, IPIV, INFO)
CGBTRF
real function clangb(NORM, N, KL, KU, AB, LDAB, WORK)
CLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
subroutine cgbt02(TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, RESID)
CGBT02