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