354 SUBROUTINE sdrvsg( 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,
370 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
371 REAL A( lda, * ), AB( lda, * ), AP( * ),
372 $ b( ldb, * ), bb( ldb, * ), bp( * ), d( * ),
373 $ result( * ), work( * ), z( ldz, * )
380 parameter ( zero = 0.0e0, one = 1.0e0, ten = 10.0e0 )
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 REAL 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 ),
402 EXTERNAL lsame, slamch, slarnd
410 INTRINSIC abs, max, min,
REAL, 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(
'SDRVSG', -info )
459 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
464 unfl = slamch(
'Safe minimum' )
465 ovfl = slamch(
'Overflow' )
467 ulp = slamch(
'Epsilon' )*slamch(
'Base' )
469 rtunfl = sqrt( unfl )
470 rtovfl = sqrt( ovfl )
473 iseed2( i ) = iseed( i )
481 DO 650 jsize = 1, nsizes
483 aninv = one /
REAL( 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 slaset(
'Full', lda, n, zero, zero, a, lda )
555 ELSE IF( itype.EQ.2 )
THEN
561 CALL slaset(
'Full', lda, n, zero, zero, a, lda )
563 a( jcol, jcol ) = anorm
566 ELSE IF( itype.EQ.4 )
THEN
572 CALL slatms( 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 slatms( 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 slatmr( 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 slatmr( 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 slatms( 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 )*slarnd( 1, iseed2 )
652 iu = 1 + ( n-1 )*slarnd( 1, iseed2 )
681 CALL slatms( n, n,
'U', iseed,
'P', work, 5, ten, one,
682 $ kb, kb, uplo, b, ldb, work( n+1 ),
689 CALL slacpy(
' ', n, n, a, lda, z, ldz )
690 CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
692 CALL ssygv( ibtype,
'V', uplo, n, z, ldz, bb, ldb, d,
693 $ work, nwork, iinfo )
694 IF( iinfo.NE.0 )
THEN
695 WRITE( nounit, fmt = 9999 )
'SSYGV(V,' // uplo //
696 $
')', iinfo, n, jtype, ioldsd
698 IF( iinfo.LT.0 )
THEN
701 result( ntest ) = ulpinv
708 CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
709 $ ldz, d, work, result( ntest ) )
715 CALL slacpy(
' ', n, n, a, lda, z, ldz )
716 CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
718 CALL ssygvd( 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 )
'SSYGVD(V,' // uplo //
722 $
')', iinfo, n, jtype, ioldsd
724 IF( iinfo.LT.0 )
THEN
727 result( ntest ) = ulpinv
734 CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
735 $ ldz, d, work, result( ntest ) )
741 CALL slacpy(
' ', n, n, a, lda, ab, lda )
742 CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
744 CALL ssygvx( 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 )
'SSYGVX(V,A' // uplo //
750 $
')', iinfo, n, jtype, ioldsd
752 IF( iinfo.LT.0 )
THEN
755 result( ntest ) = ulpinv
762 CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
763 $ ldz, d, work, result( ntest ) )
767 CALL slacpy(
' ', n, n, a, lda, ab, lda )
768 CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
777 CALL ssygvx( 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 )
'SSYGVX(V,V,' //
783 $ uplo //
')', iinfo, n, jtype, ioldsd
785 IF( iinfo.LT.0 )
THEN
788 result( ntest ) = ulpinv
795 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
796 $ ldz, d, work, result( ntest ) )
800 CALL slacpy(
' ', n, n, a, lda, ab, lda )
801 CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
803 CALL ssygvx( 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 )
'SSYGVX(V,I,' //
809 $ uplo //
')', iinfo, n, jtype, ioldsd
811 IF( iinfo.LT.0 )
THEN
814 result( ntest ) = ulpinv
821 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
822 $ ldz, d, work, result( ntest ) )
832 IF( lsame( uplo,
'U' ) )
THEN
852 CALL sspgv( ibtype,
'V', uplo, n, ap, bp, d, z, ldz,
854 IF( iinfo.NE.0 )
THEN
855 WRITE( nounit, fmt = 9999 )
'SSPGV(V,' // uplo //
856 $
')', iinfo, n, jtype, ioldsd
858 IF( iinfo.LT.0 )
THEN
861 result( ntest ) = ulpinv
868 CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
869 $ ldz, d, work, result( ntest ) )
877 IF( lsame( uplo,
'U' ) )
THEN
897 CALL sspgvd( 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 )
'SSPGVD(V,' // uplo //
901 $
')', iinfo, n, jtype, ioldsd
903 IF( iinfo.LT.0 )
THEN
906 result( ntest ) = ulpinv
913 CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
914 $ ldz, d, work, result( ntest ) )
922 IF( lsame( uplo,
'U' ) )
THEN
942 CALL sspgvx( 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 )
'SSPGVX(V,A' // uplo //
947 $
')', iinfo, n, jtype, ioldsd
949 IF( iinfo.LT.0 )
THEN
952 result( ntest ) = ulpinv
959 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
960 $ ldz, d, work, result( ntest ) )
966 IF( lsame( uplo,
'U' ) )
THEN
988 CALL sspgvx( 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 )
'SSPGVX(V,V' // uplo //
993 $
')', iinfo, n, jtype, ioldsd
995 IF( iinfo.LT.0 )
THEN
998 result( ntest ) = ulpinv
1005 CALL ssgt01( 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 sspgvx( 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 )
'SSPGVX(V,I' // uplo //
1037 $
')', iinfo, n, jtype, ioldsd
1039 IF( iinfo.LT.0 )
THEN
1042 result( ntest ) = ulpinv
1049 CALL ssgt01( 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 ssbgv(
'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 )
'SSBGV(V,' //
1086 $ uplo //
')', iinfo, n, jtype, ioldsd
1088 IF( iinfo.LT.0 )
THEN
1091 result( ntest ) = ulpinv
1098 CALL ssgt01( 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 ssbgvd(
'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 )
'SSBGVD(V,' //
1132 $ uplo //
')', iinfo, n, jtype, ioldsd
1134 IF( iinfo.LT.0 )
THEN
1137 result( ntest ) = ulpinv
1144 CALL ssgt01( 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 ssbgvx(
'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 )
'SSBGVX(V,A' //
1179 $ uplo //
')', iinfo, n, jtype, ioldsd
1181 IF( iinfo.LT.0 )
THEN
1184 result( ntest ) = ulpinv
1191 CALL ssgt01( 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 ssbgvx(
'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 )
'SSBGVX(V,V' //
1227 $ uplo //
')', iinfo, n, jtype, ioldsd
1229 IF( iinfo.LT.0 )
THEN
1232 result( ntest ) = ulpinv
1239 CALL ssgt01( 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 ssbgvx(
'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 )
'SSBGVX(V,I' //
1272 $ uplo //
')', iinfo, n, jtype, ioldsd
1274 IF( iinfo.LT.0 )
THEN
1277 result( ntest ) = ulpinv
1284 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1285 $ ldz, d, work, result( ntest ) )
1294 ntestt = ntestt + ntest
1295 CALL slafts(
'SSG', n, n, jtype, ntest, result, ioldsd,
1296 $ thresh, nounit, nerrs )
1302 CALL slasum(
'SSG', nounit, nerrs, ntestt )
1308 9999
FORMAT(
' SDRVSG: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
1309 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
subroutine ssgt01(ITYPE, UPLO, N, M, A, LDA, B, LDB, Z, LDZ, D, WORK, RESULT)
SSGT01
subroutine sspgvx(ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO)
SSPGVX
subroutine ssygv(ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, INFO)
SSYGV
subroutine ssbgvd(JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO)
SSBGVD
subroutine slatmr(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)
SLATMR
subroutine sspgv(ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, INFO)
SSPGV
subroutine slafts(TYPE, M, N, IMAT, NTESTS, RESULT, ISEED, THRESH, IOUNIT, IE)
SLAFTS
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine ssbgv(JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, INFO)
SSBGV
subroutine sdrvsg(NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, NOUNIT, A, LDA, B, LDB, D, Z, LDZ, AB, BB, AP, BP, WORK, NWORK, IWORK, LIWORK, RESULT, INFO)
SDRVSG
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine sspgvd(ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO)
SSPGVD
subroutine ssbgvx(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)
SSBGVX
subroutine ssygvx(ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO)
SSYGVX
subroutine ssygvd(ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, IWORK, LIWORK, INFO)
SSYGVD
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine slasum(TYPE, IOUNIT, IE, NRUN)
SLASUM