LAPACK  3.9.1
LAPACK: Linear Algebra PACKage

◆ check3()

subroutine check3 ( double precision  SFAC)

Definition at line 713 of file dblat1.f.

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