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 ),
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' )
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,
')' )