LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ 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: