LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine check3 ( double precision  SFAC)

Definition at line 681 of file dblat1.f.

681 * .. Parameters ..
682  INTEGER nout
683  parameter (nout=6)
684 * .. Scalar Arguments ..
685  DOUBLE PRECISION sfac
686 * .. Scalars in Common ..
687  INTEGER icase, incx, incy, n
688  LOGICAL pass
689 * .. Local Scalars ..
690  DOUBLE PRECISION sc, ss
691  INTEGER i, k, ki, kn, ksize, lenx, leny, mx, my
692 * .. Local Arrays ..
693  DOUBLE PRECISION copyx(5), copyy(5), dt9x(7,4,4), dt9y(7,4,4),
694  + dx1(7), dy1(7), mwpc(11), mwps(11), mwpstx(5),
695  + mwpsty(5), mwptx(11,5), mwpty(11,5), mwpx(5),
696  + mwpy(5), ssize2(14,2), stx(7), sty(7), sx(7),
697  + sy(7)
698  INTEGER incxs(4), incys(4), lens(4,2), mwpinx(11),
699  + mwpiny(11), mwpn(11), ns(4)
700 * .. External Subroutines ..
701  EXTERNAL drot, stest
702 * .. Intrinsic Functions ..
703  INTRINSIC abs, min
704 * .. Common blocks ..
705  COMMON /combla/icase, n, incx, incy, pass
706 * .. Data statements ..
707  DATA incxs/1, 2, -2, -1/
708  DATA incys/1, -2, 1, -2/
709  DATA lens/1, 1, 2, 4, 1, 1, 3, 7/
710  DATA ns/0, 1, 2, 4/
711  DATA dx1/0.6d0, 0.1d0, -0.5d0, 0.8d0, 0.9d0, -0.3d0,
712  + -0.4d0/
713  DATA dy1/0.5d0, -0.9d0, 0.3d0, 0.7d0, -0.6d0, 0.2d0,
714  + 0.8d0/
715  DATA sc, ss/0.8d0, 0.6d0/
716  DATA dt9x/0.6d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
717  + 0.0d0, 0.78d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
718  + 0.0d0, 0.0d0, 0.78d0, -0.46d0, 0.0d0, 0.0d0,
719  + 0.0d0, 0.0d0, 0.0d0, 0.78d0, -0.46d0, -0.22d0,
720  + 1.06d0, 0.0d0, 0.0d0, 0.0d0, 0.6d0, 0.0d0,
721  + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.78d0,
722  + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
723  + 0.66d0, 0.1d0, -0.1d0, 0.0d0, 0.0d0, 0.0d0,
724  + 0.0d0, 0.96d0, 0.1d0, -0.76d0, 0.8d0, 0.90d0,
725  + -0.3d0, -0.02d0, 0.6d0, 0.0d0, 0.0d0, 0.0d0,
726  + 0.0d0, 0.0d0, 0.0d0, 0.78d0, 0.0d0, 0.0d0,
727  + 0.0d0, 0.0d0, 0.0d0, 0.0d0, -0.06d0, 0.1d0,
728  + -0.1d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.90d0,
729  + 0.1d0, -0.22d0, 0.8d0, 0.18d0, -0.3d0, -0.02d0,
730  + 0.6d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
731  + 0.78d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
732  + 0.0d0, 0.78d0, 0.26d0, 0.0d0, 0.0d0, 0.0d0,
733  + 0.0d0, 0.0d0, 0.78d0, 0.26d0, -0.76d0, 1.12d0,
734  + 0.0d0, 0.0d0, 0.0d0/
735  DATA dt9y/0.5d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
736  + 0.0d0, 0.04d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
737  + 0.0d0, 0.0d0, 0.04d0, -0.78d0, 0.0d0, 0.0d0,
738  + 0.0d0, 0.0d0, 0.0d0, 0.04d0, -0.78d0, 0.54d0,
739  + 0.08d0, 0.0d0, 0.0d0, 0.0d0, 0.5d0, 0.0d0,
740  + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.04d0,
741  + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.7d0,
742  + -0.9d0, -0.12d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
743  + 0.64d0, -0.9d0, -0.30d0, 0.7d0, -0.18d0, 0.2d0,
744  + 0.28d0, 0.5d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
745  + 0.0d0, 0.0d0, 0.04d0, 0.0d0, 0.0d0, 0.0d0,
746  + 0.0d0, 0.0d0, 0.0d0, 0.7d0, -1.08d0, 0.0d0,
747  + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.64d0, -1.26d0,
748  + 0.54d0, 0.20d0, 0.0d0, 0.0d0, 0.0d0, 0.5d0,
749  + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
750  + 0.04d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
751  + 0.0d0, 0.04d0, -0.9d0, 0.18d0, 0.0d0, 0.0d0,
752  + 0.0d0, 0.0d0, 0.04d0, -0.9d0, 0.18d0, 0.7d0,
753  + -0.18d0, 0.2d0, 0.16d0/
754  DATA ssize2/0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
755  + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
756  + 0.0d0, 1.17d0, 1.17d0, 1.17d0, 1.17d0, 1.17d0,
757  + 1.17d0, 1.17d0, 1.17d0, 1.17d0, 1.17d0, 1.17d0,
758  + 1.17d0, 1.17d0, 1.17d0/
759 * .. Executable Statements ..
760 *
761  DO 60 ki = 1, 4
762  incx = incxs(ki)
763  incy = incys(ki)
764  mx = abs(incx)
765  my = abs(incy)
766 *
767  DO 40 kn = 1, 4
768  n = ns(kn)
769  ksize = min(2,kn)
770  lenx = lens(kn,mx)
771  leny = lens(kn,my)
772 *
773  IF (icase.EQ.4) THEN
774 * .. DROT ..
775  DO 20 i = 1, 7
776  sx(i) = dx1(i)
777  sy(i) = dy1(i)
778  stx(i) = dt9x(i,kn,ki)
779  sty(i) = dt9y(i,kn,ki)
780  20 CONTINUE
781  CALL drot(n,sx,incx,sy,incy,sc,ss)
782  CALL stest(lenx,sx,stx,ssize2(1,ksize),sfac)
783  CALL stest(leny,sy,sty,ssize2(1,ksize),sfac)
784  ELSE
785  WRITE (nout,*) ' Shouldn''t be here in CHECK3'
786  stop
787  END IF
788  40 CONTINUE
789  60 CONTINUE
790 *
791  mwpc(1) = 1
792  DO 80 i = 2, 11
793  mwpc(i) = 0
794  80 CONTINUE
795  mwps(1) = 0
796  DO 100 i = 2, 6
797  mwps(i) = 1
798  100 CONTINUE
799  DO 120 i = 7, 11
800  mwps(i) = -1
801  120 CONTINUE
802  mwpinx(1) = 1
803  mwpinx(2) = 1
804  mwpinx(3) = 1
805  mwpinx(4) = -1
806  mwpinx(5) = 1
807  mwpinx(6) = -1
808  mwpinx(7) = 1
809  mwpinx(8) = 1
810  mwpinx(9) = -1
811  mwpinx(10) = 1
812  mwpinx(11) = -1
813  mwpiny(1) = 1
814  mwpiny(2) = 1
815  mwpiny(3) = -1
816  mwpiny(4) = -1
817  mwpiny(5) = 2
818  mwpiny(6) = 1
819  mwpiny(7) = 1
820  mwpiny(8) = -1
821  mwpiny(9) = -1
822  mwpiny(10) = 2
823  mwpiny(11) = 1
824  DO 140 i = 1, 11
825  mwpn(i) = 5
826  140 CONTINUE
827  mwpn(5) = 3
828  mwpn(10) = 3
829  DO 160 i = 1, 5
830  mwpx(i) = i
831  mwpy(i) = i
832  mwptx(1,i) = i
833  mwpty(1,i) = i
834  mwptx(2,i) = i
835  mwpty(2,i) = -i
836  mwptx(3,i) = 6 - i
837  mwpty(3,i) = i - 6
838  mwptx(4,i) = i
839  mwpty(4,i) = -i
840  mwptx(6,i) = 6 - i
841  mwpty(6,i) = i - 6
842  mwptx(7,i) = -i
843  mwpty(7,i) = i
844  mwptx(8,i) = i - 6
845  mwpty(8,i) = 6 - i
846  mwptx(9,i) = -i
847  mwpty(9,i) = i
848  mwptx(11,i) = i - 6
849  mwpty(11,i) = 6 - i
850  160 CONTINUE
851  mwptx(5,1) = 1
852  mwptx(5,2) = 3
853  mwptx(5,3) = 5
854  mwptx(5,4) = 4
855  mwptx(5,5) = 5
856  mwpty(5,1) = -1
857  mwpty(5,2) = 2
858  mwpty(5,3) = -2
859  mwpty(5,4) = 4
860  mwpty(5,5) = -3
861  mwptx(10,1) = -1
862  mwptx(10,2) = -3
863  mwptx(10,3) = -5
864  mwptx(10,4) = 4
865  mwptx(10,5) = 5
866  mwpty(10,1) = 1
867  mwpty(10,2) = 2
868  mwpty(10,3) = 2
869  mwpty(10,4) = 4
870  mwpty(10,5) = 3
871  DO 200 i = 1, 11
872  incx = mwpinx(i)
873  incy = mwpiny(i)
874  DO 180 k = 1, 5
875  copyx(k) = mwpx(k)
876  copyy(k) = mwpy(k)
877  mwpstx(k) = mwptx(i,k)
878  mwpsty(k) = mwpty(i,k)
879  180 CONTINUE
880  CALL drot(mwpn(i),copyx,incx,copyy,incy,mwpc(i),mwps(i))
881  CALL stest(5,copyx,mwpstx,mwpstx,sfac)
882  CALL stest(5,copyy,mwpsty,mwpsty,sfac)
883  200 CONTINUE
884  RETURN
drot
subroutine drot(N, DX, INCX, DY, INCY, C, S)
DROT
Definition: drot.f:53
stest
subroutine stest(LEN, SCOMP, STRUE, SSIZE, SFAC)
Definition: cblat1.f:564

Here is the call graph for this function:

Here is the caller graph for this function: