358 SUBROUTINE sdrvsg2stg( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
359 $ NOUNIT, A, LDA, B, LDB, D, D2, Z, LDZ, AB,
360 $ BB, AP, BP, WORK, NWORK, IWORK, LIWORK,
370 INTEGER INFO, LDA, LDB, LDZ, LIWORK, , NSIZES,
376 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
377 REAL A( LDA, * ), AB( LDA, * ), AP( * ),
378 $ b( ldb, * ), bb( ldb, * ), bp( * ), d( * ),
379 $ d2( * ), result( * ), work( * ), z( ldz, * )
386 PARAMETER ( ZERO = 0.0e0, one = 1.0e0, ten = 10.0e0 )
388 parameter( maxtyp = 21 )
393 INTEGER I, IBTYPE, IBUPLO, IINFO, IJ, IL, IMODE, ITEMP,
394 $ itype, iu, j, jcol, jsize, jtype, ka, ka9, kb,
395 $ kb9, m, mtypes, n, nerrs, nmats, nmax, ntest,
397 REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
398 $ , ULP, ULPINV, UNFL, VL, VU, TEMP1, TEMP2
401 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
402 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
408 EXTERNAL LSAME, SLAMCH, SLARND
417 INTRINSIC abs, real,
max,
min, sqrt
420 DATA ktype / 1, 2, 5*4, 5*5, 3*8, 6*9 /
421 DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
423 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
436 nmax =
max( nmax, nn( j ) )
443 IF( nsizes.LT.0 )
THEN
445 ELSE IF( badnn )
THEN
447 ELSE IF( ntypes.LT.0 )
THEN
449 ELSE IF( lda.LE.1 .OR. lda.LT.nmax )
THEN
451 ELSE IF( ldz.LE.1 .OR. ldz.LT.nmax )
THEN
453 ELSE IF( 2*
max( nmax, 3 )**2.GT.nwork )
THEN
455 ELSE IF( 2*
max( nmax, 3 )**2.GT.liwork )
THEN
460 CALL xerbla(
'SDRVSG2STG', -info )
466 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
471 unfl = slamch(
'Safe minimum' )
472 ovfl = slamch
'Overflow' )
474 ulp = slamch(
'Epsilon' )*slamch(
'Base' )
476 rtunfl = sqrt( unfl )
477 rtovfl = sqrt( ovfl )
480 iseed2( i ) = iseed( i )
488 DO 650 jsize = 1, nsizes
490 aninv = one / real(
max( 1, n ) )
492 IF( nsizes.NE.1 )
THEN
493 mtypes =
min( maxtyp, ntypes )
495 mtypes =
min( maxtyp+1, ntypes )
500 DO 640 jtype = 1, mtypes
501 IF( .NOT.dotype( jtype ) )
507 ioldsd( j ) = iseed( j )
525 IF( mtypes.GT.maxtyp )
528 itype = ktype( jtype )
529 imode = kmode( jtype )
533 GO TO ( 40, 50, 60 )kmagn( jtype )
540 anorm = ( rtovfl*ulp )*aninv
544 anorm = rtunfl*n*ulpinv
554 IF( itype.EQ.1 )
THEN
560 CALL slaset(
'Full', lda, n, zero, zero, a, lda )
562 ELSE IF( itype.EQ.2 )
THEN
568 CALL slaset(
'Full', lda, n, zero, zero, a, lda )
570 a( jcol, jcol ) = anorm
573 ELSE IF( itype.EQ.4 )
THEN
579 CALL slatms( n, n,
'S', iseed,
'S', work, imode, cond,
580 $ anorm, 0, 0,
'N', a, lda, work( n+1 ),
583 ELSE IF( itype.EQ.5 )
THEN
589 CALL slatms( n, n,
'S', iseed,
'S', work, imode, cond,
590 $ anorm, n, n,
'N', a, lda, work( n+1 ),
593 ELSE IF( itype.EQ.7 )
THEN
599 CALL slatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
600 $
'T',
'N', work( n+1 ), 1, one,
601 $ work( 2*n+1 ), 1, one,
'N', idumma
602 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
604 ELSE IF( itype.EQ.8 )
THEN
610 CALL slatmr'S', iseed,
'H', work, 6, one, one,
611 $ 't
', 'n
', WORK( N+1 ), 1, ONE,
612 $ WORK( 2*N+1 ), 1, ONE, 'n
', IDUMMA, N, N,
613 $ ZERO, ANORM, 'no
', A, LDA, IWORK, IINFO )
615.EQ.
ELSE IF( ITYPE9 ) THEN
629.GT.
IF( KB9KA9 ) THEN
633 KA = MAX( 0, MIN( N-1, KA9 ) )
634 KB = MAX( 0, MIN( N-1, KB9 ) )
635 CALL SLATMS( N, N, 's
', ISEED, 's
', WORK, IMODE, COND,
636 $ ANORM, KA, KA, 'n
', A, LDA, WORK( N+1 ),
644.NE.
IF( IINFO0 ) THEN
645 WRITE( NOUNIT, FMT = 9999 )'generator
', IINFO, N, JTYPE,
658 IL = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) )
659 IU = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) )
688 CALL SLATMS( N, N, 'u
', ISEED, 'p
', WORK, 5, TEN, ONE,
689 $ KB, KB, UPLO, B, LDB, WORK( N+1 ),
696 CALL SLACPY( ' ', N, N, A, LDA, Z, LDZ )
697 CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB )
699 CALL SSYGV( IBTYPE, 'v
', UPLO, N, Z, LDZ, BB, LDB, D,
700 $ WORK, NWORK, IINFO )
701.NE.
IF( IINFO0 ) THEN
702 WRITE( NOUNIT, FMT = 9999 )'ssygv(v,
' // UPLO //
703 $ ')
', IINFO, N, JTYPE, IOLDSD
705.LT.
IF( IINFO0 ) THEN
708 RESULT( NTEST ) = ULPINV
715 CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
716 $ LDZ, D, WORK, RESULT( NTEST ) )
722 CALL SLACPY( ' ', N, N, A, LDA, Z, LDZ )
723 CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB )
725 CALL SSYGV_2STAGE( IBTYPE, 'n
', UPLO, N, Z, LDZ,
726 $ BB, LDB, D2, WORK, NWORK, IINFO )
727.NE.
IF( IINFO0 ) THEN
728 WRITE( NOUNIT, FMT = 9999 )
730 $ ')
', IINFO, N, JTYPE, IOLDSD
732.LT.
IF( IINFO0 ) THEN
735 RESULT( NTEST ) = ULPINV
753 TEMP1 = MAX( TEMP1, ABS( D( J ) ),
755 TEMP2 = MAX( TEMP2, ABS( D( J )-D2( J ) ) )
758 RESULT( NTEST ) = TEMP2 /
759 $ MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) )
765 CALL SLACPY( ' ', N, N, A, LDA, Z, LDZ )
766 CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB )
768 CALL SSYGVD( IBTYPE, 'v
', UPLO, N, Z, LDZ, BB, LDB, D,
769 $ WORK, NWORK, IWORK, LIWORK, IINFO )
770.NE.
IF( IINFO0 ) THEN
771 WRITE( NOUNIT, FMT = 9999 )'ssygvd(v,
' // UPLO //
772 $ ')
', IINFO, N, JTYPE, IOLDSD
774.LT.
IF( IINFO0 ) THEN
777 RESULT( NTEST ) = ULPINV
784 CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
785 $ LDZ, D, WORK, RESULT( NTEST ) )
791 CALL SLACPY( ' ', N, N, A, LDA, AB, LDA )
792 CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB )
794 CALL SSYGVX( IBTYPE, 'v
', 'a
', UPLO, N, AB, LDA, BB,
795 $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z,
796 $ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK,
798.NE.
IF( IINFO0 ) THEN
799 WRITE( NOUNIT, FMT = 9999 )'ssygvx(v,a
' // UPLO //
800 $ ')
', IINFO, N, JTYPE, IOLDSD
802.LT.
IF( IINFO0 ) THEN
805 RESULT( NTEST ) = ULPINV
812 CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
813 $ LDZ, D, WORK, RESULT( NTEST ) )
817 CALL SLACPY( ' ', N, N, A, LDA, AB, LDA )
818 CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB )
827 CALL SSYGVX( IBTYPE, 'v
', 'v
', UPLO, N, AB, LDA, BB,
828 $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z,
829 $ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK,
831.NE.
IF( IINFO0 ) THEN
832 WRITE( NOUNIT, FMT = 9999 )'ssygvx(v,v,
' //
833 $ UPLO // ')
', IINFO, N, JTYPE, IOLDSD
835.LT.
IF( IINFO0 ) THEN
838 RESULT( NTEST ) = ULPINV
845 CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
846 $ LDZ, D, WORK, RESULT( NTEST ) )
850 CALL SLACPY( ' ', N, N, A, LDA, AB, LDA )
851 CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB )
853 CALL SSYGVX( IBTYPE, 'v
', 'i
', UPLO, N, AB, LDA, BB,
854 $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z,
855 $ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK,
857.NE.
IF( IINFO0 ) THEN
858 WRITE( NOUNIT, FMT = 9999 )'ssygvx(v,i,
' //
859 $ UPLO // ')
', IINFO, N, JTYPE, IOLDSD
861.LT.
IF( IINFO0 ) THEN
864 RESULT( NTEST ) = ULPINV
871 CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
872 $ LDZ, D, WORK, RESULT( NTEST ) )
882 IF( LSAME( UPLO, 'u
' ) ) THEN
902 CALL SSPGV( IBTYPE, 'v
', UPLO, N, AP, BP, D, Z, LDZ,
904.NE.
IF( IINFO0 ) THEN
905 WRITE( NOUNIT, FMT = 9999 )'sspgv(v,
' // UPLO //
906 $ ')
', IINFO, N, JTYPE, IOLDSD
908.LT.
IF( IINFO0 ) THEN
911 RESULT( NTEST ) = ULPINV
918 CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
919 $ LDZ, D, WORK, RESULT( NTEST ) )
927 IF( LSAME( UPLO, 'u
' ) ) THEN
947 CALL SSPGVD( IBTYPE, 'v
', UPLO, N, AP, BP, D, Z, LDZ,
948 $ WORK, NWORK, IWORK, LIWORK, IINFO )
949.NE.
IF( IINFO0 ) THEN
950 WRITE( NOUNIT, FMT = 9999 )'sspgvd(v,
' // UPLO //
951 $ ')
', IINFO, N, JTYPE, IOLDSD
953.LT.
IF( IINFO0 ) THEN
956 RESULT( NTEST ) = ULPINV
963 CALL SSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
964 $ LDZ, D, WORK, RESULT( NTEST ) )
972 IF( LSAME( UPLO, 'u
' ) ) THEN
992 CALL SSPGVX( IBTYPE, 'v
', 'a
', UPLO, N, AP, BP, VL,
993 $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK,
994 $ IWORK( N+1 ), IWORK, INFO )
995.NE.
IF( IINFO0 ) THEN
996 WRITE( NOUNIT, FMT = 9999 )'sspgvx(v,a
' // UPLO //
997 $ ')
', IINFO, N, JTYPE, IOLDSD
999.LT.
IF( IINFO0 ) THEN
1002 RESULT( NTEST ) = ULPINV
1009 CALL SSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
1010 $ LDZ, D, WORK, RESULT( NTEST ) )
1016 IF( LSAME( UPLO, 'u
' ) ) THEN
1020 AP( IJ ) = A( I, J )
1021 BP( IJ ) = B( I, J )
1029 AP( IJ ) = A( I, J )
1030 BP( IJ ) = B( I, J )
1038 CALL SSPGVX( IBTYPE, 'v
', 'v
', UPLO, N, AP, BP, VL,
1039 $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK,
1040 $ IWORK( N+1 ), IWORK, INFO )
1041.NE.
IF( IINFO0 ) THEN
1042 WRITE( NOUNIT, FMT = 9999 )'sspgvx(v,v
' // UPLO //
1043 $ ')', iinfo, n, jtype, ioldsd
1045 IF( iinfo.LT.0 )
THEN
1048 result( ntest ) = ulpinv
1055 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1056 $ ldz, d, work, result( ntest ) )
1062 IF( lsame( uplo,
'U' ) )
THEN
1066 ap( ij ) = a( i, j )
1075 ap( ij ) = a( i, j )
1076 bp( ij ) = b( i, j )
1082 CALL sspgvx( ibtype,
'V',
'I', uplo, n, ap, bp, vl,
1083 $ vu, il, iu, abstol, m, d, z, ldz, work,
1084 $ iwork( n+1 ), iwork, info )
1085 IF( iinfo.NE.0 )
THEN
1086 WRITE( nounit, fmt = 9999 )
'SSPGVX(V,I' // uplo //
1087 $
')', iinfo, n, jtype, ioldsd
1089 IF( iinfo.LT.0 )
THEN
1092 result( ntest ) = ulpinv
1099 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1100 $ ldz, d, work, result( ntest ) )
1104 IF( ibtype.EQ.1 )
THEN
1112 IF( lsame( uplo,
'U' ) )
THEN
1114 DO 320 i =
max( 1, j-ka ), j
1115 ab( ka+1+i-j, j ) = a( i, j )
1117 DO 330 i =
max( 1, j-kb ), j
1118 bb( kb+1+i-j, j ) = b( i, j )
1123 DO 350 i = j,
min( n, j+ka )
1124 ab( 1+i-j, j ) = a( i, j )
1126 DO 360 i = j,
min( n, j+kb )
1127 bb( 1+i-j, j ) = b( i, j )
1132 CALL ssbgv(
'V', uplo, n, ka, kb, ab, lda, bb, ldb,
1133 $ d, z, ldz, work, iinfo )
1134 IF( iinfo.NE.0 )
THEN
1135 WRITE( nounit, fmt = 9999 )
'SSBGV(V,' //
1136 $ uplo //
')', iinfo, n, jtype, ioldsd
1138 IF( iinfo.LT.0 )
THEN
1141 result( ntest ) = ulpinv
1148 CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1149 $ ldz, d, work, result( ntest ) )
1157 IF( lsame( uplo,
'U' ) )
THEN
1159 DO 380 i =
max( 1, j-ka ), j
1160 ab( ka+1+i-j, j ) = a( i, j )
1162 DO 390 i =
max( 1, j-kb ), j
1163 bb( kb+1+i-j, j ) = b( i, j )
1168 DO 410 i = j,
min( n, j+ka )
1169 ab( 1+i-j, j ) = a( i, j )
1171 DO 420 i = j,
min( n, j+kb )
1172 bb( 1+i-j, j ) = b( i, j )
1177 CALL ssbgvd(
'V', uplo, n, ka, kb, ab, lda, bb,
1178 $ ldb, d, z, ldz, work, nwork, iwork,
1180 IF( iinfo.NE.0 )
THEN
1181 WRITE( nounit, fmt = 9999 )
'SSBGVD(V,' //
1182 $ uplo //
')', iinfo, n, jtype, ioldsd
1184 IF( iinfo.LT.0 )
THEN
1187 result( ntest ) = ulpinv
1194 CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1195 $ ldz, d, work, result( ntest ) )
1203 IF( lsame( uplo,
'U' ) )
THEN
1205 DO 440 i =
max( 1, j-ka ), j
1206 ab( ka+1+i-j, j ) = a( i, j )
1208 DO 450 i =
max( 1, j-kb ), j
1209 bb( kb+1+i-j, j ) = b( i, j )
1214 DO 470 i = j,
min( n, j+ka )
1215 ab( 1+i-j, j ) = a( i, j )
1217 DO 480 i = j,
min( n, j+kb )
1218 bb( 1+i-j, j ) = b( i, j )
1223 CALL ssbgvx(
'V',
'A', uplo, n, ka, kb, ab, lda,
1224 $ bb, ldb, bp,
max( 1, n ), vl, vu, il,
1225 $ iu, abstol, m, d, z, ldz, work,
1226 $ iwork( n+1 ), iwork, iinfo )
1227 IF( iinfo.NE.0 )
THEN
1228 WRITE( nounit, fmt = 9999 )
'SSBGVX(V,A' //
1229 $ uplo //
')', iinfo, n, jtype, ioldsd
1231 IF( iinfo.LT.0 )
THEN
1234 result( ntest ) = ulpinv
1241 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1242 $ ldz, d, work, result( ntest ) )
1249 IF( lsame( uplo,
'U' ) )
THEN
1251 DO 500 i =
max( 1, j-ka ), j
1252 ab( ka+1+i-j, j ) = a( i, j )
1254 DO 510 i =
max( 1, j-kb ), j
1255 bb( kb+1+i-j, j ) = b( i, j )
1260 DO 530 i = j,
min( n, j+ka )
1261 ab( 1+i-j, j ) = a( i, j )
1263 DO 540 i = j,
min( n, j+kb )
1264 bb( 1+i-j, j ) = b( i, j )
1271 CALL ssbgvx(
'V',
'V', uplo, n, ka, kb, ab, lda,
1272 $ bb, ldb, bp,
max( 1, n ), vl, vu, il,
1273 $ iu, abstol, m, d, z, ldz, work,
1274 $ iwork( n+1 ), iwork, iinfo )
1275 IF( iinfo.NE.0 )
THEN
1276 WRITE( nounit, fmt = 9999 )
'SSBGVX(V,V' //
1277 $ uplo //
')', iinfo, n, jtype, ioldsd
1279 IF( iinfo.LT.0 )
THEN
1282 result( ntest ) = ulpinv
1289 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1290 $ ldz, d, work, result( ntest ) )
1296 IF( lsame( uplo,
'U' ) )
THEN
1298 DO 560 i =
max( 1, j-ka ), j
1299 ab( ka+1+i-j, j ) = a( i, j )
1301 DO 570 i =
max( 1, j-kb ), j
1302 bb( kb+1+i-j, j ) = b( i, j )
1307 DO 590 i = j,
min( n, j+ka )
1308 ab( 1+i-j, j ) = a( i, j )
1310 DO 600 i = j,
min( n, j+kb )
1311 bb( 1+i-j, j ) = b( i, j )
1316 CALL ssbgvx(
'V',
'I', uplo, n, ka, kb, ab, lda,
1317 $ bb, ldb, bp,
max( 1, n ), vl, vu, il,
1318 $ iu, abstol, m, d, z, ldz, work,
1319 $ iwork( n+1 ), iwork, iinfo )
1320 IF( iinfo.NE.0 )
THEN
1321 WRITE( nounit, fmt = 9999 )
'SSBGVX(V,I' //
1322 $ uplo //
')', iinfo, n, jtype, ioldsd
1324 IF( iinfo.LT.0 )
THEN
1327 result( ntest ) = ulpinv
1334 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1335 $ ldz, d, work, result( ntest ) )
1344 ntestt = ntestt + ntest
1345 CALL slafts(
'SSG', n, n, jtype, ntest, result, ioldsd,
1346 $ thresh, nounit, nerrs )
1352 CALL slasum(
'SSG', nounit, nerrs, ntestt )
1358 9999
FORMAT(
' SDRVSG2STG: ', a,
' returned INFO=', i6,
'.', / 9x,
1359 $
'N=', i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )