360 SUBROUTINE sdrvsg2stg( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
361 $ nounit, a, lda, b, ldb, d, d2, z, ldz, ab,
362 $ bb, ap, bp, work, nwork, iwork, liwork,
373 INTEGER INFO, LDA, LDB, LDZ, LIWORK, NOUNIT, NSIZES,
379 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
380 REAL A( lda, * ), AB( lda, * ), AP( * ),
381 $ b( ldb, * ), bb( ldb, * ), bp( * ), d( * ),
382 $ d2( * ), result( * ), work( * ), z( ldz, * )
389 parameter ( zero = 0.0e0, one = 1.0e0, ten = 10.0e0 )
391 parameter ( maxtyp = 21 )
396 INTEGER I, IBTYPE, IBUPLO, IINFO, IJ, IL, IMODE, ITEMP,
397 $ itype, iu, j, jcol, jsize, jtype, ka, ka9, kb,
398 $ kb9, m, mtypes, n, nerrs, nmats, nmax, ntest,
400 REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
401 $ rtunfl, ulp, ulpinv, unfl, vl, vu, temp1, temp2
404 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
405 $ kmagn( maxtyp ), kmode( maxtyp ),
411 EXTERNAL lsame, slamch, slarnd
420 INTRINSIC abs,
REAL, MAX, MIN, SQRT
423 DATA ktype / 1, 2, 5*4, 5*5, 3*8, 6*9 /
424 DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
426 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
439 nmax = max( nmax, nn( j ) )
446 IF( nsizes.LT.0 )
THEN
448 ELSE IF( badnn )
THEN
450 ELSE IF( ntypes.LT.0 )
THEN
452 ELSE IF( lda.LE.1 .OR. lda.LT.nmax )
THEN
454 ELSE IF( ldz.LE.1 .OR. ldz.LT.nmax )
THEN
456 ELSE IF( 2*max( nmax, 3 )**2.GT.nwork )
THEN
458 ELSE IF( 2*max( nmax, 3 )**2.GT.liwork )
THEN
463 CALL xerbla(
'SDRVSG2STG', -info )
469 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
474 unfl = slamch(
'Safe minimum' )
475 ovfl = slamch(
'Overflow' )
477 ulp = slamch(
'Epsilon' )*slamch(
'Base' )
479 rtunfl = sqrt( unfl )
480 rtovfl = sqrt( ovfl )
483 iseed2( i ) = iseed( i )
491 DO 650 jsize = 1, nsizes
493 aninv = one /
REAL( MAX( 1, N ) )
495 IF( nsizes.NE.1 )
THEN
496 mtypes = min( maxtyp, ntypes )
498 mtypes = min( maxtyp+1, ntypes )
503 DO 640 jtype = 1, mtypes
504 IF( .NOT.dotype( jtype ) )
510 ioldsd( j ) = iseed( j )
528 IF( mtypes.GT.maxtyp )
531 itype = ktype( jtype )
532 imode = kmode( jtype )
536 GO TO ( 40, 50, 60 )kmagn( jtype )
543 anorm = ( rtovfl*ulp )*aninv
547 anorm = rtunfl*n*ulpinv
557 IF( itype.EQ.1 )
THEN
563 CALL slaset(
'Full', lda, n, zero, zero, a, lda )
565 ELSE IF( itype.EQ.2 )
THEN
571 CALL slaset(
'Full', lda, n, zero, zero, a, lda )
573 a( jcol, jcol ) = anorm
576 ELSE IF( itype.EQ.4 )
THEN
582 CALL slatms( n, n,
'S', iseed,
'S', work, imode, cond,
583 $ anorm, 0, 0,
'N', a, lda, work( n+1 ),
586 ELSE IF( itype.EQ.5 )
THEN
592 CALL slatms( n, n,
'S', iseed,
'S', work, imode, cond,
593 $ anorm, n, n,
'N', a, lda, work( n+1 ),
596 ELSE IF( itype.EQ.7 )
THEN
602 CALL slatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
603 $
'T',
'N', work( n+1 ), 1, one,
604 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
605 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
607 ELSE IF( itype.EQ.8 )
THEN
613 CALL slatmr( n, n,
'S', iseed,
'H', work, 6, one, one,
614 $
'T',
'N', work( n+1 ), 1, one,
615 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
616 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
618 ELSE IF( itype.EQ.9 )
THEN
632 IF( kb9.GT.ka9 )
THEN
636 ka = max( 0, min( n-1, ka9 ) )
637 kb = max( 0, min( n-1, kb9 ) )
638 CALL slatms( n, n,
'S', iseed,
'S', work, imode, cond,
639 $ anorm, ka, ka,
'N', a, lda, work( n+1 ),
647 IF( iinfo.NE.0 )
THEN
648 WRITE( nounit, fmt = 9999 )
'Generator', iinfo, n, jtype,
661 il = 1 + int( ( n-1 )*slarnd( 1, iseed2 ) )
662 iu = 1 + int( ( n-1 )*slarnd( 1, iseed2 ) )
691 CALL slatms( n, n,
'U', iseed,
'P', work, 5, ten, one,
692 $ kb, kb, uplo, b, ldb, work( n+1 ),
699 CALL slacpy(
' ', n, n, a, lda, z, ldz )
700 CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
702 CALL ssygv( ibtype,
'V', uplo, n, z, ldz, bb, ldb, d,
703 $ work, nwork, iinfo )
704 IF( iinfo.NE.0 )
THEN
705 WRITE( nounit, fmt = 9999 )
'SSYGV(V,' // uplo //
706 $
')', iinfo, n, jtype, ioldsd
708 IF( iinfo.LT.0 )
THEN
711 result( ntest ) = ulpinv
718 CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
719 $ ldz, d, work, result( ntest ) )
725 CALL slacpy(
' ', n, n, a, lda, z, ldz )
726 CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
729 $ bb, ldb, d2, work, nwork, iinfo )
730 IF( iinfo.NE.0 )
THEN
731 WRITE( nounit, fmt = 9999 )
732 $
'SSYGV_2STAGE(V,' // uplo //
733 $
')', iinfo, n, jtype, ioldsd
735 IF( iinfo.LT.0 )
THEN
738 result( ntest ) = ulpinv
756 temp1 = max( temp1, abs( d( j ) ),
758 temp2 = max( temp2, abs( d( j )-d2( j ) ) )
761 result( ntest ) = temp2 /
762 $ max( unfl, ulp*max( temp1, temp2 ) )
768 CALL slacpy(
' ', n, n, a, lda, z, ldz )
769 CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
771 CALL ssygvd( ibtype,
'V', uplo, n, z, ldz, bb, ldb, d,
772 $ work, nwork, iwork, liwork, iinfo )
773 IF( iinfo.NE.0 )
THEN
774 WRITE( nounit, fmt = 9999 )
'SSYGVD(V,' // uplo //
775 $
')', iinfo, n, jtype, ioldsd
777 IF( iinfo.LT.0 )
THEN
780 result( ntest ) = ulpinv
787 CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
788 $ ldz, d, work, result( ntest ) )
794 CALL slacpy(
' ', n, n, a, lda, ab, lda )
795 CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
797 CALL ssygvx( ibtype,
'V',
'A', uplo, n, ab, lda, bb,
798 $ ldb, vl, vu, il, iu, abstol, m, d, z,
799 $ ldz, work, nwork, iwork( n+1 ), iwork,
801 IF( iinfo.NE.0 )
THEN
802 WRITE( nounit, fmt = 9999 )
'SSYGVX(V,A' // uplo //
803 $
')', iinfo, n, jtype, ioldsd
805 IF( iinfo.LT.0 )
THEN
808 result( ntest ) = ulpinv
815 CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
816 $ ldz, d, work, result( ntest ) )
820 CALL slacpy(
' ', n, n, a, lda, ab, lda )
821 CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
830 CALL ssygvx( ibtype,
'V',
'V', uplo, n, ab, lda, bb,
831 $ ldb, vl, vu, il, iu, abstol, m, d, z,
832 $ ldz, work, nwork, iwork( n+1 ), iwork,
834 IF( iinfo.NE.0 )
THEN
835 WRITE( nounit, fmt = 9999 )
'SSYGVX(V,V,' //
836 $ uplo //
')', iinfo, n, jtype, ioldsd
838 IF( iinfo.LT.0 )
THEN
841 result( ntest ) = ulpinv
848 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
849 $ ldz, d, work, result( ntest ) )
853 CALL slacpy(
' ', n, n, a, lda, ab, lda )
854 CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
856 CALL ssygvx( ibtype,
'V',
'I', uplo, n, ab, lda, bb,
857 $ ldb, vl, vu, il, iu, abstol, m, d, z,
858 $ ldz, work, nwork, iwork( n+1 ), iwork,
860 IF( iinfo.NE.0 )
THEN
861 WRITE( nounit, fmt = 9999 )
'SSYGVX(V,I,' //
862 $ uplo //
')', iinfo, n, jtype, ioldsd
864 IF( iinfo.LT.0 )
THEN
867 result( ntest ) = ulpinv
874 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
875 $ ldz, d, work, result( ntest ) )
885 IF( lsame( uplo,
'U' ) )
THEN
905 CALL sspgv( ibtype,
'V', uplo, n, ap, bp, d, z, ldz,
907 IF( iinfo.NE.0 )
THEN
908 WRITE( nounit, fmt = 9999 )
'SSPGV(V,' // uplo //
909 $
')', iinfo, n, jtype, ioldsd
911 IF( iinfo.LT.0 )
THEN
914 result( ntest ) = ulpinv
921 CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
922 $ ldz, d, work, result( ntest ) )
930 IF( lsame( uplo,
'U' ) )
THEN
950 CALL sspgvd( ibtype,
'V', uplo, n, ap, bp, d, z, ldz,
951 $ work, nwork, iwork, liwork, iinfo )
952 IF( iinfo.NE.0 )
THEN
953 WRITE( nounit, fmt = 9999 )
'SSPGVD(V,' // uplo //
954 $
')', iinfo, n, jtype, ioldsd
956 IF( iinfo.LT.0 )
THEN
959 result( ntest ) = ulpinv
966 CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
967 $ ldz, d, work, result( ntest ) )
975 IF( lsame( uplo,
'U' ) )
THEN
995 CALL sspgvx( ibtype,
'V',
'A', uplo, n, ap, bp, vl,
996 $ vu, il, iu, abstol, m, d, z, ldz, work,
997 $ iwork( n+1 ), iwork, info )
998 IF( iinfo.NE.0 )
THEN
999 WRITE( nounit, fmt = 9999 )
'SSPGVX(V,A' // uplo //
1000 $
')', iinfo, n, jtype, ioldsd
1002 IF( iinfo.LT.0 )
THEN
1005 result( ntest ) = ulpinv
1012 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1013 $ ldz, d, work, result( ntest ) )
1019 IF( lsame( uplo,
'U' ) )
THEN
1023 ap( ij ) = a( i, j )
1024 bp( ij ) = b( i, j )
1032 ap( ij ) = a( i, j )
1033 bp( ij ) = b( i, j )
1041 CALL sspgvx( ibtype,
'V',
'V', uplo, n, ap, bp, vl,
1042 $ vu, il, iu, abstol, m, d, z, ldz, work,
1043 $ iwork( n+1 ), iwork, info )
1044 IF( iinfo.NE.0 )
THEN
1045 WRITE( nounit, fmt = 9999 )
'SSPGVX(V,V' // uplo //
1046 $
')', iinfo, n, jtype, ioldsd
1048 IF( iinfo.LT.0 )
THEN
1051 result( ntest ) = ulpinv
1058 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1059 $ ldz, d, work, result( ntest ) )
1065 IF( lsame( uplo,
'U' ) )
THEN
1069 ap( ij ) = a( i, j )
1070 bp( ij ) = b( i, j )
1078 ap( ij ) = a( i, j )
1079 bp( ij ) = b( i, j )
1085 CALL sspgvx( ibtype,
'V',
'I', uplo, n, ap, bp, vl,
1086 $ vu, il, iu, abstol, m, d, z, ldz, work,
1087 $ iwork( n+1 ), iwork, info )
1088 IF( iinfo.NE.0 )
THEN
1089 WRITE( nounit, fmt = 9999 )
'SSPGVX(V,I' // uplo //
1090 $
')', iinfo, n, jtype, ioldsd
1092 IF( iinfo.LT.0 )
THEN
1095 result( ntest ) = ulpinv
1102 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1103 $ ldz, d, work, result( ntest ) )
1107 IF( ibtype.EQ.1 )
THEN
1115 IF( lsame( uplo,
'U' ) )
THEN
1117 DO 320 i = max( 1, j-ka ), j
1118 ab( ka+1+i-j, j ) = a( i, j )
1120 DO 330 i = max( 1, j-kb ), j
1121 bb( kb+1+i-j, j ) = b( i, j )
1126 DO 350 i = j, min( n, j+ka )
1127 ab( 1+i-j, j ) = a( i, j )
1129 DO 360 i = j, min( n, j+kb )
1130 bb( 1+i-j, j ) = b( i, j )
1135 CALL ssbgv(
'V', uplo, n, ka, kb, ab, lda, bb, ldb,
1136 $ d, z, ldz, work, iinfo )
1137 IF( iinfo.NE.0 )
THEN
1138 WRITE( nounit, fmt = 9999 )
'SSBGV(V,' //
1139 $ uplo //
')', iinfo, n, jtype, ioldsd
1141 IF( iinfo.LT.0 )
THEN
1144 result( ntest ) = ulpinv
1151 CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1152 $ ldz, d, work, result( ntest ) )
1160 IF( lsame( uplo,
'U' ) )
THEN
1162 DO 380 i = max( 1, j-ka ), j
1163 ab( ka+1+i-j, j ) = a( i, j )
1165 DO 390 i = max( 1, j-kb ), j
1166 bb( kb+1+i-j, j ) = b( i, j )
1171 DO 410 i = j, min( n, j+ka )
1172 ab( 1+i-j, j ) = a( i, j )
1174 DO 420 i = j, min( n, j+kb )
1175 bb( 1+i-j, j ) = b( i, j )
1180 CALL ssbgvd(
'V', uplo, n, ka, kb, ab, lda, bb,
1181 $ ldb, d, z, ldz, work, nwork, iwork,
1183 IF( iinfo.NE.0 )
THEN
1184 WRITE( nounit, fmt = 9999 )
'SSBGVD(V,' //
1185 $ uplo //
')', iinfo, n, jtype, ioldsd
1187 IF( iinfo.LT.0 )
THEN
1190 result( ntest ) = ulpinv
1197 CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1198 $ ldz, d, work, result( ntest ) )
1206 IF( lsame( uplo,
'U' ) )
THEN
1208 DO 440 i = max( 1, j-ka ), j
1209 ab( ka+1+i-j, j ) = a( i, j )
1211 DO 450 i = max( 1, j-kb ), j
1212 bb( kb+1+i-j, j ) = b( i, j )
1217 DO 470 i = j, min( n, j+ka )
1218 ab( 1+i-j, j ) = a( i, j )
1220 DO 480 i = j, min( n, j+kb )
1221 bb( 1+i-j, j ) = b( i, j )
1226 CALL ssbgvx(
'V',
'A', uplo, n, ka, kb, ab, lda,
1227 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1228 $ iu, abstol, m, d, z, ldz, work,
1229 $ iwork( n+1 ), iwork, iinfo )
1230 IF( iinfo.NE.0 )
THEN
1231 WRITE( nounit, fmt = 9999 )
'SSBGVX(V,A' //
1232 $ uplo //
')', iinfo, n, jtype, ioldsd
1234 IF( iinfo.LT.0 )
THEN
1237 result( ntest ) = ulpinv
1244 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1245 $ ldz, d, work, result( ntest ) )
1252 IF( lsame( uplo,
'U' ) )
THEN
1254 DO 500 i = max( 1, j-ka ), j
1255 ab( ka+1+i-j, j ) = a( i, j )
1257 DO 510 i = max( 1, j-kb ), j
1258 bb( kb+1+i-j, j ) = b( i, j )
1263 DO 530 i = j, min( n, j+ka )
1264 ab( 1+i-j, j ) = a( i, j )
1266 DO 540 i = j, min( n, j+kb )
1267 bb( 1+i-j, j ) = b( i, j )
1274 CALL ssbgvx(
'V',
'V', uplo, n, ka, kb, ab, lda,
1275 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1276 $ iu, abstol, m, d, z, ldz, work,
1277 $ iwork( n+1 ), iwork, iinfo )
1278 IF( iinfo.NE.0 )
THEN
1279 WRITE( nounit, fmt = 9999 )
'SSBGVX(V,V' //
1280 $ uplo //
')', iinfo, n, jtype, ioldsd
1282 IF( iinfo.LT.0 )
THEN
1285 result( ntest ) = ulpinv
1292 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1293 $ ldz, d, work, result( ntest ) )
1299 IF( lsame( uplo,
'U' ) )
THEN
1301 DO 560 i = max( 1, j-ka ), j
1302 ab( ka+1+i-j, j ) = a( i, j )
1304 DO 570 i = max( 1, j-kb ), j
1305 bb( kb+1+i-j, j ) = b( i, j )
1310 DO 590 i = j, min( n, j+ka )
1311 ab( 1+i-j, j ) = a( i, j )
1313 DO 600 i = j, min( n, j+kb )
1314 bb( 1+i-j, j ) = b( i, j )
1319 CALL ssbgvx(
'V',
'I', uplo, n, ka, kb, ab, lda,
1320 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1321 $ iu, abstol, m, d, z, ldz, work,
1322 $ iwork( n+1 ), iwork, iinfo )
1323 IF( iinfo.NE.0 )
THEN
1324 WRITE( nounit, fmt = 9999 )
'SSBGVX(V,I' //
1325 $ uplo //
')', iinfo, n, jtype, ioldsd
1327 IF( iinfo.LT.0 )
THEN
1330 result( ntest ) = ulpinv
1337 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1338 $ ldz, d, work, result( ntest ) )
1347 ntestt = ntestt + ntest
1348 CALL slafts(
'SSG', n, n, jtype, ntest, result, ioldsd,
1349 $ thresh, nounit, nerrs )
1355 CALL slasum(
'SSG', nounit, nerrs, ntestt )
1361 9999
FORMAT(
' SDRVSG2STG: ', a,
' returned INFO=', i6,
'.', / 9x,
1362 $
'N=', 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 ssygv_2stage(ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, INFO)
SSYGV_2STAGE
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 sdrvsg2stg(NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, NOUNIT, A, LDA, B, LDB, D, D2, Z, LDZ, AB, BB, AP, BP, WORK, NWORK, IWORK, LIWORK, RESULT, INFO)
SDRVSG2STG
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