354 SUBROUTINE ddrvsg( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
355 $ nounit, a, lda,
b, ldb, d, z, ldz, ab, bb, ap,
356 $ bp, work, nwork, iwork, liwork, result, info )
364 INTEGER info, lda, ldb, ldz, liwork, nounit, nsizes,
366 DOUBLE PRECISION thresh
370 INTEGER iseed( 4 ), iwork( * ), nn( * )
371 DOUBLE PRECISION a( lda, * ), ab( lda, * ), ap( * ),
372 $
b( ldb, * ), bb( ldb, * ), bp( * ), d( * ),
373 $ result( * ), work( * ), z( ldz, * )
379 DOUBLE PRECISION zero, one, ten
380 parameter( zero = 0.0d0, one = 1.0d0, ten = 10.0d0 )
382 parameter( maxtyp = 21 )
387 INTEGER i, ibtype, ibuplo, iinfo, ij, il, imode, itemp,
388 $ itype, iu,
j, jcol, jsize, jtype, ka, ka9, kb,
389 $ kb9, m, mtypes, n, nerrs, nmats, nmax, ntest,
391 DOUBLE PRECISION abstol, aninv, anorm, cond, ovfl, rtovfl,
392 $ rtunfl, ulp, ulpinv, unfl, vl, vu
395 INTEGER idumma( 1 ), ioldsd( 4 ), iseed2( 4 ),
396 $ kmagn( maxtyp ), kmode( maxtyp ),
410 INTRINSIC abs, dble, max, min, sqrt
413 DATA ktype / 1, 2, 5*4, 5*5, 3*8, 6*9 /
414 DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
416 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
429 nmax = max( nmax, nn(
j ) )
436 IF( nsizes.LT.0 )
THEN
438 ELSE IF( badnn )
THEN
440 ELSE IF( ntypes.LT.0 )
THEN
442 ELSE IF( lda.LE.1 .OR. lda.LT.nmax )
THEN
444 ELSE IF( ldz.LE.1 .OR. ldz.LT.nmax )
THEN
446 ELSE IF( 2*max( nmax, 3 )**2.GT.nwork )
THEN
448 ELSE IF( 2*max( nmax, 3 )**2.GT.liwork )
THEN
453 CALL
xerbla(
'DDRVSG', -info )
459 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
464 unfl =
dlamch(
'Safe minimum' )
465 ovfl =
dlamch(
'Overflow' )
469 rtunfl = sqrt( unfl )
470 rtovfl = sqrt( ovfl )
473 iseed2( i ) = iseed( i )
481 DO 650 jsize = 1, nsizes
483 aninv = one / dble( max( 1, n ) )
485 IF( nsizes.NE.1 )
THEN
486 mtypes = min( maxtyp, ntypes )
488 mtypes = min( maxtyp+1, ntypes )
493 DO 640 jtype = 1, mtypes
494 IF( .NOT.dotype( jtype ) )
500 ioldsd(
j ) = iseed(
j )
518 IF( mtypes.GT.maxtyp )
521 itype = ktype( jtype )
522 imode = kmode( jtype )
526 go to( 40, 50, 60 )kmagn( jtype )
533 anorm = ( rtovfl*ulp )*aninv
537 anorm = rtunfl*n*ulpinv
547 IF( itype.EQ.1 )
THEN
553 CALL
dlaset(
'Full', lda, n, zero, zero, a, lda )
555 ELSE IF( itype.EQ.2 )
THEN
561 CALL
dlaset(
'Full', lda, n, zero, zero, a, lda )
563 a( jcol, jcol ) = anorm
566 ELSE IF( itype.EQ.4 )
THEN
572 CALL
dlatms( n, n,
'S', iseed,
'S', work, imode, cond,
573 $ anorm, 0, 0,
'N', a, lda, work( n+1 ),
576 ELSE IF( itype.EQ.5 )
THEN
582 CALL
dlatms( n, n,
'S', iseed,
'S', work, imode, cond,
583 $ anorm, n, n,
'N', a, lda, work( n+1 ),
586 ELSE IF( itype.EQ.7 )
THEN
592 CALL
dlatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
593 $
'T',
'N', work( n+1 ), 1, one,
594 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
595 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
597 ELSE IF( itype.EQ.8 )
THEN
603 CALL
dlatmr( n, n,
'S', iseed,
'H', work, 6, one, one,
604 $
'T',
'N', work( n+1 ), 1, one,
605 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
606 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
608 ELSE IF( itype.EQ.9 )
THEN
622 IF( kb9.GT.ka9 )
THEN
626 ka = max( 0, min( n-1, ka9 ) )
627 kb = max( 0, min( n-1, kb9 ) )
628 CALL
dlatms( n, n,
'S', iseed,
'S', work, imode, cond,
629 $ anorm, ka, ka,
'N', a, lda, work( n+1 ),
637 IF( iinfo.NE.0 )
THEN
638 WRITE( nounit, fmt = 9999 )
'Generator', iinfo, n, jtype,
651 il = 1 + ( n-1 )*
dlarnd( 1, iseed2 )
652 iu = 1 + ( n-1 )*
dlarnd( 1, iseed2 )
681 CALL
dlatms( n, n,
'U', iseed,
'P', work, 5, ten, one,
682 $ kb, kb, uplo,
b, ldb, work( n+1 ),
689 CALL
dlacpy(
' ', n, n, a, lda, z, ldz )
690 CALL
dlacpy( uplo, n, n,
b, ldb, bb, ldb )
692 CALL
dsygv( ibtype,
'V', uplo, n, z, ldz, bb, ldb, d,
693 $ work, nwork, iinfo )
694 IF( iinfo.NE.0 )
THEN
695 WRITE( nounit, fmt = 9999 )
'DSYGV(V,' // uplo //
696 $
')', iinfo, n, jtype, ioldsd
698 IF( iinfo.LT.0 )
THEN
701 result( ntest ) = ulpinv
708 CALL
dsgt01( ibtype, uplo, n, n, a, lda,
b, ldb, z,
709 $ ldz, d, work, result( ntest ) )
715 CALL
dlacpy(
' ', n, n, a, lda, z, ldz )
716 CALL
dlacpy( uplo, n, n,
b, ldb, bb, ldb )
718 CALL
dsygvd( ibtype,
'V', uplo, n, z, ldz, bb, ldb, d,
719 $ work, nwork, iwork, liwork, iinfo )
720 IF( iinfo.NE.0 )
THEN
721 WRITE( nounit, fmt = 9999 )
'DSYGVD(V,' // uplo //
722 $
')', iinfo, n, jtype, ioldsd
724 IF( iinfo.LT.0 )
THEN
727 result( ntest ) = ulpinv
734 CALL
dsgt01( ibtype, uplo, n, n, a, lda,
b, ldb, z,
735 $ ldz, d, work, result( ntest ) )
741 CALL
dlacpy(
' ', n, n, a, lda, ab, lda )
742 CALL
dlacpy( uplo, n, n,
b, ldb, bb, ldb )
744 CALL
dsygvx( ibtype,
'V',
'A', uplo, n, ab, lda, bb,
745 $ ldb, vl, vu, il, iu, abstol, m, d, z,
746 $ ldz, work, nwork, iwork( n+1 ), iwork,
748 IF( iinfo.NE.0 )
THEN
749 WRITE( nounit, fmt = 9999 )
'DSYGVX(V,A' // uplo //
750 $
')', iinfo, n, jtype, ioldsd
752 IF( iinfo.LT.0 )
THEN
755 result( ntest ) = ulpinv
762 CALL
dsgt01( ibtype, uplo, n, n, a, lda,
b, ldb, z,
763 $ ldz, d, work, result( ntest ) )
767 CALL
dlacpy(
' ', n, n, a, lda, ab, lda )
768 CALL
dlacpy( uplo, n, n,
b, ldb, bb, ldb )
777 CALL
dsygvx( ibtype,
'V',
'V', uplo, n, ab, lda, bb,
778 $ ldb, vl, vu, il, iu, abstol, m, d, z,
779 $ ldz, work, nwork, iwork( n+1 ), iwork,
781 IF( iinfo.NE.0 )
THEN
782 WRITE( nounit, fmt = 9999 )
'DSYGVX(V,V,' //
783 $ uplo //
')', iinfo, n, jtype, ioldsd
785 IF( iinfo.LT.0 )
THEN
788 result( ntest ) = ulpinv
795 CALL
dsgt01( ibtype, uplo, n, m, a, lda,
b, ldb, z,
796 $ ldz, d, work, result( ntest ) )
800 CALL
dlacpy(
' ', n, n, a, lda, ab, lda )
801 CALL
dlacpy( uplo, n, n,
b, ldb, bb, ldb )
803 CALL
dsygvx( ibtype,
'V',
'I', uplo, n, ab, lda, bb,
804 $ ldb, vl, vu, il, iu, abstol, m, d, z,
805 $ ldz, work, nwork, iwork( n+1 ), iwork,
807 IF( iinfo.NE.0 )
THEN
808 WRITE( nounit, fmt = 9999 )
'DSYGVX(V,I,' //
809 $ uplo //
')', iinfo, n, jtype, ioldsd
811 IF( iinfo.LT.0 )
THEN
814 result( ntest ) = ulpinv
821 CALL
dsgt01( ibtype, uplo, n, m, a, lda,
b, ldb, z,
822 $ ldz, d, work, result( ntest ) )
832 IF(
lsame( uplo,
'U' ) )
THEN
852 CALL
dspgv( ibtype,
'V', uplo, n, ap, bp, d, z, ldz,
854 IF( iinfo.NE.0 )
THEN
855 WRITE( nounit, fmt = 9999 )
'DSPGV(V,' // uplo //
856 $
')', iinfo, n, jtype, ioldsd
858 IF( iinfo.LT.0 )
THEN
861 result( ntest ) = ulpinv
868 CALL
dsgt01( ibtype, uplo, n, n, a, lda,
b, ldb, z,
869 $ ldz, d, work, result( ntest ) )
877 IF(
lsame( uplo,
'U' ) )
THEN
897 CALL
dspgvd( ibtype,
'V', uplo, n, ap, bp, d, z, ldz,
898 $ work, nwork, iwork, liwork, iinfo )
899 IF( iinfo.NE.0 )
THEN
900 WRITE( nounit, fmt = 9999 )
'DSPGVD(V,' // uplo //
901 $
')', iinfo, n, jtype, ioldsd
903 IF( iinfo.LT.0 )
THEN
906 result( ntest ) = ulpinv
913 CALL
dsgt01( ibtype, uplo, n, n, a, lda,
b, ldb, z,
914 $ ldz, d, work, result( ntest ) )
922 IF(
lsame( uplo,
'U' ) )
THEN
942 CALL
dspgvx( ibtype,
'V',
'A', uplo, n, ap, bp, vl,
943 $ vu, il, iu, abstol, m, d, z, ldz, work,
944 $ iwork( n+1 ), iwork, info )
945 IF( iinfo.NE.0 )
THEN
946 WRITE( nounit, fmt = 9999 )
'DSPGVX(V,A' // uplo //
947 $
')', iinfo, n, jtype, ioldsd
949 IF( iinfo.LT.0 )
THEN
952 result( ntest ) = ulpinv
959 CALL
dsgt01( ibtype, uplo, n, m, a, lda,
b, ldb, z,
960 $ ldz, d, work, result( ntest ) )
966 IF(
lsame( uplo,
'U' ) )
THEN
988 CALL
dspgvx( ibtype,
'V',
'V', uplo, n, ap, bp, vl,
989 $ vu, il, iu, abstol, m, d, z, ldz, work,
990 $ iwork( n+1 ), iwork, info )
991 IF( iinfo.NE.0 )
THEN
992 WRITE( nounit, fmt = 9999 )
'DSPGVX(V,V' // uplo //
993 $
')', iinfo, n, jtype, ioldsd
995 IF( iinfo.LT.0 )
THEN
998 result( ntest ) = ulpinv
1005 CALL
dsgt01( ibtype, uplo, n, m, a, lda,
b, ldb, z,
1006 $ ldz, d, work, result( ntest ) )
1012 IF(
lsame( uplo,
'U' ) )
THEN
1016 ap( ij ) = a( i,
j )
1017 bp( ij ) =
b( i,
j )
1025 ap( ij ) = a( i,
j )
1026 bp( ij ) =
b( i,
j )
1032 CALL
dspgvx( ibtype,
'V',
'I', uplo, n, ap, bp, vl,
1033 $ vu, il, iu, abstol, m, d, z, ldz, work,
1034 $ iwork( n+1 ), iwork, info )
1035 IF( iinfo.NE.0 )
THEN
1036 WRITE( nounit, fmt = 9999 )
'DSPGVX(V,I' // uplo //
1037 $
')', iinfo, n, jtype, ioldsd
1039 IF( iinfo.LT.0 )
THEN
1042 result( ntest ) = ulpinv
1049 CALL
dsgt01( ibtype, uplo, n, m, a, lda,
b, ldb, z,
1050 $ ldz, d, work, result( ntest ) )
1054 IF( ibtype.EQ.1 )
THEN
1062 IF(
lsame( uplo,
'U' ) )
THEN
1064 DO 320 i = max( 1,
j-ka ),
j
1065 ab( ka+1+i-
j,
j ) = a( i,
j )
1067 DO 330 i = max( 1,
j-kb ),
j
1068 bb( kb+1+i-
j,
j ) =
b( i,
j )
1073 DO 350 i =
j, min( n,
j+ka )
1074 ab( 1+i-
j,
j ) = a( i,
j )
1076 DO 360 i =
j, min( n,
j+kb )
1077 bb( 1+i-
j,
j ) =
b( i,
j )
1082 CALL
dsbgv(
'V', uplo, n, ka, kb, ab, lda, bb, ldb,
1083 $ d, z, ldz, work, iinfo )
1084 IF( iinfo.NE.0 )
THEN
1085 WRITE( nounit, fmt = 9999 )
'DSBGV(V,' //
1086 $ uplo //
')', iinfo, n, jtype, ioldsd
1088 IF( iinfo.LT.0 )
THEN
1091 result( ntest ) = ulpinv
1098 CALL
dsgt01( ibtype, uplo, n, n, a, lda,
b, ldb, z,
1099 $ ldz, d, work, result( ntest ) )
1107 IF(
lsame( uplo,
'U' ) )
THEN
1109 DO 380 i = max( 1,
j-ka ),
j
1110 ab( ka+1+i-
j,
j ) = a( i,
j )
1112 DO 390 i = max( 1,
j-kb ),
j
1113 bb( kb+1+i-
j,
j ) =
b( i,
j )
1118 DO 410 i =
j, min( n,
j+ka )
1119 ab( 1+i-
j,
j ) = a( i,
j )
1121 DO 420 i =
j, min( n,
j+kb )
1122 bb( 1+i-
j,
j ) =
b( i,
j )
1127 CALL
dsbgvd(
'V', uplo, n, ka, kb, ab, lda, bb,
1128 $ ldb, d, z, ldz, work, nwork, iwork,
1130 IF( iinfo.NE.0 )
THEN
1131 WRITE( nounit, fmt = 9999 )
'DSBGVD(V,' //
1132 $ uplo //
')', iinfo, n, jtype, ioldsd
1134 IF( iinfo.LT.0 )
THEN
1137 result( ntest ) = ulpinv
1144 CALL
dsgt01( ibtype, uplo, n, n, a, lda,
b, ldb, z,
1145 $ ldz, d, work, result( ntest ) )
1153 IF(
lsame( uplo,
'U' ) )
THEN
1155 DO 440 i = max( 1,
j-ka ),
j
1156 ab( ka+1+i-
j,
j ) = a( i,
j )
1158 DO 450 i = max( 1,
j-kb ),
j
1159 bb( kb+1+i-
j,
j ) =
b( i,
j )
1164 DO 470 i =
j, min( n,
j+ka )
1165 ab( 1+i-
j,
j ) = a( i,
j )
1167 DO 480 i =
j, min( n,
j+kb )
1168 bb( 1+i-
j,
j ) =
b( i,
j )
1173 CALL
dsbgvx(
'V',
'A', uplo, n, ka, kb, ab, lda,
1174 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1175 $ iu, abstol, m, d, z, ldz, work,
1176 $ iwork( n+1 ), iwork, iinfo )
1177 IF( iinfo.NE.0 )
THEN
1178 WRITE( nounit, fmt = 9999 )
'DSBGVX(V,A' //
1179 $ uplo //
')', iinfo, n, jtype, ioldsd
1181 IF( iinfo.LT.0 )
THEN
1184 result( ntest ) = ulpinv
1191 CALL
dsgt01( ibtype, uplo, n, m, a, lda,
b, ldb, z,
1192 $ ldz, d, work, result( ntest ) )
1199 IF(
lsame( uplo,
'U' ) )
THEN
1201 DO 500 i = max( 1,
j-ka ),
j
1202 ab( ka+1+i-
j,
j ) = a( i,
j )
1204 DO 510 i = max( 1,
j-kb ),
j
1205 bb( kb+1+i-
j,
j ) =
b( i,
j )
1210 DO 530 i =
j, min( n,
j+ka )
1211 ab( 1+i-
j,
j ) = a( i,
j )
1213 DO 540 i =
j, min( n,
j+kb )
1214 bb( 1+i-
j,
j ) =
b( i,
j )
1221 CALL
dsbgvx(
'V',
'V', uplo, n, ka, kb, ab, lda,
1222 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1223 $ iu, abstol, m, d, z, ldz, work,
1224 $ iwork( n+1 ), iwork, iinfo )
1225 IF( iinfo.NE.0 )
THEN
1226 WRITE( nounit, fmt = 9999 )
'DSBGVX(V,V' //
1227 $ uplo //
')', iinfo, n, jtype, ioldsd
1229 IF( iinfo.LT.0 )
THEN
1232 result( ntest ) = ulpinv
1239 CALL
dsgt01( ibtype, uplo, n, m, a, lda,
b, ldb, z,
1240 $ ldz, d, work, result( ntest ) )
1246 IF(
lsame( uplo,
'U' ) )
THEN
1248 DO 560 i = max( 1,
j-ka ),
j
1249 ab( ka+1+i-
j,
j ) = a( i,
j )
1251 DO 570 i = max( 1,
j-kb ),
j
1252 bb( kb+1+i-
j,
j ) =
b( i,
j )
1257 DO 590 i =
j, min( n,
j+ka )
1258 ab( 1+i-
j,
j ) = a( i,
j )
1260 DO 600 i =
j, min( n,
j+kb )
1261 bb( 1+i-
j,
j ) =
b( i,
j )
1266 CALL
dsbgvx(
'V',
'I', uplo, n, ka, kb, ab, lda,
1267 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1268 $ iu, abstol, m, d, z, ldz, work,
1269 $ iwork( n+1 ), iwork, iinfo )
1270 IF( iinfo.NE.0 )
THEN
1271 WRITE( nounit, fmt = 9999 )
'DSBGVX(V,I' //
1272 $ uplo //
')', iinfo, n, jtype, ioldsd
1274 IF( iinfo.LT.0 )
THEN
1277 result( ntest ) = ulpinv
1284 CALL
dsgt01( ibtype, uplo, n, m, a, lda,
b, ldb, z,
1285 $ ldz, d, work, result( ntest ) )
1294 ntestt = ntestt + ntest
1295 CALL
dlafts(
'DSG', n, n, jtype, ntest, result, ioldsd,
1296 $ thresh, nounit, nerrs )
1302 CALL
dlasum(
'DSG', nounit, nerrs, ntestt )
1308 9999
FORMAT(
' DDRVSG: ', a,
' returned INFO=', i6,
'.', / 9
x,
'N=',
1309 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
LOGICAL function lsame(CA, CB)
LSAME
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
subroutine dsgt01(ITYPE, UPLO, N, M, A, LDA, B, LDB, Z, LDZ, D, WORK, RESULT)
DSGT01
subroutine dspgv(ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, INFO)
DSPGST
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dsbgvd(JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO)
DSBGST
subroutine dlabad(SMALL, LARGE)
DLABAD
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine dlatmr(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER, CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM, PACK, A, LDA, IWORK, INFO)
DLATMR
subroutine dsygvd(ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, IWORK, LIWORK, INFO)
DSYGST
subroutine dlasum(TYPE, IOUNIT, IE, NRUN)
DLASUM
subroutine dsygv(ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, INFO)
DSYGST
subroutine dsygvx(ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO)
DSYGST
subroutine dspgvx(ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO)
DSPGST
DOUBLE PRECISION function dlarnd(IDIST, ISEED)
DLARND
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine ddrvsg(NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, NOUNIT, A, LDA, B, LDB, D, Z, LDZ, AB, BB, AP, BP, WORK, NWORK, IWORK, LIWORK, RESULT, INFO)
DDRVSG
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
subroutine dsbgvx(JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO)
DSBGST
subroutine dspgvd(ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO)
DSPGST
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine dlafts(TYPE, M, N, IMAT, NTESTS, RESULT, ISEED, THRESH, IOUNIT, IE)
DLAFTS
subroutine dsbgv(JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, INFO)
DSBGST