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 ),
401 DOUBLE PRECISION DLAMCH, DLARND
402 EXTERNAL lsame, dlamch, dlarnd
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' )
467 ulp = dlamch(
'Epsilon' )*dlamch(
'Base' )
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,
'.', / 9x,
'N=',
1309 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
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 dsygv(ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, INFO)
DSYGV
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 dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dspgvd(ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO)
DSPGVD
subroutine dsygvd(ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, IWORK, LIWORK, INFO)
DSYGVD
subroutine xerbla(SRNAME, INFO)
XERBLA
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 dlabad(SMALL, LARGE)
DLABAD
subroutine dspgvx(ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO)
DSPGVX
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)
DSBGVX
subroutine dlafts(TYPE, M, N, IMAT, NTESTS, RESULT, ISEED, THRESH, IOUNIT, IE)
DLAFTS
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)
DSYGVX
subroutine dlasum(TYPE, IOUNIT, IE, NRUN)
DLASUM
subroutine dsbgvd(JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO)
DSBGVD
subroutine dspgv(ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, INFO)
DSPGV
subroutine dsbgv(JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, INFO)
DSBGV
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