368 SUBROUTINE zdrvsg( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
369 $ nounit, a, lda, b, ldb, d, z, ldz, ab, bb, ap,
370 $ bp, work, nwork, rwork, lrwork, iwork, liwork,
379 INTEGER INFO, LDA, LDB, LDZ, LIWORK, LRWORK, NOUNIT,
380 $ nsizes, ntypes, nwork
381 DOUBLE PRECISION THRESH
385 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
386 DOUBLE PRECISION D( * ), RESULT( * ), RWORK( * )
387 COMPLEX*16 A( lda, * ), AB( lda, * ), AP( * ),
388 $ b( ldb, * ), bb( ldb, * ), bp( * ), work( * ),
395 DOUBLE PRECISION ZERO, ONE, TEN
396 parameter ( zero = 0.0d+0, one = 1.0d+0, ten = 10.0d+0 )
397 COMPLEX*16 CZERO, CONE
398 parameter ( czero = ( 0.0d+0, 0.0d+0 ),
399 $ cone = ( 1.0d+0, 0.0d+0 ) )
401 parameter ( maxtyp = 21 )
406 INTEGER I, IBTYPE, IBUPLO, IINFO, IJ, IL, IMODE, ITEMP,
407 $ itype, iu, j, jcol, jsize, jtype, ka, ka9, kb,
408 $ kb9, m, mtypes, n, nerrs, nmats, nmax, ntest,
410 DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
411 $ rtunfl, ulp, ulpinv, unfl, vl, vu
414 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
415 $ kmagn( maxtyp ), kmode( maxtyp ),
420 DOUBLE PRECISION DLAMCH, DLARND
421 EXTERNAL lsame, dlamch, dlarnd
429 INTRINSIC abs, dble, max, min, sqrt
432 DATA ktype / 1, 2, 5*4, 5*5, 3*8, 6*9 /
433 DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
435 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
448 nmax = max( nmax, nn( j ) )
455 IF( nsizes.LT.0 )
THEN
457 ELSE IF( badnn )
THEN
459 ELSE IF( ntypes.LT.0 )
THEN
461 ELSE IF( lda.LE.1 .OR. lda.LT.nmax )
THEN
463 ELSE IF( ldz.LE.1 .OR. ldz.LT.nmax )
THEN
465 ELSE IF( 2*max( nmax, 2 )**2.GT.nwork )
THEN
467 ELSE IF( 2*max( nmax, 2 )**2.GT.lrwork )
THEN
469 ELSE IF( 2*max( nmax, 2 )**2.GT.liwork )
THEN
474 CALL xerbla(
'ZDRVSG', -info )
480 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
485 unfl = dlamch(
'Safe minimum' )
486 ovfl = dlamch(
'Overflow' )
488 ulp = dlamch(
'Epsilon' )*dlamch(
'Base' )
490 rtunfl = sqrt( unfl )
491 rtovfl = sqrt( ovfl )
494 iseed2( i ) = iseed( i )
502 DO 650 jsize = 1, nsizes
504 aninv = one / dble( max( 1, n ) )
506 IF( nsizes.NE.1 )
THEN
507 mtypes = min( maxtyp, ntypes )
509 mtypes = min( maxtyp+1, ntypes )
514 DO 640 jtype = 1, mtypes
515 IF( .NOT.dotype( jtype ) )
521 ioldsd( j ) = iseed( j )
539 IF( mtypes.GT.maxtyp )
542 itype = ktype( jtype )
543 imode = kmode( jtype )
547 GO TO ( 40, 50, 60 )kmagn( jtype )
554 anorm = ( rtovfl*ulp )*aninv
558 anorm = rtunfl*n*ulpinv
568 IF( itype.EQ.1 )
THEN
574 CALL zlaset(
'Full', lda, n, czero, czero, a, lda )
576 ELSE IF( itype.EQ.2 )
THEN
582 CALL zlaset(
'Full', lda, n, czero, czero, a, lda )
584 a( jcol, jcol ) = anorm
587 ELSE IF( itype.EQ.4 )
THEN
593 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
594 $ anorm, 0, 0,
'N', a, lda, work, iinfo )
596 ELSE IF( itype.EQ.5 )
THEN
602 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
603 $ anorm, n, n,
'N', a, lda, work, iinfo )
605 ELSE IF( itype.EQ.7 )
THEN
611 CALL zlatmr( n, n,
'S', iseed,
'H', work, 6, one, cone,
612 $
'T',
'N', work( n+1 ), 1, one,
613 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
614 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
616 ELSE IF( itype.EQ.8 )
THEN
622 CALL zlatmr( n, n,
'S', iseed,
'H', work, 6, one, cone,
623 $
'T',
'N', work( n+1 ), 1, one,
624 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
625 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
627 ELSE IF( itype.EQ.9 )
THEN
641 IF( kb9.GT.ka9 )
THEN
645 ka = max( 0, min( n-1, ka9 ) )
646 kb = max( 0, min( n-1, kb9 ) )
647 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
648 $ anorm, ka, ka,
'N', a, lda, work, iinfo )
655 IF( iinfo.NE.0 )
THEN
656 WRITE( nounit, fmt = 9999 )
'Generator', iinfo, n, jtype,
669 il = 1 + ( n-1 )*dlarnd( 1, iseed2 )
670 iu = 1 + ( n-1 )*dlarnd( 1, iseed2 )
699 CALL zlatms( n, n,
'U', iseed,
'P', rwork, 5, ten,
700 $ one, kb, kb, uplo, b, ldb, work( n+1 ),
707 CALL zlacpy(
' ', n, n, a, lda, z, ldz )
708 CALL zlacpy( uplo, n, n, b, ldb, bb, ldb )
710 CALL zhegv( ibtype,
'V', uplo, n, z, ldz, bb, ldb, d,
711 $ work, nwork, rwork, iinfo )
712 IF( iinfo.NE.0 )
THEN
713 WRITE( nounit, fmt = 9999 )
'ZHEGV(V,' // uplo //
714 $
')', iinfo, n, jtype, ioldsd
716 IF( iinfo.LT.0 )
THEN
719 result( ntest ) = ulpinv
726 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
727 $ ldz, d, work, rwork, result( ntest ) )
733 CALL zlacpy(
' ', n, n, a, lda, z, ldz )
734 CALL zlacpy( uplo, n, n, b, ldb, bb, ldb )
736 CALL zhegvd( ibtype,
'V', uplo, n, z, ldz, bb, ldb, d,
737 $ work, nwork, rwork, lrwork, iwork,
739 IF( iinfo.NE.0 )
THEN
740 WRITE( nounit, fmt = 9999 )
'ZHEGVD(V,' // uplo //
741 $
')', iinfo, n, jtype, ioldsd
743 IF( iinfo.LT.0 )
THEN
746 result( ntest ) = ulpinv
753 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
754 $ ldz, d, work, rwork, result( ntest ) )
760 CALL zlacpy(
' ', n, n, a, lda, ab, lda )
761 CALL zlacpy( uplo, n, n, b, ldb, bb, ldb )
763 CALL zhegvx( ibtype,
'V',
'A', uplo, n, ab, lda, bb,
764 $ ldb, vl, vu, il, iu, abstol, m, d, z,
765 $ ldz, work, nwork, rwork, iwork( n+1 ),
767 IF( iinfo.NE.0 )
THEN
768 WRITE( nounit, fmt = 9999 )
'ZHEGVX(V,A' // uplo //
769 $
')', iinfo, n, jtype, ioldsd
771 IF( iinfo.LT.0 )
THEN
774 result( ntest ) = ulpinv
781 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
782 $ ldz, d, work, rwork, result( ntest ) )
786 CALL zlacpy(
' ', n, n, a, lda, ab, lda )
787 CALL zlacpy( uplo, n, n, b, ldb, bb, ldb )
796 CALL zhegvx( ibtype,
'V',
'V', uplo, n, ab, lda, bb,
797 $ ldb, vl, vu, il, iu, abstol, m, d, z,
798 $ ldz, work, nwork, rwork, iwork( n+1 ),
800 IF( iinfo.NE.0 )
THEN
801 WRITE( nounit, fmt = 9999 )
'ZHEGVX(V,V,' //
802 $ uplo //
')', iinfo, n, jtype, ioldsd
804 IF( iinfo.LT.0 )
THEN
807 result( ntest ) = ulpinv
814 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
815 $ ldz, d, work, rwork, result( ntest ) )
819 CALL zlacpy(
' ', n, n, a, lda, ab, lda )
820 CALL zlacpy( uplo, n, n, b, ldb, bb, ldb )
822 CALL zhegvx( ibtype,
'V',
'I', uplo, n, ab, lda, bb,
823 $ ldb, vl, vu, il, iu, abstol, m, d, z,
824 $ ldz, work, nwork, rwork, iwork( n+1 ),
826 IF( iinfo.NE.0 )
THEN
827 WRITE( nounit, fmt = 9999 )
'ZHEGVX(V,I,' //
828 $ uplo //
')', iinfo, n, jtype, ioldsd
830 IF( iinfo.LT.0 )
THEN
833 result( ntest ) = ulpinv
840 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
841 $ ldz, d, work, rwork, result( ntest ) )
851 IF( lsame( uplo,
'U' ) )
THEN
871 CALL zhpgv( ibtype,
'V', uplo, n, ap, bp, d, z, ldz,
872 $ work, rwork, iinfo )
873 IF( iinfo.NE.0 )
THEN
874 WRITE( nounit, fmt = 9999 )
'ZHPGV(V,' // uplo //
875 $
')', iinfo, n, jtype, ioldsd
877 IF( iinfo.LT.0 )
THEN
880 result( ntest ) = ulpinv
887 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
888 $ ldz, d, work, rwork, result( ntest ) )
896 IF( lsame( uplo,
'U' ) )
THEN
916 CALL zhpgvd( ibtype,
'V', uplo, n, ap, bp, d, z, ldz,
917 $ work, nwork, rwork, lrwork, iwork,
919 IF( iinfo.NE.0 )
THEN
920 WRITE( nounit, fmt = 9999 )
'ZHPGVD(V,' // uplo //
921 $
')', iinfo, n, jtype, ioldsd
923 IF( iinfo.LT.0 )
THEN
926 result( ntest ) = ulpinv
933 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
934 $ ldz, d, work, rwork, result( ntest ) )
942 IF( lsame( uplo,
'U' ) )
THEN
962 CALL zhpgvx( ibtype,
'V',
'A', uplo, n, ap, bp, vl,
963 $ vu, il, iu, abstol, m, d, z, ldz, work,
964 $ rwork, iwork( n+1 ), iwork, info )
965 IF( iinfo.NE.0 )
THEN
966 WRITE( nounit, fmt = 9999 )
'ZHPGVX(V,A' // uplo //
967 $
')', iinfo, n, jtype, ioldsd
969 IF( iinfo.LT.0 )
THEN
972 result( ntest ) = ulpinv
979 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
980 $ ldz, d, work, rwork, result( ntest ) )
986 IF( lsame( uplo,
'U' ) )
THEN
1000 bp( ij ) = b( i, j )
1008 CALL zhpgvx( ibtype,
'V',
'V', uplo, n, ap, bp, vl,
1009 $ vu, il, iu, abstol, m, d, z, ldz, work,
1010 $ rwork, iwork( n+1 ), iwork, info )
1011 IF( iinfo.NE.0 )
THEN
1012 WRITE( nounit, fmt = 9999 )
'ZHPGVX(V,V' // uplo //
1013 $
')', iinfo, n, jtype, ioldsd
1015 IF( iinfo.LT.0 )
THEN
1018 result( ntest ) = ulpinv
1025 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1026 $ ldz, d, work, rwork, result( ntest ) )
1032 IF( lsame( uplo,
'U' ) )
THEN
1036 ap( ij ) = a( i, j )
1037 bp( ij ) = b( i, j )
1045 ap( ij ) = a( i, j )
1046 bp( ij ) = b( i, j )
1052 CALL zhpgvx( ibtype,
'V',
'I', uplo, n, ap, bp, vl,
1053 $ vu, il, iu, abstol, m, d, z, ldz, work,
1054 $ rwork, iwork( n+1 ), iwork, info )
1055 IF( iinfo.NE.0 )
THEN
1056 WRITE( nounit, fmt = 9999 )
'ZHPGVX(V,I' // uplo //
1057 $
')', iinfo, n, jtype, ioldsd
1059 IF( iinfo.LT.0 )
THEN
1062 result( ntest ) = ulpinv
1069 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1070 $ ldz, d, work, rwork, result( ntest ) )
1074 IF( ibtype.EQ.1 )
THEN
1082 IF( lsame( uplo,
'U' ) )
THEN
1084 DO 320 i = max( 1, j-ka ), j
1085 ab( ka+1+i-j, j ) = a( i, j )
1087 DO 330 i = max( 1, j-kb ), j
1088 bb( kb+1+i-j, j ) = b( i, j )
1093 DO 350 i = j, min( n, j+ka )
1094 ab( 1+i-j, j ) = a( i, j )
1096 DO 360 i = j, min( n, j+kb )
1097 bb( 1+i-j, j ) = b( i, j )
1102 CALL zhbgv(
'V', uplo, n, ka, kb, ab, lda, bb, ldb,
1103 $ d, z, ldz, work, rwork, iinfo )
1104 IF( iinfo.NE.0 )
THEN
1105 WRITE( nounit, fmt = 9999 )
'ZHBGV(V,' //
1106 $ uplo //
')', iinfo, n, jtype, ioldsd
1108 IF( iinfo.LT.0 )
THEN
1111 result( ntest ) = ulpinv
1118 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1119 $ ldz, d, work, rwork, result( ntest ) )
1127 IF( lsame( uplo,
'U' ) )
THEN
1129 DO 380 i = max( 1, j-ka ), j
1130 ab( ka+1+i-j, j ) = a( i, j )
1132 DO 390 i = max( 1, j-kb ), j
1133 bb( kb+1+i-j, j ) = b( i, j )
1138 DO 410 i = j, min( n, j+ka )
1139 ab( 1+i-j, j ) = a( i, j )
1141 DO 420 i = j, min( n, j+kb )
1142 bb( 1+i-j, j ) = b( i, j )
1147 CALL zhbgvd(
'V', uplo, n, ka, kb, ab, lda, bb,
1148 $ ldb, d, z, ldz, work, nwork, rwork,
1149 $ lrwork, iwork, liwork, iinfo )
1150 IF( iinfo.NE.0 )
THEN
1151 WRITE( nounit, fmt = 9999 )
'ZHBGVD(V,' //
1152 $ uplo //
')', iinfo, n, jtype, ioldsd
1154 IF( iinfo.LT.0 )
THEN
1157 result( ntest ) = ulpinv
1164 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1165 $ ldz, d, work, rwork, result( ntest ) )
1173 IF( lsame( uplo,
'U' ) )
THEN
1175 DO 440 i = max( 1, j-ka ), j
1176 ab( ka+1+i-j, j ) = a( i, j )
1178 DO 450 i = max( 1, j-kb ), j
1179 bb( kb+1+i-j, j ) = b( i, j )
1184 DO 470 i = j, min( n, j+ka )
1185 ab( 1+i-j, j ) = a( i, j )
1187 DO 480 i = j, min( n, j+kb )
1188 bb( 1+i-j, j ) = b( i, j )
1193 CALL zhbgvx(
'V',
'A', uplo, n, ka, kb, ab, lda,
1194 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1195 $ iu, abstol, m, d, z, ldz, work, rwork,
1196 $ iwork( n+1 ), iwork, iinfo )
1197 IF( iinfo.NE.0 )
THEN
1198 WRITE( nounit, fmt = 9999 )
'ZHBGVX(V,A' //
1199 $ uplo //
')', iinfo, n, jtype, ioldsd
1201 IF( iinfo.LT.0 )
THEN
1204 result( ntest ) = ulpinv
1211 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1212 $ ldz, d, work, rwork, result( ntest ) )
1218 IF( lsame( uplo,
'U' ) )
THEN
1220 DO 500 i = max( 1, j-ka ), j
1221 ab( ka+1+i-j, j ) = a( i, j )
1223 DO 510 i = max( 1, j-kb ), j
1224 bb( kb+1+i-j, j ) = b( i, j )
1229 DO 530 i = j, min( n, j+ka )
1230 ab( 1+i-j, j ) = a( i, j )
1232 DO 540 i = j, min( n, j+kb )
1233 bb( 1+i-j, j ) = b( i, j )
1240 CALL zhbgvx(
'V',
'V', uplo, n, ka, kb, ab, lda,
1241 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1242 $ iu, abstol, m, d, z, ldz, work, rwork,
1243 $ iwork( n+1 ), iwork, iinfo )
1244 IF( iinfo.NE.0 )
THEN
1245 WRITE( nounit, fmt = 9999 )
'ZHBGVX(V,V' //
1246 $ uplo //
')', iinfo, n, jtype, ioldsd
1248 IF( iinfo.LT.0 )
THEN
1251 result( ntest ) = ulpinv
1258 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1259 $ ldz, d, work, rwork, result( ntest ) )
1265 IF( lsame( uplo,
'U' ) )
THEN
1267 DO 560 i = max( 1, j-ka ), j
1268 ab( ka+1+i-j, j ) = a( i, j )
1270 DO 570 i = max( 1, j-kb ), j
1271 bb( kb+1+i-j, j ) = b( i, j )
1276 DO 590 i = j, min( n, j+ka )
1277 ab( 1+i-j, j ) = a( i, j )
1279 DO 600 i = j, min( n, j+kb )
1280 bb( 1+i-j, j ) = b( i, j )
1285 CALL zhbgvx(
'V',
'I', uplo, n, ka, kb, ab, lda,
1286 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1287 $ iu, abstol, m, d, z, ldz, work, rwork,
1288 $ iwork( n+1 ), iwork, iinfo )
1289 IF( iinfo.NE.0 )
THEN
1290 WRITE( nounit, fmt = 9999 )
'ZHBGVX(V,I' //
1291 $ uplo //
')', iinfo, n, jtype, ioldsd
1293 IF( iinfo.LT.0 )
THEN
1296 result( ntest ) = ulpinv
1303 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1304 $ ldz, d, work, rwork, result( ntest ) )
1313 ntestt = ntestt + ntest
1314 CALL dlafts(
'ZSG', n, n, jtype, ntest, result, ioldsd,
1315 $ thresh, nounit, nerrs )
1321 CALL dlasum(
'ZSG', nounit, nerrs, ntestt )
1325 9999
FORMAT(
' ZDRVSG: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
1326 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
subroutine zdrvsg(NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, NOUNIT, A, LDA, B, LDB, D, Z, LDZ, AB, BB, AP, BP, WORK, NWORK, RWORK, LRWORK, IWORK, LIWORK, RESULT, INFO)
ZDRVSG
subroutine zlatmr(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)
ZLATMR
subroutine zhbgvx(JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO)
ZHBGVX
subroutine zhegvx(ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO)
ZHEGVX
subroutine zhegv(ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, INFO)
ZHEGV
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zhbgvd(JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO)
ZHBGVD
subroutine dlafts(TYPE, M, N, IMAT, NTESTS, RESULT, ISEED, THRESH, IOUNIT, IE)
DLAFTS
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zsgt01(ITYPE, UPLO, N, M, A, LDA, B, LDB, Z, LDZ, D, WORK, RWORK, RESULT)
ZSGT01
subroutine zhegvd(ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO)
ZHEGVD
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine zhpgv(ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, RWORK, INFO)
ZHPGV
subroutine dlasum(TYPE, IOUNIT, IE, NRUN)
DLASUM
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
subroutine zhpgvd(ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO)
ZHPGVD
subroutine zhbgv(JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, RWORK, INFO)
ZHBGV
subroutine zhpgvx(ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO)
ZHPGVX