LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ check3()

subroutine check3 ( double precision  sfac)

Definition at line 733 of file dblat1.f.

734* .. Parameters ..
735 INTEGER NOUT
736 parameter(nout=6)
737* .. Scalar Arguments ..
738 DOUBLE PRECISION SFAC
739* .. Scalars in Common ..
740 INTEGER ICASE, INCX, INCY, N
741 LOGICAL PASS
742* .. Local Scalars ..
743 DOUBLE PRECISION SC, SS
744 INTEGER I, K, KI, KN, KSIZE, LENX, LENY, MX, MY
745* .. Local Arrays ..
746 DOUBLE PRECISION COPYX(5), COPYY(5), DT9X(7,4,4), DT9Y(7,4,4),
747 + DX1(7), DY1(7), MWPC(11), MWPS(11), MWPSTX(5),
748 + MWPSTY(5), MWPTX(11,5), MWPTY(11,5), MWPX(5),
749 + MWPY(5), SSIZE2(14,2), STX(7), STY(7), SX(7),
750 + SY(7)
751 INTEGER INCXS(4), INCYS(4), LENS(4,2), MWPINX(11),
752 + MWPINY(11), MWPN(11), NS(4)
753* .. External Subroutines ..
754 EXTERNAL drot, stest
755* .. Intrinsic Functions ..
756 INTRINSIC abs, min
757* .. Common blocks ..
758 COMMON /combla/icase, n, incx, incy, pass
759* .. Data statements ..
760 DATA incxs/1, 2, -2, -1/
761 DATA incys/1, -2, 1, -2/
762 DATA lens/1, 1, 2, 4, 1, 1, 3, 7/
763 DATA ns/0, 1, 2, 4/
764 DATA dx1/0.6d0, 0.1d0, -0.5d0, 0.8d0, 0.9d0, -0.3d0,
765 + -0.4d0/
766 DATA dy1/0.5d0, -0.9d0, 0.3d0, 0.7d0, -0.6d0, 0.2d0,
767 + 0.8d0/
768 DATA sc, ss/0.8d0, 0.6d0/
769 DATA dt9x/0.6d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
770 + 0.0d0, 0.78d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
771 + 0.0d0, 0.0d0, 0.78d0, -0.46d0, 0.0d0, 0.0d0,
772 + 0.0d0, 0.0d0, 0.0d0, 0.78d0, -0.46d0, -0.22d0,
773 + 1.06d0, 0.0d0, 0.0d0, 0.0d0, 0.6d0, 0.0d0,
774 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.78d0,
775 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
776 + 0.66d0, 0.1d0, -0.1d0, 0.0d0, 0.0d0, 0.0d0,
777 + 0.0d0, 0.96d0, 0.1d0, -0.76d0, 0.8d0, 0.90d0,
778 + -0.3d0, -0.02d0, 0.6d0, 0.0d0, 0.0d0, 0.0d0,
779 + 0.0d0, 0.0d0, 0.0d0, 0.78d0, 0.0d0, 0.0d0,
780 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, -0.06d0, 0.1d0,
781 + -0.1d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.90d0,
782 + 0.1d0, -0.22d0, 0.8d0, 0.18d0, -0.3d0, -0.02d0,
783 + 0.6d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
784 + 0.78d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
785 + 0.0d0, 0.78d0, 0.26d0, 0.0d0, 0.0d0, 0.0d0,
786 + 0.0d0, 0.0d0, 0.78d0, 0.26d0, -0.76d0, 1.12d0,
787 + 0.0d0, 0.0d0, 0.0d0/
788 DATA dt9y/0.5d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
789 + 0.0d0, 0.04d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
790 + 0.0d0, 0.0d0, 0.04d0, -0.78d0, 0.0d0, 0.0d0,
791 + 0.0d0, 0.0d0, 0.0d0, 0.04d0, -0.78d0, 0.54d0,
792 + 0.08d0, 0.0d0, 0.0d0, 0.0d0, 0.5d0, 0.0d0,
793 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.04d0,
794 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.7d0,
795 + -0.9d0, -0.12d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
796 + 0.64d0, -0.9d0, -0.30d0, 0.7d0, -0.18d0, 0.2d0,
797 + 0.28d0, 0.5d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
798 + 0.0d0, 0.0d0, 0.04d0, 0.0d0, 0.0d0, 0.0d0,
799 + 0.0d0, 0.0d0, 0.0d0, 0.7d0, -1.08d0, 0.0d0,
800 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.64d0, -1.26d0,
801 + 0.54d0, 0.20d0, 0.0d0, 0.0d0, 0.0d0, 0.5d0,
802 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
803 + 0.04d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
804 + 0.0d0, 0.04d0, -0.9d0, 0.18d0, 0.0d0, 0.0d0,
805 + 0.0d0, 0.0d0, 0.04d0, -0.9d0, 0.18d0, 0.7d0,
806 + -0.18d0, 0.2d0, 0.16d0/
807 DATA ssize2/0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
808 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
809 + 0.0d0, 1.17d0, 1.17d0, 1.17d0, 1.17d0, 1.17d0,
810 + 1.17d0, 1.17d0, 1.17d0, 1.17d0, 1.17d0, 1.17d0,
811 + 1.17d0, 1.17d0, 1.17d0/
812* .. Executable Statements ..
813*
814 DO 60 ki = 1, 4
815 incx = incxs(ki)
816 incy = incys(ki)
817 mx = abs(incx)
818 my = abs(incy)
819*
820 DO 40 kn = 1, 4
821 n = ns(kn)
822 ksize = min(2,kn)
823 lenx = lens(kn,mx)
824 leny = lens(kn,my)
825*
826 IF (icase.EQ.4) THEN
827* .. DROT ..
828 DO 20 i = 1, 7
829 sx(i) = dx1(i)
830 sy(i) = dy1(i)
831 stx(i) = dt9x(i,kn,ki)
832 sty(i) = dt9y(i,kn,ki)
833 20 CONTINUE
834 CALL drot(n,sx,incx,sy,incy,sc,ss)
835 CALL stest(lenx,sx,stx,ssize2(1,ksize),sfac)
836 CALL stest(leny,sy,sty,ssize2(1,ksize),sfac)
837 ELSE
838 WRITE (nout,*) ' Shouldn''t be here in CHECK3'
839 stop
840 END IF
841 40 CONTINUE
842 60 CONTINUE
843*
844 mwpc(1) = 1
845 DO 80 i = 2, 11
846 mwpc(i) = 0
847 80 CONTINUE
848 mwps(1) = 0
849 DO 100 i = 2, 6
850 mwps(i) = 1
851 100 CONTINUE
852 DO 120 i = 7, 11
853 mwps(i) = -1
854 120 CONTINUE
855 mwpinx(1) = 1
856 mwpinx(2) = 1
857 mwpinx(3) = 1
858 mwpinx(4) = -1
859 mwpinx(5) = 1
860 mwpinx(6) = -1
861 mwpinx(7) = 1
862 mwpinx(8) = 1
863 mwpinx(9) = -1
864 mwpinx(10) = 1
865 mwpinx(11) = -1
866 mwpiny(1) = 1
867 mwpiny(2) = 1
868 mwpiny(3) = -1
869 mwpiny(4) = -1
870 mwpiny(5) = 2
871 mwpiny(6) = 1
872 mwpiny(7) = 1
873 mwpiny(8) = -1
874 mwpiny(9) = -1
875 mwpiny(10) = 2
876 mwpiny(11) = 1
877 DO 140 i = 1, 11
878 mwpn(i) = 5
879 140 CONTINUE
880 mwpn(5) = 3
881 mwpn(10) = 3
882 DO 160 i = 1, 5
883 mwpx(i) = i
884 mwpy(i) = i
885 mwptx(1,i) = i
886 mwpty(1,i) = i
887 mwptx(2,i) = i
888 mwpty(2,i) = -i
889 mwptx(3,i) = 6 - i
890 mwpty(3,i) = i - 6
891 mwptx(4,i) = i
892 mwpty(4,i) = -i
893 mwptx(6,i) = 6 - i
894 mwpty(6,i) = i - 6
895 mwptx(7,i) = -i
896 mwpty(7,i) = i
897 mwptx(8,i) = i - 6
898 mwpty(8,i) = 6 - i
899 mwptx(9,i) = -i
900 mwpty(9,i) = i
901 mwptx(11,i) = i - 6
902 mwpty(11,i) = 6 - i
903 160 CONTINUE
904 mwptx(5,1) = 1
905 mwptx(5,2) = 3
906 mwptx(5,3) = 5
907 mwptx(5,4) = 4
908 mwptx(5,5) = 5
909 mwpty(5,1) = -1
910 mwpty(5,2) = 2
911 mwpty(5,3) = -2
912 mwpty(5,4) = 4
913 mwpty(5,5) = -3
914 mwptx(10,1) = -1
915 mwptx(10,2) = -3
916 mwptx(10,3) = -5
917 mwptx(10,4) = 4
918 mwptx(10,5) = 5
919 mwpty(10,1) = 1
920 mwpty(10,2) = 2
921 mwpty(10,3) = 2
922 mwpty(10,4) = 4
923 mwpty(10,5) = 3
924 DO 200 i = 1, 11
925 incx = mwpinx(i)
926 incy = mwpiny(i)
927 DO 180 k = 1, 5
928 copyx(k) = mwpx(k)
929 copyy(k) = mwpy(k)
930 mwpstx(k) = mwptx(i,k)
931 mwpsty(k) = mwpty(i,k)
932 180 CONTINUE
933 CALL drot(mwpn(i),copyx,incx,copyy,incy,mwpc(i),mwps(i))
934 CALL stest(5,copyx,mwpstx,mwpstx,sfac)
935 CALL stest(5,copyy,mwpsty,mwpsty,sfac)
936 200 CONTINUE
937 RETURN
938*
939* End of CHECK3
940*
stest
subroutine stest(len, scomp, strue, ssize, sfac)
Definition cblat1.f:614
drot
subroutine drot(n, dx, incx, dy, incy, c, s)
DROT
Definition drot.f:92
Here is the call graph for this function:
Here is the caller graph for this function: