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 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 chbgvd(JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO)
CHBGVD
subroutine csgt01(ITYPE, UPLO, N, M, A, LDA, B, LDB, Z, LDZ, D, WORK, RWORK, RESULT)
CSGT01
subroutine chpgv(ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, RWORK, INFO)
CHPGV
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 chbgv(JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, RWORK, INFO)
CHBGV
subroutine slafts(TYPE, M, N, IMAT, NTESTS, RESULT, ISEED, THRESH, IOUNIT, IE)
SLAFTS
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 chpgvx(ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO)
CHPGVX
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)
CHBGVX
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
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)
CHEGVX
subroutine chpgvd(ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO)
CHPGVD
subroutine chegv(ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, INFO)
CHEGV
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine chegvd(ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO)
CHEGVD
subroutine slasum(TYPE, IOUNIT, IE, NRUN)
SLASUM