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

◆ check3()

subroutine check3 ( real  sfac)

Definition at line 735 of file sblat1.f.

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