376
377 IMPLICIT NONE
378
379
380
381
382
383
384 INTEGER INFO, LDA, LDB, LDZ, LIWORK, LRWORK, NOUNIT,
385 $ NSIZES, NTYPES, NWORK
386 REAL THRESH
387
388
389 LOGICAL DOTYPE( * )
390 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
391 REAL D( * ), D2( * ), RESULT( * ), RWORK( * )
392 COMPLEX A( LDA, * ), AB( LDA, * ), AP( * ),
393 $ B( LDB, * ), BB( LDB, * ), BP( * ), WORK( * ),
394 $ Z( LDZ, * )
395
396
397
398
399
400 REAL ZERO, ONE, TEN
401 parameter( zero = 0.0e+0, one = 1.0e+0, ten = 10.0e+0 )
402 COMPLEX CZERO, CONE
403 parameter( czero = ( 0.0e+0, 0.0e+0 ),
404 $ cone = ( 1.0e+0, 0.0e+0 ) )
405 INTEGER MAXTYP
406 parameter( maxtyp = 21 )
407
408
409 LOGICAL BADNN
410 CHARACTER UPLO
411 INTEGER I, IBTYPE, IBUPLO, IINFO, IJ, IL, IMODE, ITEMP,
412 $ ITYPE, IU, J, JCOL, JSIZE, JTYPE, KA, KA9, KB,
413 $ KB9, M, MTYPES, N, NERRS, NMATS, NMAX, NTEST,
414 $ NTESTT
415 REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
416 $ RTUNFL, ULP, ULPINV, UNFL, VL, VU, TEMP1, TEMP2
417
418
419 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
420 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
421 $ KTYPE( MAXTYP )
422
423
424 LOGICAL LSAME
425 REAL SLAMCH, SLARND
427
428
433
434
435 INTRINSIC abs, real, max, min, sqrt
436
437
438 DATA ktype / 1, 2, 5*4, 5*5, 3*8, 6*9 /
439 DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
440 $ 2, 3, 6*1 /
441 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
442 $ 0, 0, 6*4 /
443
444
445
446
447
448 ntestt = 0
449 info = 0
450
451 badnn = .false.
452 nmax = 0
453 DO 10 j = 1, nsizes
454 nmax = max( nmax, nn( j ) )
455 IF( nn( j ).LT.0 )
456 $ badnn = .true.
457 10 CONTINUE
458
459
460
461 IF( nsizes.LT.0 ) THEN
462 info = -1
463 ELSE IF( badnn ) THEN
464 info = -2
465 ELSE IF( ntypes.LT.0 ) THEN
466 info = -3
467 ELSE IF( lda.LE.1 .OR. lda.LT.nmax ) THEN
468 info = -9
469 ELSE IF( ldz.LE.1 .OR. ldz.LT.nmax ) THEN
470 info = -16
471 ELSE IF( 2*max( nmax, 2 )**2.GT.nwork ) THEN
472 info = -21
473 ELSE IF( 2*max( nmax, 2 )**2.GT.lrwork ) THEN
474 info = -23
475 ELSE IF( 2*max( nmax, 2 )**2.GT.liwork ) THEN
476 info = -25
477 END IF
478
479 IF( info.NE.0 ) THEN
480 CALL xerbla(
'CDRVSG2STG', -info )
481 RETURN
482 END IF
483
484
485
486 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
487 $ RETURN
488
489
490
491 unfl =
slamch(
'Safe minimum' )
492 ovfl =
slamch(
'Overflow' )
494 ulpinv = one / ulp
495 rtunfl = sqrt( unfl )
496 rtovfl = sqrt( ovfl )
497
498 DO 20 i = 1, 4
499 iseed2( i ) = iseed( i )
500 20 CONTINUE
501
502
503
504 nerrs = 0
505 nmats = 0
506
507 DO 650 jsize = 1, nsizes
508 n = nn( jsize )
509 aninv = one / real( max( 1, n ) )
510
511 IF( nsizes.NE.1 ) THEN
512 mtypes = min( maxtyp, ntypes )
513 ELSE
514 mtypes = min( maxtyp+1, ntypes )
515 END IF
516
517 ka9 = 0
518 kb9 = 0
519 DO 640 jtype = 1, mtypes
520 IF( .NOT.dotype( jtype ) )
521 $ GO TO 640
522 nmats = nmats + 1
523 ntest = 0
524
525 DO 30 j = 1, 4
526 ioldsd( j ) = iseed( j )
527 30 CONTINUE
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544 IF( mtypes.GT.maxtyp )
545 $ GO TO 90
546
547 itype = ktype( jtype )
548 imode = kmode( jtype )
549
550
551
552 GO TO ( 40, 50, 60 )kmagn( jtype )
553
554 40 CONTINUE
555 anorm = one
556 GO TO 70
557
558 50 CONTINUE
559 anorm = ( rtovfl*ulp )*aninv
560 GO TO 70
561
562 60 CONTINUE
563 anorm = rtunfl*n*ulpinv
564 GO TO 70
565
566 70 CONTINUE
567
568 iinfo = 0
569 cond = ulpinv
570
571
572
573 IF( itype.EQ.1 ) THEN
574
575
576
577 ka = 0
578 kb = 0
579 CALL claset(
'Full', lda, n, czero, czero, a, lda )
580
581 ELSE IF( itype.EQ.2 ) THEN
582
583
584
585 ka = 0
586 kb = 0
587 CALL claset(
'Full', lda, n, czero, czero, a, lda )
588 DO 80 jcol = 1, n
589 a( jcol, jcol ) = anorm
590 80 CONTINUE
591
592 ELSE IF( itype.EQ.4 ) THEN
593
594
595
596 ka = 0
597 kb = 0
598 CALL clatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
599 $ anorm, 0, 0, 'N', a, lda, work, iinfo )
600
601 ELSE IF( itype.EQ.5 ) THEN
602
603
604
605 ka = max( 0, n-1 )
606 kb = ka
607 CALL clatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
608 $ anorm, n, n, 'N', a, lda, work, iinfo )
609
610 ELSE IF( itype.EQ.7 ) THEN
611
612
613
614 ka = 0
615 kb = 0
616 CALL clatmr( n, n,
'S', iseed,
'H', work, 6, one, cone,
617 $ 'T', 'N', work( n+1 ), 1, one,
618 $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
619 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
620
621 ELSE IF( itype.EQ.8 ) THEN
622
623
624
625 ka = max( 0, n-1 )
626 kb = ka
627 CALL clatmr( n, n,
'S', iseed,
'H', work, 6, one, cone,
628 $ 'T', 'N', work( n+1 ), 1, one,
629 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
630 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
631
632 ELSE IF( itype.EQ.9 ) THEN
633
634
635
636
637
638
639
640
641
642
643
644
645 kb9 = kb9 + 1
646 IF( kb9.GT.ka9 ) THEN
647 ka9 = ka9 + 1
648 kb9 = 1
649 END IF
650 ka = max( 0, min( n-1, ka9 ) )
651 kb = max( 0, min( n-1, kb9 ) )
652 CALL clatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
653 $ anorm, ka, ka, 'N', a, lda, work, iinfo )
654
655 ELSE
656
657 iinfo = 1
658 END IF
659
660 IF( iinfo.NE.0 ) THEN
661 WRITE( nounit, fmt = 9999 )'Generator', iinfo, n, jtype,
662 $ ioldsd
663 info = abs( iinfo )
664 RETURN
665 END IF
666
667 90 CONTINUE
668
669 abstol = unfl + unfl
670 IF( n.LE.1 ) THEN
671 il = 1
672 iu = n
673 ELSE
674 il = 1 + int( ( n-1 )*
slarnd( 1, iseed2 ) )
675 iu = 1 + int( ( n-1 )*
slarnd( 1, iseed2 ) )
676 IF( il.GT.iu ) THEN
677 itemp = il
678 il = iu
679 iu = itemp
680 END IF
681 END IF
682
683
684
685
686
687
688
689
690
691 DO 630 ibtype = 1, 3
692
693
694
695 DO 620 ibuplo = 1, 2
696 IF( ibuplo.EQ.1 )
697 $ uplo = 'U'
698 IF( ibuplo.EQ.2 )
699 $ uplo = 'L'
700
701
702
703
704 CALL clatms( n, n,
'U', iseed,
'P', rwork, 5, ten,
705 $ one, kb, kb, uplo, b, ldb, work( n+1 ),
706 $ iinfo )
707
708
709
710 ntest = ntest + 1
711
712 CALL clacpy(
' ', n, n, a, lda, z, ldz )
713 CALL clacpy( uplo, n, n, b, ldb, bb, ldb )
714
715 CALL chegv( ibtype,
'V', uplo, n, z, ldz, bb, ldb, d,
716 $ work, nwork, rwork, iinfo )
717 IF( iinfo.NE.0 ) THEN
718 WRITE( nounit, fmt = 9999 )'CHEGV(V,' // uplo //
719 $ ')', iinfo, n, jtype, ioldsd
720 info = abs( iinfo )
721 IF( iinfo.LT.0 ) THEN
722 RETURN
723 ELSE
724 result( ntest ) = ulpinv
725 GO TO 100
726 END IF
727 END IF
728
729
730
731 CALL csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
732 $ ldz, d, work, rwork, result( ntest ) )
733
734
735
736 ntest = ntest + 1
737
738 CALL clacpy(
' ', n, n, a, lda, z, ldz )
739 CALL clacpy( uplo, n, n, b, ldb, bb, ldb )
740
742 $ bb, ldb, d2, work, nwork, rwork,
743 $ iinfo )
744 IF( iinfo.NE.0 ) THEN
745 WRITE( nounit, fmt = 9999 )
746 $ 'CHEGV_2STAGE(V,' // uplo //
747 $ ')', iinfo, n, jtype, ioldsd
748 info = abs( iinfo )
749 IF( iinfo.LT.0 ) THEN
750 RETURN
751 ELSE
752 result( ntest ) = ulpinv
753 GO TO 100
754 END IF
755 END IF
756
757
758
759
760
761
762
763
764
765
766 temp1 = zero
767 temp2 = zero
768 DO 151 j = 1, n
769 temp1 = max( temp1, abs( d( j ) ),
770 $ abs( d2( j ) ) )
771 temp2 = max( temp2, abs( d( j )-d2( j ) ) )
772 151 CONTINUE
773
774 result( ntest ) = temp2 /
775 $ max( unfl, ulp*max( temp1, temp2 ) )
776
777
778
779 ntest = ntest + 1
780
781 CALL clacpy(
' ', n, n, a, lda, z, ldz )
782 CALL clacpy( uplo, n, n, b, ldb, bb, ldb )
783
784 CALL chegvd( ibtype,
'V', uplo, n, z, ldz, bb, ldb, d,
785 $ work, nwork, rwork, lrwork, iwork,
786 $ liwork, iinfo )
787 IF( iinfo.NE.0 ) THEN
788 WRITE( nounit, fmt = 9999 )'CHEGVD(V,' // uplo //
789 $ ')', iinfo, n, jtype, ioldsd
790 info = abs( iinfo )
791 IF( iinfo.LT.0 ) THEN
792 RETURN
793 ELSE
794 result( ntest ) = ulpinv
795 GO TO 100
796 END IF
797 END IF
798
799
800
801 CALL csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
802 $ ldz, d, work, rwork, result( ntest ) )
803
804
805
806 ntest = ntest + 1
807
808 CALL clacpy(
' ', n, n, a, lda, ab, lda )
809 CALL clacpy( uplo, n, n, b, ldb, bb, ldb )
810
811 CALL chegvx( ibtype,
'V',
'A', uplo, n, ab, lda, bb,
812 $ ldb, vl, vu, il, iu, abstol, m, d, z,
813 $ ldz, work, nwork, rwork, iwork( n+1 ),
814 $ iwork, iinfo )
815 IF( iinfo.NE.0 ) THEN
816 WRITE( nounit, fmt = 9999 )'CHEGVX(V,A' // uplo //
817 $ ')', iinfo, n, jtype, ioldsd
818 info = abs( iinfo )
819 IF( iinfo.LT.0 ) THEN
820 RETURN
821 ELSE
822 result( ntest ) = ulpinv
823 GO TO 100
824 END IF
825 END IF
826
827
828
829 CALL csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
830 $ ldz, d, work, rwork, result( ntest ) )
831
832 ntest = ntest + 1
833
834 CALL clacpy(
' ', n, n, a, lda, ab, lda )
835 CALL clacpy( uplo, n, n, b, ldb, bb, ldb )
836
837
838
839
840
841
842 vl = zero
843 vu = anorm
844 CALL chegvx( ibtype,
'V',
'V', uplo, n, ab, lda, bb,
845 $ ldb, vl, vu, il, iu, abstol, m, d, z,
846 $ ldz, work, nwork, rwork, iwork( n+1 ),
847 $ iwork, iinfo )
848 IF( iinfo.NE.0 ) THEN
849 WRITE( nounit, fmt = 9999 )'CHEGVX(V,V,' //
850 $ uplo // ')', iinfo, n, jtype, ioldsd
851 info = abs( iinfo )
852 IF( iinfo.LT.0 ) THEN
853 RETURN
854 ELSE
855 result( ntest ) = ulpinv
856 GO TO 100
857 END IF
858 END IF
859
860
861
862 CALL csgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
863 $ ldz, d, work, rwork, result( ntest ) )
864
865 ntest = ntest + 1
866
867 CALL clacpy(
' ', n, n, a, lda, ab, lda )
868 CALL clacpy( uplo, n, n, b, ldb, bb, ldb )
869
870 CALL chegvx( ibtype,
'V',
'I', uplo, n, ab, lda, bb,
871 $ ldb, vl, vu, il, iu, abstol, m, d, z,
872 $ ldz, work, nwork, rwork, iwork( n+1 ),
873 $ iwork, iinfo )
874 IF( iinfo.NE.0 ) THEN
875 WRITE( nounit, fmt = 9999 )'CHEGVX(V,I,' //
876 $ uplo // ')', iinfo, n, jtype, ioldsd
877 info = abs( iinfo )
878 IF( iinfo.LT.0 ) THEN
879 RETURN
880 ELSE
881 result( ntest ) = ulpinv
882 GO TO 100
883 END IF
884 END IF
885
886
887
888 CALL csgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
889 $ ldz, d, work, rwork, result( ntest ) )
890
891 100 CONTINUE
892
893
894
895 ntest = ntest + 1
896
897
898
899 IF(
lsame( uplo,
'U' ) )
THEN
900 ij = 1
901 DO 120 j = 1, n
902 DO 110 i = 1, j
903 ap( ij ) = a( i, j )
904 bp( ij ) = b( i, j )
905 ij = ij + 1
906 110 CONTINUE
907 120 CONTINUE
908 ELSE
909 ij = 1
910 DO 140 j = 1, n
911 DO 130 i = j, n
912 ap( ij ) = a( i, j )
913 bp( ij ) = b( i, j )
914 ij = ij + 1
915 130 CONTINUE
916 140 CONTINUE
917 END IF
918
919 CALL chpgv( ibtype,
'V', uplo, n, ap, bp, d, z, ldz,
920 $ work, rwork, iinfo )
921 IF( iinfo.NE.0 ) THEN
922 WRITE( nounit, fmt = 9999 )'CHPGV(V,' // uplo //
923 $ ')', iinfo, n, jtype, ioldsd
924 info = abs( iinfo )
925 IF( iinfo.LT.0 ) THEN
926 RETURN
927 ELSE
928 result( ntest ) = ulpinv
929 GO TO 310
930 END IF
931 END IF
932
933
934
935 CALL csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
936 $ ldz, d, work, rwork, result( ntest ) )
937
938
939
940 ntest = ntest + 1
941
942
943
944 IF(
lsame( uplo,
'U' ) )
THEN
945 ij = 1
946 DO 160 j = 1, n
947 DO 150 i = 1, j
948 ap( ij ) = a( i, j )
949 bp( ij ) = b( i, j )
950 ij = ij + 1
951 150 CONTINUE
952 160 CONTINUE
953 ELSE
954 ij = 1
955 DO 180 j = 1, n
956 DO 170 i = j, n
957 ap( ij ) = a( i, j )
958 bp( ij ) = b( i, j )
959 ij = ij + 1
960 170 CONTINUE
961 180 CONTINUE
962 END IF
963
964 CALL chpgvd( ibtype,
'V', uplo, n, ap, bp, d, z, ldz,
965 $ work, nwork, rwork, lrwork, iwork,
966 $ liwork, iinfo )
967 IF( iinfo.NE.0 ) THEN
968 WRITE( nounit, fmt = 9999 )'CHPGVD(V,' // uplo //
969 $ ')', iinfo, n, jtype, ioldsd
970 info = abs( iinfo )
971 IF( iinfo.LT.0 ) THEN
972 RETURN
973 ELSE
974 result( ntest ) = ulpinv
975 GO TO 310
976 END IF
977 END IF
978
979
980
981 CALL csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
982 $ ldz, d, work, rwork, result( ntest ) )
983
984
985
986 ntest = ntest + 1
987
988
989
990 IF(
lsame( uplo,
'U' ) )
THEN
991 ij = 1
992 DO 200 j = 1, n
993 DO 190 i = 1, j
994 ap( ij ) = a( i, j )
995 bp( ij ) = b( i, j )
996 ij = ij + 1
997 190 CONTINUE
998 200 CONTINUE
999 ELSE
1000 ij = 1
1001 DO 220 j = 1, n
1002 DO 210 i = j, n
1003 ap( ij ) = a( i, j )
1004 bp( ij ) = b( i, j )
1005 ij = ij + 1
1006 210 CONTINUE
1007 220 CONTINUE
1008 END IF
1009
1010 CALL chpgvx( ibtype,
'V',
'A', uplo, n, ap, bp, vl,
1011 $ vu, il, iu, abstol, m, d, z, ldz, work,
1012 $ rwork, iwork( n+1 ), iwork, info )
1013 IF( iinfo.NE.0 ) THEN
1014 WRITE( nounit, fmt = 9999 )'CHPGVX(V,A' // uplo //
1015 $ ')', iinfo, n, jtype, ioldsd
1016 info = abs( iinfo )
1017 IF( iinfo.LT.0 ) THEN
1018 RETURN
1019 ELSE
1020 result( ntest ) = ulpinv
1021 GO TO 310
1022 END IF
1023 END IF
1024
1025
1026
1027 CALL csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1028 $ ldz, d, work, rwork, result( ntest ) )
1029
1030 ntest = ntest + 1
1031
1032
1033
1034 IF(
lsame( uplo,
'U' ) )
THEN
1035 ij = 1
1036 DO 240 j = 1, n
1037 DO 230 i = 1, j
1038 ap( ij ) = a( i, j )
1039 bp( ij ) = b( i, j )
1040 ij = ij + 1
1041 230 CONTINUE
1042 240 CONTINUE
1043 ELSE
1044 ij = 1
1045 DO 260 j = 1, n
1046 DO 250 i = j, n
1047 ap( ij ) = a( i, j )
1048 bp( ij ) = b( i, j )
1049 ij = ij + 1
1050 250 CONTINUE
1051 260 CONTINUE
1052 END IF
1053
1054 vl = zero
1055 vu = anorm
1056 CALL chpgvx( ibtype,
'V',
'V', uplo, n, ap, bp, vl,
1057 $ vu, il, iu, abstol, m, d, z, ldz, work,
1058 $ rwork, iwork( n+1 ), iwork, info )
1059 IF( iinfo.NE.0 ) THEN
1060 WRITE( nounit, fmt = 9999 )'CHPGVX(V,V' // uplo //
1061 $ ')', iinfo, n, jtype, ioldsd
1062 info = abs( iinfo )
1063 IF( iinfo.LT.0 ) THEN
1064 RETURN
1065 ELSE
1066 result( ntest ) = ulpinv
1067 GO TO 310
1068 END IF
1069 END IF
1070
1071
1072
1073 CALL csgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1074 $ ldz, d, work, rwork, result( ntest ) )
1075
1076 ntest = ntest + 1
1077
1078
1079
1080 IF(
lsame( uplo,
'U' ) )
THEN
1081 ij = 1
1082 DO 280 j = 1, n
1083 DO 270 i = 1, j
1084 ap( ij ) = a( i, j )
1085 bp( ij ) = b( i, j )
1086 ij = ij + 1
1087 270 CONTINUE
1088 280 CONTINUE
1089 ELSE
1090 ij = 1
1091 DO 300 j = 1, n
1092 DO 290 i = j, n
1093 ap( ij ) = a( i, j )
1094 bp( ij ) = b( i, j )
1095 ij = ij + 1
1096 290 CONTINUE
1097 300 CONTINUE
1098 END IF
1099
1100 CALL chpgvx( ibtype,
'V',
'I', uplo, n, ap, bp, vl,
1101 $ vu, il, iu, abstol, m, d, z, ldz, work,
1102 $ rwork, iwork( n+1 ), iwork, info )
1103 IF( iinfo.NE.0 ) THEN
1104 WRITE( nounit, fmt = 9999 )'CHPGVX(V,I' // uplo //
1105 $ ')', iinfo, n, jtype, ioldsd
1106 info = abs( iinfo )
1107 IF( iinfo.LT.0 ) THEN
1108 RETURN
1109 ELSE
1110 result( ntest ) = ulpinv
1111 GO TO 310
1112 END IF
1113 END IF
1114
1115
1116
1117 CALL csgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1118 $ ldz, d, work, rwork, result( ntest ) )
1119
1120 310 CONTINUE
1121
1122 IF( ibtype.EQ.1 ) THEN
1123
1124
1125
1126 ntest = ntest + 1
1127
1128
1129
1130 IF(
lsame( uplo,
'U' ) )
THEN
1131 DO 340 j = 1, n
1132 DO 320 i = max( 1, j-ka ), j
1133 ab( ka+1+i-j, j ) = a( i, j )
1134 320 CONTINUE
1135 DO 330 i = max( 1, j-kb ), j
1136 bb( kb+1+i-j, j ) = b( i, j )
1137 330 CONTINUE
1138 340 CONTINUE
1139 ELSE
1140 DO 370 j = 1, n
1141 DO 350 i = j, min( n, j+ka )
1142 ab( 1+i-j, j ) = a( i, j )
1143 350 CONTINUE
1144 DO 360 i = j, min( n, j+kb )
1145 bb( 1+i-j, j ) = b( i, j )
1146 360 CONTINUE
1147 370 CONTINUE
1148 END IF
1149
1150 CALL chbgv(
'V', uplo, n, ka, kb, ab, lda, bb, ldb,
1151 $ d, z, ldz, work, rwork, iinfo )
1152 IF( iinfo.NE.0 ) THEN
1153 WRITE( nounit, fmt = 9999 )'CHBGV(V,' //
1154 $ uplo // ')', iinfo, n, jtype, ioldsd
1155 info = abs( iinfo )
1156 IF( iinfo.LT.0 ) THEN
1157 RETURN
1158 ELSE
1159 result( ntest ) = ulpinv
1160 GO TO 620
1161 END IF
1162 END IF
1163
1164
1165
1166 CALL csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1167 $ ldz, d, work, rwork, result( ntest ) )
1168
1169
1170
1171 ntest = ntest + 1
1172
1173
1174
1175 IF(
lsame( uplo,
'U' ) )
THEN
1176 DO 400 j = 1, n
1177 DO 380 i = max( 1, j-ka ), j
1178 ab( ka+1+i-j, j ) = a( i, j )
1179 380 CONTINUE
1180 DO 390 i = max( 1, j-kb ), j
1181 bb( kb+1+i-j, j ) = b( i, j )
1182 390 CONTINUE
1183 400 CONTINUE
1184 ELSE
1185 DO 430 j = 1, n
1186 DO 410 i = j, min( n, j+ka )
1187 ab( 1+i-j, j ) = a( i, j )
1188 410 CONTINUE
1189 DO 420 i = j, min( n, j+kb )
1190 bb( 1+i-j, j ) = b( i, j )
1191 420 CONTINUE
1192 430 CONTINUE
1193 END IF
1194
1195 CALL chbgvd(
'V', uplo, n, ka, kb, ab, lda, bb,
1196 $ ldb, d, z, ldz, work, nwork, rwork,
1197 $ lrwork, iwork, liwork, iinfo )
1198 IF( iinfo.NE.0 ) THEN
1199 WRITE( nounit, fmt = 9999 )'CHBGVD(V,' //
1200 $ uplo // ')', iinfo, n, jtype, ioldsd
1201 info = abs( iinfo )
1202 IF( iinfo.LT.0 ) THEN
1203 RETURN
1204 ELSE
1205 result( ntest ) = ulpinv
1206 GO TO 620
1207 END IF
1208 END IF
1209
1210
1211
1212 CALL csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1213 $ ldz, d, work, rwork, result( ntest ) )
1214
1215
1216
1217 ntest = ntest + 1
1218
1219
1220
1221 IF(
lsame( uplo,
'U' ) )
THEN
1222 DO 460 j = 1, n
1223 DO 440 i = max( 1, j-ka ), j
1224 ab( ka+1+i-j, j ) = a( i, j )
1225 440 CONTINUE
1226 DO 450 i = max( 1, j-kb ), j
1227 bb( kb+1+i-j, j ) = b( i, j )
1228 450 CONTINUE
1229 460 CONTINUE
1230 ELSE
1231 DO 490 j = 1, n
1232 DO 470 i = j, min( n, j+ka )
1233 ab( 1+i-j, j ) = a( i, j )
1234 470 CONTINUE
1235 DO 480 i = j, min( n, j+kb )
1236 bb( 1+i-j, j ) = b( i, j )
1237 480 CONTINUE
1238 490 CONTINUE
1239 END IF
1240
1241 CALL chbgvx(
'V',
'A', uplo, n, ka, kb, ab, lda,
1242 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1243 $ iu, abstol, m, d, z, ldz, work, rwork,
1244 $ iwork( n+1 ), iwork, iinfo )
1245 IF( iinfo.NE.0 ) THEN
1246 WRITE( nounit, fmt = 9999 )'CHBGVX(V,A' //
1247 $ uplo // ')', iinfo, n, jtype, ioldsd
1248 info = abs( iinfo )
1249 IF( iinfo.LT.0 ) THEN
1250 RETURN
1251 ELSE
1252 result( ntest ) = ulpinv
1253 GO TO 620
1254 END IF
1255 END IF
1256
1257
1258
1259 CALL csgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1260 $ ldz, d, work, rwork, result( ntest ) )
1261
1262 ntest = ntest + 1
1263
1264
1265
1266 IF(
lsame( uplo,
'U' ) )
THEN
1267 DO 520 j = 1, n
1268 DO 500 i = max( 1, j-ka ), j
1269 ab( ka+1+i-j, j ) = a( i, j )
1270 500 CONTINUE
1271 DO 510 i = max( 1, j-kb ), j
1272 bb( kb+1+i-j, j ) = b( i, j )
1273 510 CONTINUE
1274 520 CONTINUE
1275 ELSE
1276 DO 550 j = 1, n
1277 DO 530 i = j, min( n, j+ka )
1278 ab( 1+i-j, j ) = a( i, j )
1279 530 CONTINUE
1280 DO 540 i = j, min( n, j+kb )
1281 bb( 1+i-j, j ) = b( i, j )
1282 540 CONTINUE
1283 550 CONTINUE
1284 END IF
1285
1286 vl = zero
1287 vu = anorm
1288 CALL chbgvx(
'V',
'V', uplo, n, ka, kb, ab, lda,
1289 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1290 $ iu, abstol, m, d, z, ldz, work, rwork,
1291 $ iwork( n+1 ), iwork, iinfo )
1292 IF( iinfo.NE.0 ) THEN
1293 WRITE( nounit, fmt = 9999 )'CHBGVX(V,V' //
1294 $ uplo // ')', iinfo, n, jtype, ioldsd
1295 info = abs( iinfo )
1296 IF( iinfo.LT.0 ) THEN
1297 RETURN
1298 ELSE
1299 result( ntest ) = ulpinv
1300 GO TO 620
1301 END IF
1302 END IF
1303
1304
1305
1306 CALL csgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1307 $ ldz, d, work, rwork, result( ntest ) )
1308
1309 ntest = ntest + 1
1310
1311
1312
1313 IF(
lsame( uplo,
'U' ) )
THEN
1314 DO 580 j = 1, n
1315 DO 560 i = max( 1, j-ka ), j
1316 ab( ka+1+i-j, j ) = a( i, j )
1317 560 CONTINUE
1318 DO 570 i = max( 1, j-kb ), j
1319 bb( kb+1+i-j, j ) = b( i, j )
1320 570 CONTINUE
1321 580 CONTINUE
1322 ELSE
1323 DO 610 j = 1, n
1324 DO 590 i = j, min( n, j+ka )
1325 ab( 1+i-j, j ) = a( i, j )
1326 590 CONTINUE
1327 DO 600 i = j, min( n, j+kb )
1328 bb( 1+i-j, j ) = b( i, j )
1329 600 CONTINUE
1330 610 CONTINUE
1331 END IF
1332
1333 CALL chbgvx(
'V',
'I', uplo, n, ka, kb, ab, lda,
1334 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1335 $ iu, abstol, m, d, z, ldz, work, rwork,
1336 $ iwork( n+1 ), iwork, iinfo )
1337 IF( iinfo.NE.0 ) THEN
1338 WRITE( nounit, fmt = 9999 )'CHBGVX(V,I' //
1339 $ uplo // ')', iinfo, n, jtype, ioldsd
1340 info = abs( iinfo )
1341 IF( iinfo.LT.0 ) THEN
1342 RETURN
1343 ELSE
1344 result( ntest ) = ulpinv
1345 GO TO 620
1346 END IF
1347 END IF
1348
1349
1350
1351 CALL csgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1352 $ ldz, d, work, rwork, result( ntest ) )
1353
1354 END IF
1355
1356 620 CONTINUE
1357 630 CONTINUE
1358
1359
1360
1361 ntestt = ntestt + ntest
1362 CALL slafts(
'CSG', n, n, jtype, ntest, result, ioldsd,
1363 $ thresh, nounit, nerrs )
1364 640 CONTINUE
1365 650 CONTINUE
1366
1367
1368
1369 CALL slasum(
'CSG', nounit, nerrs, ntestt )
1370
1371 RETURN
1372
1373 9999 FORMAT( ' CDRVSG2STG: ', a, ' returned INFO=', i6, '.', / 9x,
1374 $ 'N=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
1375
1376
1377
subroutine xerbla(srname, info)
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 csgt01(itype, uplo, n, m, a, lda, b, ldb, z, ldz, d, work, rwork, result)
CSGT01
subroutine chbgv(jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z, ldz, work, rwork, info)
CHBGV
subroutine chbgvd(jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z, ldz, work, lwork, rwork, lrwork, iwork, liwork, info)
CHBGVD
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 chegv_2stage(itype, jobz, uplo, n, a, lda, b, ldb, w, work, lwork, rwork, info)
CHEGV_2STAGE
subroutine chegv(itype, jobz, uplo, n, a, lda, b, ldb, w, work, lwork, rwork, info)
CHEGV
subroutine chegvd(itype, jobz, uplo, n, a, lda, b, ldb, w, work, lwork, rwork, lrwork, iwork, liwork, info)
CHEGVD
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 chpgv(itype, jobz, uplo, n, ap, bp, w, z, ldz, work, rwork, info)
CHPGV
subroutine chpgvd(itype, jobz, uplo, n, ap, bp, w, z, ldz, work, lwork, rwork, lrwork, iwork, liwork, info)
CHPGVD
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 clacpy(uplo, m, n, a, lda, b, ldb)
CLACPY copies all or part of one two-dimensional array to another.
real function slamch(cmach)
SLAMCH
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.
logical function lsame(ca, cb)
LSAME
subroutine slafts(type, m, n, imat, ntests, result, iseed, thresh, iounit, ie)
SLAFTS
real function slarnd(idist, iseed)
SLARND
subroutine slasum(type, iounit, ie, nrun)
SLASUM