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

◆ check3()

subroutine check3 ( real  SFAC)

Definition at line 730 of file sblat1.f.

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