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 ssygv(ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, INFO)
SSYGV
subroutine sspgv(ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, INFO)
SSPGV
subroutine sspgvd(ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO)
SSPGVD
subroutine ssbgv(JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, INFO)
SSBGV
subroutine ssgt01(ITYPE, UPLO, N, M, A, LDA, B, LDB, Z, LDZ, D, WORK, RESULT)
SSGT01
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 ssbgvd(JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO)
SSBGVD
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 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 slabad(SMALL, LARGE)
SLABAD
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 sspgvx(ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO)
SSPGVX
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 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
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