diff --git a/ctest/c_sblas1.c b/ctest/c_sblas1.c index 1f301a693..1a433b287 100644 --- a/ctest/c_sblas1.c +++ b/ctest/c_sblas1.c @@ -55,6 +55,13 @@ void F77_srotg( float *a, float *b, float *c, float *s) return; } +void F77_srotm(blasint *N, float *X, blasint *incX, float *Y, blasint *incY, + float *param) +{ + cblas_srotm(*N, X, *incX, Y, *incY, param); + return; +} + void F77_srot( blasint *N, float *X, blasint *incX, float *Y, blasint *incY, const float *c, const float *s) { diff --git a/ctest/c_sblat1.f b/ctest/c_sblat1.f index 89902f12d..66a5def89 100644 --- a/ctest/c_sblat1.f +++ b/ctest/c_sblat1.f @@ -19,7 +19,7 @@ DATA SFAC/9.765625E-4/ * .. Executable Statements .. WRITE (NOUT,99999) - DO 20 IC = 1, 10 + DO 20 IC = 1, 11 ICASE = IC CALL HEADER * @@ -40,7 +40,7 @@ ELSE IF (ICASE.EQ.1 .OR. ICASE.EQ.2 .OR. ICASE.EQ.5 .OR. + ICASE.EQ.6) THEN CALL CHECK2(SFAC) - ELSE IF (ICASE.EQ.4) THEN + ELSE IF (ICASE.EQ.4 .OR. ICASE.EQ.11) THEN CALL CHECK3(SFAC) END IF * -- Print @@ -59,7 +59,7 @@ INTEGER ICASE, INCX, INCY, MODE, N LOGICAL PASS * .. Local Arrays .. - CHARACTER*15 L(10) + CHARACTER*15 L(11) * .. Common blocks .. COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS * .. Data statements .. @@ -73,6 +73,7 @@ DATA L(8)/'CBLAS_SASUM '/ DATA L(9)/'CBLAS_SSCAL '/ DATA L(10)/'CBLAS_ISAMAX'/ + DATA L(11)/'CBLAS_SROTM'/ * .. Executable Statements .. WRITE (NOUT,99999) ICASE, L(ICASE) RETURN @@ -396,203 +397,92 @@ * .. Scalar Arguments .. REAL SFAC * .. Scalars in Common .. - INTEGER ICASE, INCX, INCY, MODE, N + INTEGER ICASE, INCX, INCY, N LOGICAL PASS * .. Local Scalars .. REAL SC, SS - INTEGER I, K, KI, KN, KSIZE, LENX, LENY, MX, MY + INTEGER I, K, KI, KN, KSIZE, LEN * .. Local Arrays .. - REAL COPYX(5), COPYY(5), DT9X(7,4,4), DT9Y(7,4,4), - + DX1(7), DY1(7), MWPC(11), MWPS(11), MWPSTX(5), - + MWPSTY(5), MWPTX(11,5), MWPTY(11,5), MWPX(5), - + MWPY(5), SSIZE2(14,2), STX(7), STY(7), SX(7), - + SY(7) - INTEGER INCXS(4), INCYS(4), LENS(4,2), MWPINX(11), - + MWPINY(11), MWPN(11), NS(4) + REAL DX(19), DY(19), + + SSIZE2(19,2), STX(19), STY(19), SX(19), SY(19), + + PARAM(5, 4), SPARAM(5) + INTEGER INCXS(7), INCYS(7), NS(7) * .. External Subroutines .. - EXTERNAL SROTTEST, STEST + EXTERNAL SROTMTEST, SROTM * .. Intrinsic Functions .. - INTRINSIC ABS, MIN + INTRINSIC MIN * .. Common blocks .. COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS * .. Data statements .. - DATA INCXS/1, 2, -2, -1/ - DATA INCYS/1, -2, 1, -2/ - DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/ - DATA NS/0, 1, 2, 4/ - DATA DX1/0.6E0, 0.1E0, -0.5E0, 0.8E0, 0.9E0, -0.3E0, - + -0.4E0/ - DATA DY1/0.5E0, -0.9E0, 0.3E0, 0.7E0, -0.6E0, 0.2E0, + DATA INCXS/1, 1, 2, 2, -2, -1, -2/ + DATA INCYS/1, 2, 2, -2, 1, -2, -2/ + DATA NS/0, 1, 2, 4, 5, 8, 9/ + DATA DX/0.6E0, 0.1E0, -0.5E0, 0.8E0, 0.9E0, -0.3E0, + + -0.4E0, 0.5E0, -0.9E0, 0.3E0, 0.7E0, -0.6E0, + + 0.2E0, 0.8E0, -0.46E0, 0.78E0, -0.46E0, -0.22E0, + + 1.06E0/ + DATA DY/0.5E0, -0.9E0, 0.3E0, 0.7E0, -0.6E0, 0.2E0, + + 0.6E0, 0.1E0, -0.5E0, 0.8E0, 0.9E0, -0.3E0, + + 0.96E0, 0.1E0, -0.76E0, 0.8E0, 0.90E0, 0.66E0, + 0.8E0/ DATA SC, SS/0.8E0, 0.6E0/ - DATA DT9X/0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.78E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.78E0, -0.46E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.78E0, -0.46E0, -0.22E0, - + 1.06E0, 0.0E0, 0.0E0, 0.0E0, 0.6E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.78E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.66E0, 0.1E0, -0.1E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.96E0, 0.1E0, -0.76E0, 0.8E0, 0.90E0, - + -0.3E0, -0.02E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.78E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, -0.06E0, 0.1E0, - + -0.1E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.90E0, - + 0.1E0, -0.22E0, 0.8E0, 0.18E0, -0.3E0, -0.02E0, - + 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.78E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.78E0, 0.26E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.78E0, 0.26E0, -0.76E0, 1.12E0, - + 0.0E0, 0.0E0, 0.0E0/ - DATA DT9Y/0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.04E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.04E0, -0.78E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.04E0, -0.78E0, 0.54E0, - + 0.08E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.04E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.7E0, - + -0.9E0, -0.12E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.64E0, -0.9E0, -0.30E0, 0.7E0, -0.18E0, 0.2E0, - + 0.28E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.04E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.7E0, -1.08E0, 0.0E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.64E0, -1.26E0, - + 0.54E0, 0.20E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, - + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.04E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 0.04E0, -0.9E0, 0.18E0, 0.0E0, 0.0E0, - + 0.0E0, 0.0E0, 0.04E0, -0.9E0, 0.18E0, 0.7E0, - + -0.18E0, 0.2E0, 0.16E0/ + DATA PARAM/-2.0E0, 1.0E0, 0.0E0, 0.0E0, 1.0E0, + + -1.0E0, 0.2E0, 0.3E0, 0.4E0, 0.5E0, + + 0.0E0, 1.0E0, 0.3E0, 0.4E0, 1.0E0, + + 1.0E0, 0.2E0, -1.0E0, 1.0E0, 0.5E0/ + DATA LEN/19/ DATA SSIZE2/0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, - + 0.0E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, + + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, + 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, - + 1.17E0, 1.17E0, 1.17E0/ + + 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, + + 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, + + 1.17E0/ * .. Executable Statements .. * - DO 60 KI = 1, 4 + DO 60 KI = 1, 7 INCX = INCXS(KI) INCY = INCYS(KI) - MX = ABS(INCX) - MY = ABS(INCY) * - DO 40 KN = 1, 4 + DO 40 KN = 1, 7 N = NS(KN) KSIZE = MIN(2,KN) - LENX = LENS(KN,MX) - LENY = LENS(KN,MY) * IF (ICASE.EQ.4) THEN * .. SROTTEST .. - DO 20 I = 1, 7 - SX(I) = DX1(I) - SY(I) = DY1(I) - STX(I) = DT9X(I,KN,KI) - STY(I) = DT9Y(I,KN,KI) + DO 20 I = 1, 19 + SX(I) = DX(I) + SY(I) = DY(I) + STX(I) = DX(I) + STY(I) = DY(I) 20 CONTINUE CALL SROTTEST(N,SX,INCX,SY,INCY,SC,SS) - CALL STEST(LENX,SX,STX,SSIZE2(1,KSIZE),SFAC) - CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC) + CALL SROT(N,STX,INCX,STY,INCY,SC,SS) + CALL STEST(LEN,SX,STX,SSIZE2(1,KSIZE),SFAC) + CALL STEST(LEN,SY,STY,SSIZE2(1,KSIZE),SFAC) + ELSE IF (ICASE.EQ.11) THEN +* .. SROTMTEST .. + DO 90 I = 1, 19 + SX(I) = DX(I) + SY(I) = DY(I) + STX(I) = DX(I) + STY(I) = DY(I) + 90 CONTINUE + DO 70 I = 1, 4 + DO 80 K = 1, 5 + SPARAM(K) = PARAM(K,I) + 80 CONTINUE + CALL SROTMTEST(N,SX,INCX,SY,INCY,SPARAM) + CALL SROTM(N,STX,INCX,STY,INCY,SPARAM) + CALL STEST(LEN,SX,STX,SSIZE2(1,KSIZE),SFAC) + CALL STEST(LEN,SY,STY,SSIZE2(1,KSIZE),SFAC) + 70 CONTINUE ELSE WRITE (NOUT,*) ' Shouldn''t be here in CHECK3' STOP END IF 40 CONTINUE 60 CONTINUE -* - MWPC(1) = 1 - DO 80 I = 2, 11 - MWPC(I) = 0 - 80 CONTINUE - MWPS(1) = 0 - DO 100 I = 2, 6 - MWPS(I) = 1 - 100 CONTINUE - DO 120 I = 7, 11 - MWPS(I) = -1 - 120 CONTINUE - MWPINX(1) = 1 - MWPINX(2) = 1 - MWPINX(3) = 1 - MWPINX(4) = -1 - MWPINX(5) = 1 - MWPINX(6) = -1 - MWPINX(7) = 1 - MWPINX(8) = 1 - MWPINX(9) = -1 - MWPINX(10) = 1 - MWPINX(11) = -1 - MWPINY(1) = 1 - MWPINY(2) = 1 - MWPINY(3) = -1 - MWPINY(4) = -1 - MWPINY(5) = 2 - MWPINY(6) = 1 - MWPINY(7) = 1 - MWPINY(8) = -1 - MWPINY(9) = -1 - MWPINY(10) = 2 - MWPINY(11) = 1 - DO 140 I = 1, 11 - MWPN(I) = 5 - 140 CONTINUE - MWPN(5) = 3 - MWPN(10) = 3 - DO 160 I = 1, 5 - MWPX(I) = I - MWPY(I) = I - MWPTX(1,I) = I - MWPTY(1,I) = I - MWPTX(2,I) = I - MWPTY(2,I) = -I - MWPTX(3,I) = 6 - I - MWPTY(3,I) = I - 6 - MWPTX(4,I) = I - MWPTY(4,I) = -I - MWPTX(6,I) = 6 - I - MWPTY(6,I) = I - 6 - MWPTX(7,I) = -I - MWPTY(7,I) = I - MWPTX(8,I) = I - 6 - MWPTY(8,I) = 6 - I - MWPTX(9,I) = -I - MWPTY(9,I) = I - MWPTX(11,I) = I - 6 - MWPTY(11,I) = 6 - I - 160 CONTINUE - MWPTX(5,1) = 1 - MWPTX(5,2) = 3 - MWPTX(5,3) = 5 - MWPTX(5,4) = 4 - MWPTX(5,5) = 5 - MWPTY(5,1) = -1 - MWPTY(5,2) = 2 - MWPTY(5,3) = -2 - MWPTY(5,4) = 4 - MWPTY(5,5) = -3 - MWPTX(10,1) = -1 - MWPTX(10,2) = -3 - MWPTX(10,3) = -5 - MWPTX(10,4) = 4 - MWPTX(10,5) = 5 - MWPTY(10,1) = 1 - MWPTY(10,2) = 2 - MWPTY(10,3) = 2 - MWPTY(10,4) = 4 - MWPTY(10,5) = 3 - DO 200 I = 1, 11 - INCX = MWPINX(I) - INCY = MWPINY(I) - DO 180 K = 1, 5 - COPYX(K) = MWPX(K) - COPYY(K) = MWPY(K) - MWPSTX(K) = MWPTX(I,K) - MWPSTY(K) = MWPTY(I,K) - 180 CONTINUE - CALL SROTTEST(MWPN(I),COPYX,INCX,COPYY,INCY,MWPC(I),MWPS(I)) - CALL STEST(5,COPYX,MWPSTX,MWPSTX,SFAC) - CALL STEST(5,COPYY,MWPSTY,MWPSTY,SFAC) - 200 CONTINUE RETURN END SUBROUTINE STEST(LEN,SCOMP,STRUE,SSIZE,SFAC) @@ -726,3 +616,147 @@ + /1X) 99997 FORMAT (1X,I4,I3,3I5,2I36,I12) END + SUBROUTINE SROT(N,SX,INCX,SY,INCY,C,S) +* +* --Reference BLAS level1 routine (version 3.8.0) -- +* --Reference BLAS is a software package provided by Univ. of Tennessee, -- +* --Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + REAL C,S + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + REAL SX(*),SY(*) +* .. +* .. Local Scalars .. + REAL STEMP + INTEGER I,IX,IY +* .. + IF (n.LE.0) RETURN + IF (incx.EQ.1 .AND. incy.EQ.1) THEN + DO i = 1,n + stemp = c*sx(i) + s*sy(i) + sy(i) = c*sy(i) - s*sx(i) + sx(i) = stemp + END DO + ELSE + ix = 1 + iy = 1 + IF (incx.LT.0) ix = (-n+1)*incx + 1 + IF (incy.LT.0) iy = (-n+1)*incy + 1 + DO i = 1,n + stemp = c*sx(ix) + s*sy(iy) + sy(iy) = c*sy(iy) - s*sx(ix) + sx(ix) = stemp + ix = ix + incx + iy = iy + incy + END DO + END IF + RETURN + END + SUBROUTINE srotm(N,SX,INCX,SY,INCY,SPARAM) +* +* --Reference BLAS level1 routine (version 3.8.0) -- +* --Reference BLAS is a software package provided by Univ. of Tennessee, -- +* --Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2017 +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + REAL SPARAM(5),SX(*),SY(*) +* .. +* +* ==================================================================== +* +* .. Local Scalars .. + REAL SFLAG,SH11,SH12,SH21,SH22,TWO,W,Z,ZERO + INTEGER I,KX,KY,NSTEPS +* .. +* .. Data statements .. + DATA zero,two/0.e0,2.e0/ +* .. +* + sflag = sparam(1) + IF (n.LE.0 .OR. (sflag+two.EQ.zero)) RETURN + IF (incx.EQ.incy.AND.incx.GT.0) THEN +* + nsteps = n*incx + IF (sflag.LT.zero) THEN + sh11 = sparam(2) + sh12 = sparam(4) + sh21 = sparam(3) + sh22 = sparam(5) + DO i = 1,nsteps,incx + w = sx(i) + z = sy(i) + sx(i) = w*sh11 + z*sh12 + sy(i) = w*sh21 + z*sh22 + END DO + ELSE IF (sflag.EQ.zero) THEN + sh12 = sparam(4) + sh21 = sparam(3) + DO i = 1,nsteps,incx + w = sx(i) + z = sy(i) + sx(i) = w + z*sh12 + sy(i) = w*sh21 + z + END DO + ELSE + sh11 = sparam(2) + sh22 = sparam(5) + DO i = 1,nsteps,incx + w = sx(i) + z = sy(i) + sx(i) = w*sh11 + z + sy(i) = -w + sh22*z + END DO + END IF + ELSE + kx = 1 + ky = 1 + IF (incx.LT.0) kx = 1 + (1-n)*incx + IF (incy.LT.0) ky = 1 + (1-n)*incy +* + IF (sflag.LT.zero) THEN + sh11 = sparam(2) + sh12 = sparam(4) + sh21 = sparam(3) + sh22 = sparam(5) + DO i = 1,n + w = sx(kx) + z = sy(ky) + sx(kx) = w*sh11 + z*sh12 + sy(ky) = w*sh21 + z*sh22 + kx = kx + incx + ky = ky + incy + END DO + ELSE IF (sflag.EQ.zero) THEN + sh12 = sparam(4) + sh21 = sparam(3) + DO i = 1,n + w = sx(kx) + z = sy(ky) + sx(kx) = w + z*sh12 + sy(ky) = w*sh21 + z + kx = kx + incx + ky = ky + incy + END DO + ELSE + sh11 = sparam(2) + sh22 = sparam(5) + DO i = 1,n + w = sx(kx) + z = sy(ky) + sx(kx) = w*sh11 + z + sy(ky) = -w + sh22*z + kx = kx + incx + ky = ky + incy + END DO + END IF + END IF + RETURN + END \ No newline at end of file