LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ check3()

subroutine check3 ( double precision  SFAC)

Definition at line 728 of file dblat1.f.

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