LAPACK  3.8.0
LAPACK: Linear Algebra PACKage

◆ check3()

subroutine check3 ( double precision  SFAC)

Definition at line 682 of file dblat1.f.

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