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