368 SUBROUTINE cdrvsg( 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
385 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
386 REAL D( * ), RESULT( * ), RWORK( * )
387 COMPLEX A( lda, * ), AB( lda, * ), AP( * ),
388 $ b( ldb, * ), bb( ldb, * ), bp( * ), work( * ),
396 parameter( zero = 0.0e+0, one = 1.0e+0, ten = 10.0e+0 )
398 parameter( czero = ( 0.0e+0, 0.0e+0 ),
399 $ cone = ( 1.0e+0, 0.0e+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 REAL 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 ),
421 EXTERNAL lsame, slamch, slarnd
429 INTRINSIC abs, max, min,
REAL, 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(
'CDRVSG', -info )
480 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
485 unfl = slamch(
'Safe minimum' )
486 ovfl = slamch(
'Overflow' )
488 ulp = slamch(
'Epsilon' )*slamch(
'Base' )
490 rtunfl = sqrt( unfl )
491 rtovfl = sqrt( ovfl )
494 iseed2( i ) = iseed( i )
502 DO 650 jsize = 1, nsizes
504 aninv = one /
REAL( 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
claset(
'Full', lda, n, czero, czero, a, lda )
576 ELSE IF( itype.EQ.2 )
THEN
582 CALL
claset(
'Full', lda, n, czero, czero, a, lda )
584 a( jcol, jcol ) = anorm
587 ELSE IF( itype.EQ.4 )
THEN
593 CALL
clatms( 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
clatms( 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
clatmr( 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
clatmr( 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
clatms( 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 )*slarnd( 1, iseed2 )
670 iu = 1 + ( n-1 )*slarnd( 1, iseed2 )
699 CALL
clatms( n, n,
'U', iseed,
'P', rwork, 5, ten,
700 $ one, kb, kb, uplo, b, ldb, work( n+1 ),
707 CALL
clacpy(
' ', n, n, a, lda, z, ldz )
708 CALL
clacpy( uplo, n, n, b, ldb, bb, ldb )
710 CALL
chegv( 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 )
'CHEGV(V,' // uplo //
714 $
')', iinfo, n, jtype, ioldsd
716 IF( iinfo.LT.0 )
THEN
719 result( ntest ) = ulpinv
726 CALL
csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
727 $ ldz, d, work, rwork, result( ntest ) )
733 CALL
clacpy(
' ', n, n, a, lda, z, ldz )
734 CALL
clacpy( uplo, n, n, b, ldb, bb, ldb )
736 CALL
chegvd( 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 )
'CHEGVD(V,' // uplo //
741 $
')', iinfo, n, jtype, ioldsd
743 IF( iinfo.LT.0 )
THEN
746 result( ntest ) = ulpinv
753 CALL
csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
754 $ ldz, d, work, rwork, result( ntest ) )
760 CALL
clacpy(
' ', n, n, a, lda, ab, lda )
761 CALL
clacpy( uplo, n, n, b, ldb, bb, ldb )
763 CALL
chegvx( 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 )
'CHEGVX(V,A' // uplo //
769 $
')', iinfo, n, jtype, ioldsd
771 IF( iinfo.LT.0 )
THEN
774 result( ntest ) = ulpinv
781 CALL
csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
782 $ ldz, d, work, rwork, result( ntest ) )
786 CALL
clacpy(
' ', n, n, a, lda, ab, lda )
787 CALL
clacpy( uplo, n, n, b, ldb, bb, ldb )
796 CALL
chegvx( 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 )
'CHEGVX(V,V,' //
802 $ uplo //
')', iinfo, n, jtype, ioldsd
804 IF( iinfo.LT.0 )
THEN
807 result( ntest ) = ulpinv
814 CALL
csgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
815 $ ldz, d, work, rwork, result( ntest ) )
819 CALL
clacpy(
' ', n, n, a, lda, ab, lda )
820 CALL
clacpy( uplo, n, n, b, ldb, bb, ldb )
822 CALL
chegvx( 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 )
'CHEGVX(V,I,' //
828 $ uplo //
')', iinfo, n, jtype, ioldsd
830 IF( iinfo.LT.0 )
THEN
833 result( ntest ) = ulpinv
840 CALL
csgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
841 $ ldz, d, work, rwork, result( ntest ) )
851 IF( lsame( uplo,
'U' ) )
THEN
871 CALL
chpgv( ibtype,
'V', uplo, n, ap, bp, d, z, ldz,
872 $ work, rwork, iinfo )
873 IF( iinfo.NE.0 )
THEN
874 WRITE( nounit, fmt = 9999 )
'CHPGV(V,' // uplo //
875 $
')', iinfo, n, jtype, ioldsd
877 IF( iinfo.LT.0 )
THEN
880 result( ntest ) = ulpinv
887 CALL
csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
888 $ ldz, d, work, rwork, result( ntest ) )
896 IF( lsame( uplo,
'U' ) )
THEN
916 CALL
chpgvd( 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 )
'CHPGVD(V,' // uplo //
921 $
')', iinfo, n, jtype, ioldsd
923 IF( iinfo.LT.0 )
THEN
926 result( ntest ) = ulpinv
933 CALL
csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
934 $ ldz, d, work, rwork, result( ntest ) )
942 IF( lsame( uplo,
'U' ) )
THEN
962 CALL
chpgvx( 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 )
'CHPGVX(V,A' // uplo //
967 $
')', iinfo, n, jtype, ioldsd
969 IF( iinfo.LT.0 )
THEN
972 result( ntest ) = ulpinv
979 CALL
csgt01( 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
chpgvx( 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 )
'CHPGVX(V,V' // uplo //
1013 $
')', iinfo, n, jtype, ioldsd
1015 IF( iinfo.LT.0 )
THEN
1018 result( ntest ) = ulpinv
1025 CALL
csgt01( 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
chpgvx( 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 )
'CHPGVX(V,I' // uplo //
1057 $
')', iinfo, n, jtype, ioldsd
1059 IF( iinfo.LT.0 )
THEN
1062 result( ntest ) = ulpinv
1069 CALL
csgt01( 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
chbgv(
'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 )
'CHBGV(V,' //
1106 $ uplo //
')', iinfo, n, jtype, ioldsd
1108 IF( iinfo.LT.0 )
THEN
1111 result( ntest ) = ulpinv
1118 CALL
csgt01( 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
chbgvd(
'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 )
'CHBGVD(V,' //
1152 $ uplo //
')', iinfo, n, jtype, ioldsd
1154 IF( iinfo.LT.0 )
THEN
1157 result( ntest ) = ulpinv
1164 CALL
csgt01( 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
chbgvx(
'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 )
'CHBGVX(V,A' //
1199 $ uplo //
')', iinfo, n, jtype, ioldsd
1201 IF( iinfo.LT.0 )
THEN
1204 result( ntest ) = ulpinv
1211 CALL
csgt01( 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
chbgvx(
'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 )
'CHBGVX(V,V' //
1246 $ uplo //
')', iinfo, n, jtype, ioldsd
1248 IF( iinfo.LT.0 )
THEN
1251 result( ntest ) = ulpinv
1258 CALL
csgt01( 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
chbgvx(
'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 )
'CHBGVX(V,I' //
1291 $ uplo //
')', iinfo, n, jtype, ioldsd
1293 IF( iinfo.LT.0 )
THEN
1296 result( ntest ) = ulpinv
1303 CALL
csgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1304 $ ldz, d, work, rwork, result( ntest ) )
1313 ntestt = ntestt + ntest
1314 CALL
slafts(
'CSG', n, n, jtype, ntest, result, ioldsd,
1315 $ thresh, nounit, nerrs )
1321 CALL
slasum(
'CSG', nounit, nerrs, ntestt )
1325 9999
FORMAT(
' CDRVSG: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
1326 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine clatmr(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)
CLATMR
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
subroutine chpgv(ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, RWORK, INFO)
CHPGST
subroutine chegv(ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, INFO)
CHEGST
subroutine chegvx(ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO)
CHEGST
subroutine chpgvx(ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO)
CHPGST
subroutine chbgvd(JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO)
CHBGST
subroutine chpgvd(ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO)
CHPGST
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine csgt01(ITYPE, UPLO, N, M, A, LDA, B, LDB, Z, LDZ, D, WORK, RWORK, RESULT)
CSGT01
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine chbgv(JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, RWORK, INFO)
CHBGST
subroutine cdrvsg(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)
CDRVSG
subroutine chegvd(ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO)
CHEGST
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine slasum(TYPE, IOUNIT, IE, NRUN)
SLASUM
subroutine chbgvx(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)
CHBGST
subroutine slafts(TYPE, M, N, IMAT, NTESTS, RESULT, ISEED, THRESH, IOUNIT, IE)
SLAFTS