LAPACK  3.9.1
LAPACK: Linear Algebra PACKage

◆ check3()

subroutine check3 ( real  SFAC)

Definition at line 715 of file sblat1.f.

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