LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ check3()

subroutine check3 ( real  SFAC)

Definition at line 685 of file sblat1.f.

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