diff --git a/BLAS/SRC/CMakeLists.txt b/BLAS/SRC/CMakeLists.txt index f41bef6d61..cda6a1e982 100644 --- a/BLAS/SRC/CMakeLists.txt +++ b/BLAS/SRC/CMakeLists.txt @@ -65,7 +65,8 @@ set(ALLBLAS lsame.f xerbla.f xerbla_array.f) #--------------------------------------------------------- set(SBLAS2 sgemv.f sgbmv.f ssymv.f ssbmv.f sspmv.f strmv.f stbmv.f stpmv.f strsv.f stbsv.f stpsv.f - sger.f ssyr.f sspr.f ssyr2.f sspr2.f) + sger.f ssyr.f sspr.f ssyr2.f sspr2.f + sskewsymv.f sskewsyr2.f) set(CBLAS2 cgemv.f cgbmv.f chemv.f chbmv.f chpmv.f ctrmv.f ctbmv.f ctpmv.f ctrsv.f ctbsv.f ctpsv.f @@ -73,7 +74,8 @@ set(CBLAS2 cgemv.f cgbmv.f chemv.f chbmv.f chpmv.f set(DBLAS2 dgemv.f dgbmv.f dsymv.f dsbmv.f dspmv.f dtrmv.f dtbmv.f dtpmv.f dtrsv.f dtbsv.f dtpsv.f - dger.f dsyr.f dspr.f dsyr2.f dspr2.f) + dger.f dsyr.f dspr.f dsyr2.f dspr2.f + dskewsymv.f dskewsyr2.f) set(ZBLAS2 zgemv.f zgbmv.f zhemv.f zhbmv.f zhpmv.f ztrmv.f ztbmv.f ztpmv.f ztrsv.f ztbsv.f ztpsv.f @@ -82,12 +84,14 @@ set(ZBLAS2 zgemv.f zgbmv.f zhemv.f zhbmv.f zhpmv.f #--------------------------------------------------------- # Level 3 BLAS #--------------------------------------------------------- -set(SBLAS3 sgemm.f ssymm.f ssyrk.f ssyr2k.f strmm.f strsm.f sgemmtr.f) +set(SBLAS3 sgemm.f ssymm.f ssyrk.f ssyr2k.f strmm.f strsm.f sgemmtr.f + sskewsymm.f sskewsyr2k.f) set(CBLAS3 cgemm.f csymm.f csyrk.f csyr2k.f ctrmm.f ctrsm.f chemm.f cherk.f cher2k.f cgemmtr.f) -set(DBLAS3 dgemm.f dsymm.f dsyrk.f dsyr2k.f dtrmm.f dtrsm.f dgemmtr.f) +set(DBLAS3 dgemm.f dsymm.f dsyrk.f dsyr2k.f dtrmm.f dtrsm.f dgemmtr.f + dskewsymm.f dskewsyr2k.f) set(ZBLAS3 zgemm.f zsymm.f zsyrk.f zsyr2k.f ztrmm.f ztrsm.f zhemm.f zherk.f zher2k.f zgemmtr.f) diff --git a/BLAS/SRC/Makefile b/BLAS/SRC/Makefile index 486571fec6..6519f4ed6e 100644 --- a/BLAS/SRC/Makefile +++ b/BLAS/SRC/Makefile @@ -105,7 +105,8 @@ $(ALLBLAS): $(FRC) #--------------------------------------------------------- SBLAS2 = sgemv.o sgbmv.o ssymv.o ssbmv.o sspmv.o \ strmv.o stbmv.o stpmv.o strsv.o stbsv.o stpsv.o \ - sger.o ssyr.o sspr.o ssyr2.o sspr2.o + sger.o ssyr.o sspr.o ssyr2.o sspr2.o \ + sskewsymv.o sskewsyr2.o $(SBLAS2): $(FRC) CBLAS2 = cgemv.o cgbmv.o chemv.o chbmv.o chpmv.o \ @@ -115,7 +116,8 @@ $(CBLAS2): $(FRC) DBLAS2 = dgemv.o dgbmv.o dsymv.o dsbmv.o dspmv.o \ dtrmv.o dtbmv.o dtpmv.o dtrsv.o dtbsv.o dtpsv.o \ - dger.o dsyr.o dspr.o dsyr2.o dspr2.o + dger.o dsyr.o dspr.o dsyr2.o dspr2.o \ + dskewsymv.o dskewsyr2.o $(DBLAS2): $(FRC) ZBLAS2 = zgemv.o zgbmv.o zhemv.o zhbmv.o zhpmv.o \ @@ -127,14 +129,16 @@ $(ZBLAS2): $(FRC) # Comment out the next 4 definitions if you already have # the Level 3 BLAS. #--------------------------------------------------------- -SBLAS3 = sgemm.o ssymm.o ssyrk.o ssyr2k.o strmm.o strsm.o sgemmtr.o +SBLAS3 = sgemm.o ssymm.o ssyrk.o ssyr2k.o strmm.o strsm.o sgemmtr.o \ + sskewsymm.o sskewsyr2k.o $(SBLAS3): $(FRC) CBLAS3 = cgemm.o csymm.o csyrk.o csyr2k.o ctrmm.o ctrsm.o \ chemm.o cherk.o cher2k.o cgemmtr.o $(CBLAS3): $(FRC) -DBLAS3 = dgemm.o dsymm.o dsyrk.o dsyr2k.o dtrmm.o dtrsm.o dgemmtr.o +DBLAS3 = dgemm.o dsymm.o dsyrk.o dsyr2k.o dtrmm.o dtrsm.o dgemmtr.o \ + dskewsymm.o dskewsyr2k.o $(DBLAS3): $(FRC) ZBLAS3 = zgemm.o zsymm.o zsyrk.o zsyr2k.o ztrmm.o ztrsm.o \ diff --git a/BLAS/SRC/dskewsymm.f b/BLAS/SRC/dskewsymm.f new file mode 100644 index 0000000000..12d862215f --- /dev/null +++ b/BLAS/SRC/dskewsymm.f @@ -0,0 +1,365 @@ +*> \brief \b DSKEWSYMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSKEWSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER LDA,LDB,LDC,M,N +* CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSKEWSYMM performs one of the matrix-matrix operations +*> +*> C := alpha*A*B + beta*C, +*> +*> or +*> +*> C := alpha*B*A + beta*C, +*> +*> where alpha and beta are scalars, A is a skew-symmetric matrix and B and +*> C are m by n matrices. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether the skew-symmetric matrix A +*> appears on the left or right in the operation as follows: +*> +*> SIDE = 'L' or 'l' C := alpha*A*B + beta*C, +*> +*> SIDE = 'R' or 'r' C := alpha*B*A + beta*C, +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the skew-symmetric matrix A is to be +*> referenced as follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of the +*> skew-symmetric matrix is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of the +*> skew-symmetric matrix is to be referenced. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix C. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix C. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is +*> m when SIDE = 'L' or 'l' and is n otherwise. +*> Before entry with SIDE = 'L' or 'l', the m by m part of +*> the array A must contain the skew-symmetric matrix, such that +*> when UPLO = 'U' or 'u', the strictly m by m upper triangular +*> part of the array A must contain the upper triangular part +*> of the skew-symmetric matrix and the leading lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the strictly m by m lower triangular part of the array A +*> must contain the lower triangular part of the skew-symmetric +*> matrix and the leading upper triangular part of A is not +*> referenced. +*> Before entry with SIDE = 'R' or 'r', the n by n part of +*> the array A must contain the skew-symmetric matrix, such that +*> when UPLO = 'U' or 'u', the strictly n by n upper triangular +*> part of the array A must contain the upper triangular part +*> of the skew-symmetric matrix and the leading lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the strictly n by n lower triangular part of the array A +*> must contain the lower triangular part of the skew-symmetric +*> matrix and the leading upper triangular part of A is not +*> referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When SIDE = 'L' or 'l' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension ( LDB, N ) +*> Before entry, the leading m by n part of the array B must +*> contain the matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. LDB must be at least +*> max( 1, m ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION. +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n updated +*> matrix. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup skewhemm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> Derived from subroutine dsymm. +*> +*> -- Written on 6-Jul-2025. +*> Shuo Zheng, China. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSKEWSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B, + + LDB,BETA,C,LDC) + IMPLICIT NONE +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER LDA,LDB,LDC,M,N + CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP1,TEMP2 + INTEGER I,INFO,J,K,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Set NROWA as the number of rows of A. +* + IF (LSAME(SIDE,'L')) THEN + NROWA = M + ELSE + NROWA = N + END IF + UPPER = LSAME(UPLO,'U') +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.LSAME(SIDE,'L')) .AND. + + (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. + + (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 7 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 9 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 12 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DSKEWSYMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,M + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (LSAME(SIDE,'L')) THEN +* +* Form C := alpha*A*B + beta*C. +* + IF (UPPER) THEN + DO 70 J = 1,N + DO 60 I = 1,M + TEMP1 = ALPHA*B(I,J) + TEMP2 = ZERO + DO 50 K = 1,I - 1 + C(K,J) = C(K,J) + TEMP1*A(K,I) + TEMP2 = TEMP2 - B(K,J)*A(K,I) + 50 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + + + ALPHA*TEMP2 + END IF + 60 CONTINUE + 70 CONTINUE + ELSE + DO 100 J = 1,N + DO 90 I = M,1,-1 + TEMP1 = ALPHA*B(I,J) + TEMP2 = ZERO + DO 80 K = I + 1,M + C(K,J) = C(K,J) + TEMP1*A(K,I) + TEMP2 = TEMP2 - B(K,J)*A(K,I) + 80 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + + + ALPHA*TEMP2 + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* Form C := alpha*B*A + beta*C. +* + DO 170 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 110 I = 1,M + C(I,J) = ZERO + 110 CONTINUE + ELSE + DO 120 I = 1,M + C(I,J) = BETA*C(I,J) + 120 CONTINUE + END IF + DO 140 K = 1,J - 1 + IF (UPPER) THEN + TEMP1 = ALPHA*A(K,J) + ELSE + TEMP1 = -ALPHA*A(J,K) + END IF + DO 130 I = 1,M + C(I,J) = C(I,J) + TEMP1*B(I,K) + 130 CONTINUE + 140 CONTINUE + DO 160 K = J + 1,N + IF (UPPER) THEN + TEMP1 = -ALPHA*A(J,K) + ELSE + TEMP1 = ALPHA*A(K,J) + END IF + DO 150 I = 1,M + C(I,J) = C(I,J) + TEMP1*B(I,K) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + END IF +* + RETURN +* +* End of DSKEWSYMM +* + END diff --git a/BLAS/SRC/dskewsymv.f b/BLAS/SRC/dskewsymv.f new file mode 100644 index 0000000000..2e9cf92f74 --- /dev/null +++ b/BLAS/SRC/dskewsymv.f @@ -0,0 +1,327 @@ +*> \brief \b DSKEWSYMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSKEWSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER INCX,INCY,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSKEWSYMV performs the matrix-vector operation +*> +*> y := alpha*A*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are n element vectors and +*> A is an n by n skew-symmetric matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array A is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of A +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of A +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the strictly n by n +*> upper triangular part of the array A must contain the upper +*> triangular part of the skew-symmetric matrix and the leading +*> lower triangular part of A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the strictly n by n +*> lower triangular part of the array A must contain the lower +*> triangular part of the skew-symmetric matrix and the leading +*> upper triangular part of A is not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION. +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. On exit, Y is overwritten by the updated +*> vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup skewhemv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> Derived from subroutine dsymv. +*> +*> -- Written on 6-Jul-2025. +*> Shuo Zheng, China. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSKEWSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + IMPLICIT NONE +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER INCX,INCY,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 5 + ELSE IF (INCX.EQ.0) THEN + INFO = 7 + ELSE IF (INCY.EQ.0) THEN + INFO = 10 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DSKEWSYMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* Set up the start points in X and Y. +* + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the triangular part +* of A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,N + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,N + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,N + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,N + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + IF (LSAME(UPLO,'U')) THEN +* +* Form y when A is stored in upper triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + DO 50 I = 1,J - 1 + Y(I) = Y(I) + TEMP1*A(I,J) + TEMP2 = TEMP2 - A(I,J)*X(I) + 50 CONTINUE + Y(J) = Y(J) + ALPHA*TEMP2 + 60 CONTINUE + ELSE + JX = KX + JY = KY + DO 80 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + IX = KX + IY = KY + DO 70 I = 1,J - 1 + Y(IY) = Y(IY) + TEMP1*A(I,J) + TEMP2 = TEMP2 - A(I,J)*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + ELSE +* +* Form y when A is stored in lower triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 100 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + DO 90 I = J + 1,N + Y(I) = Y(I) + TEMP1*A(I,J) + TEMP2 = TEMP2 - A(I,J)*X(I) + 90 CONTINUE + Y(J) = Y(J) + ALPHA*TEMP2 + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + IX = JX + IY = JY + DO 110 I = J + 1,N + IX = IX + INCX + IY = IY + INCY + Y(IY) = Y(IY) + TEMP1*A(I,J) + TEMP2 = TEMP2 - A(I,J)*X(IX) + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSKEWSYMV +* + END diff --git a/BLAS/SRC/dskewsyr2.f b/BLAS/SRC/dskewsyr2.f new file mode 100644 index 0000000000..b555fac7a0 --- /dev/null +++ b/BLAS/SRC/dskewsyr2.f @@ -0,0 +1,294 @@ +*> \brief \b DSKEWSYR2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSKEWSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA +* INTEGER INCX,INCY,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSKEWSYR2 performs the skew-symmetric rank 2 operation +*> +*> A := -alpha*x*y**T + alpha*y*x**T + A, +*> +*> where alpha is a scalar, x and y are n element vectors and A is an n +*> by n skew-symmetric matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array A is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of A +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of A +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the strictly n by n +*> upper triangular part of the array A must contain the upper +*> triangular part of the skew-symmetric matrix and the leading +*> lower triangular part of A is not referenced. On exit, the +*> upper triangular part of the array A is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the strictly n by n +*> lower triangular part of the array A must contain the lower +*> triangular part of the skew-symmetric matrix and the leading +*> upper triangular part of A is not referenced. On exit, the +*> lower triangular part of the array A is overwritten by the +*> lower triangular part of the updated matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup skewher2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> Derived from subroutine dsyr2. +*> +*> -- Written on 6-Jul-2025. +*> Shuo Zheng, China. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSKEWSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) + IMPLICIT NONE +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX,INCY,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (INCY.EQ.0) THEN + INFO = 7 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DSKEWSYR2 ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Set up the start points in X and Y if the increments are not both +* unity. +* + IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF + JX = KX + JY = KY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the triangular part +* of A. +* + IF (LSAME(UPLO,'U')) THEN +* +* Form A when A is stored in the upper triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 20 J = 1,N + IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(J) + TEMP2 = ALPHA*X(J) + DO 10 I = 1,J-1 + A(I,J) = A(I,J) - X(I)*TEMP1 + Y(I)*TEMP2 + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + DO 40 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = KX + IY = KY + DO 30 I = 1,J-1 + A(I,J) = A(I,J) - X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 30 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + 40 CONTINUE + END IF + ELSE +* +* Form A when A is stored in the lower triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(J) + TEMP2 = ALPHA*X(J) + DO 50 I = J+1,N + A(I,J) = A(I,J) - X(I)*TEMP1 + Y(I)*TEMP2 + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + DO 80 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = JX + INCX + IY = JY + INCY + DO 70 I = J+1,N + A(I,J) = A(I,J) - X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSKEWSYR2 +* + END diff --git a/BLAS/SRC/dskewsyr2k.f b/BLAS/SRC/dskewsyr2k.f new file mode 100644 index 0000000000..286c1bdd84 --- /dev/null +++ b/BLAS/SRC/dskewsyr2k.f @@ -0,0 +1,395 @@ +*> \brief \b DSKEWSYR2K +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSKEWSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,N +* CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSKEWSYR2K performs one of the skew-symmetric rank 2k operations +*> +*> C := -alpha*A*B**T + alpha*B*A**T + beta*C, +*> +*> or +*> +*> C := -alpha*A**T*B + alpha*B**T*A + beta*C, +*> +*> where alpha and beta are scalars, C is an n by n skew-symmetric matrix +*> and A and B are n by k matrices in the first case and k by n +*> matrices in the second case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array C is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of C +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of C +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' C := -alpha*A*B**T + alpha*B*A**T + +*> beta*C. +*> +*> TRANS = 'T' or 't' C := -alpha*A**T*B + alpha*B**T*A + +*> beta*C. +*> +*> TRANS = 'C' or 'c' C := -alpha*A**T*B + alpha*B**T*A + +*> beta*C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry with TRANS = 'N' or 'n', K specifies the number +*> of columns of the matrices A and B, and on entry with +*> TRANS = 'T' or 't' or 'C' or 'c', K specifies the number +*> of rows of the matrices A and B. K must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is +*> k when TRANS = 'N' or 'n', and is n otherwise. +*> Before entry with TRANS = 'N' or 'n', the leading n by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by n part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANS = 'N' or 'n' +*> then LDA must be at least max( 1, n ), otherwise LDA must +*> be at least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension ( LDB, kb ), where kb is +*> k when TRANS = 'N' or 'n', and is n otherwise. +*> Before entry with TRANS = 'N' or 'n', the leading n by k +*> part of the array B must contain the matrix B, otherwise +*> the leading k by n part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANS = 'N' or 'n' +*> then LDB must be at least max( 1, n ), otherwise LDB must +*> be at least max( 1, k ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION. +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension ( LDC, N ) +*> Before entry with UPLO = 'U' or 'u', the strictly n by n +*> upper triangular part of the array C must contain the upper +*> triangular part of the skew-symmetric matrix and the leading +*> lower triangular part of C is not referenced. On exit, the +*> upper triangular part of the array C is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the strictly n by n +*> lower triangular part of the array C must contain the lower +*> triangular part of the skew-symmetric matrix and the leading +*> upper triangular part of C is not referenced. On exit, the +*> lower triangular part of the array C is overwritten by the +*> lower triangular part of the updated matrix. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup skewher2k +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> Derived from subroutine dsyr2k. +*> +*> -- Written on 6-Jul-2025. +*> Shuo Zheng, China. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSKEWSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B, + + LDB,BETA,C,LDC) + IMPLICIT NONE +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER K,LDA,LDB,LDC,N + CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP1,TEMP2 + INTEGER I,INFO,J,L,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Test the input parameters. +* + IF (LSAME(TRANS,'N')) THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 1 + ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND. + + (.NOT.LSAME(TRANS,'T')) .AND. + + (.NOT.LSAME(TRANS,'C'))) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (K.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 7 + ELSE IF (LDB.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDC.LT.MAX(1,N)) THEN + INFO = 12 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DSKEWSYR2K',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR. + + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (UPPER) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,J-1 + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,J-1 + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE + IF (BETA.EQ.ZERO) THEN + DO 60 J = 1,N + DO 50 I = J+1,N + C(I,J) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80 J = 1,N + DO 70 I = J+1,N + C(I,J) = BETA*C(I,J) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* Start the operations. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form C := alpha*A*B**T + alpha*B*A**T + C. +* + IF (UPPER) THEN + DO 130 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 90 I = 1,J-1 + C(I,J) = ZERO + 90 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 100 I = 1,J-1 + C(I,J) = BETA*C(I,J) + 100 CONTINUE + END IF + DO 120 L = 1,K + IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN + TEMP1 = ALPHA*B(J,L) + TEMP2 = ALPHA*A(J,L) + DO 110 I = 1,J-1 + C(I,J) = C(I,J) - A(I,L)*TEMP1 + + + B(I,L)*TEMP2 + 110 CONTINUE + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 140 I = J+1,N + C(I,J) = ZERO + 140 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 150 I = J+1,N + C(I,J) = BETA*C(I,J) + 150 CONTINUE + END IF + DO 170 L = 1,K + IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN + TEMP1 = ALPHA*B(J,L) + TEMP2 = ALPHA*A(J,L) + DO 160 I = J+1,N + C(I,J) = C(I,J) - A(I,L)*TEMP1 + + + B(I,L)*TEMP2 + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* Form C := alpha*A**T*B + alpha*B**T*A + C. +* + IF (UPPER) THEN + DO 210 J = 1,N + DO 200 I = 1,J-1 + TEMP1 = ZERO + TEMP2 = ZERO + DO 190 L = 1,K + TEMP1 = TEMP1 + A(L,I)*B(L,J) + TEMP2 = TEMP2 + B(L,I)*A(L,J) + 190 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = -ALPHA*TEMP1 + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) - ALPHA*TEMP1 + + + ALPHA*TEMP2 + END IF + 200 CONTINUE + 210 CONTINUE + ELSE + DO 240 J = 1,N + DO 230 I = J+1,N + TEMP1 = ZERO + TEMP2 = ZERO + DO 220 L = 1,K + TEMP1 = TEMP1 + A(L,I)*B(L,J) + TEMP2 = TEMP2 + B(L,I)*A(L,J) + 220 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = -ALPHA*TEMP1 + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) - ALPHA*TEMP1 + + + ALPHA*TEMP2 + END IF + 230 CONTINUE + 240 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSKEWSYR2K +* + END diff --git a/BLAS/SRC/sskewsymm.f b/BLAS/SRC/sskewsymm.f new file mode 100644 index 0000000000..1ecc4b967d --- /dev/null +++ b/BLAS/SRC/sskewsymm.f @@ -0,0 +1,365 @@ +*> \brief \b SSKEWSYMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSKEWSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* REAL ALPHA,BETA +* INTEGER LDA,LDB,LDC,M,N +* CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSKEWSYMM performs one of the matrix-matrix operations +*> +*> C := alpha*A*B + beta*C, +*> +*> or +*> +*> C := alpha*B*A + beta*C, +*> +*> where alpha and beta are scalars, A is a skew-symmetric matrix and B and +*> C are m by n matrices. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether the skew-symmetric matrix A +*> appears on the left or right in the operation as follows: +*> +*> SIDE = 'L' or 'l' C := alpha*A*B + beta*C, +*> +*> SIDE = 'R' or 'r' C := alpha*B*A + beta*C, +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the skew-symmetric matrix A is to be +*> referenced as follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of the +*> skew-symmetric matrix is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of the +*> skew-symmetric matrix is to be referenced. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix C. +*> M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix C. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension ( LDA, ka ), where ka is +*> m when SIDE = 'L' or 'l' and is n otherwise. +*> Before entry with SIDE = 'L' or 'l', the m by m part of +*> the array A must contain the skew-symmetric matrix, such that +*> when UPLO = 'U' or 'u', the strictly m by m upper triangular +*> part of the array A must contain the upper triangular part +*> of the skew-symmetric matrix and the leading lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the strictly m by m lower triangular part of the array A +*> must contain the lower triangular part of the skew-symmetric +*> matrix and the leading upper triangular part of A is not +*> referenced. +*> Before entry with SIDE = 'R' or 'r', the n by n part of +*> the array A must contain the skew-symmetric matrix, such that +*> when UPLO = 'U' or 'u', the strictly n by n upper triangular +*> part of the array A must contain the upper triangular part +*> of the skew-symmetric matrix and the leading lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the strictly n by n lower triangular part of the array A +*> must contain the lower triangular part of the skew-symmetric +*> matrix and the leading upper triangular part of A is not +*> referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When SIDE = 'L' or 'l' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is REAL array, dimension ( LDB, N ) +*> Before entry, the leading m by n part of the array B must +*> contain the matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. LDB must be at least +*> max( 1, m ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is REAL +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is REAL array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n updated +*> matrix. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup skewhemm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> Derived from subroutine ssymm. +*> +*> -- Written on 6-Jul-2025. +*> Shuo Zheng, China. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SSKEWSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B, + + LDB,BETA,C,LDC) + IMPLICIT NONE +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA,BETA + INTEGER LDA,LDB,LDC,M,N + CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + REAL TEMP1,TEMP2 + INTEGER I,INFO,J,K,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* +* Set NROWA as the number of rows of A. +* + IF (LSAME(SIDE,'L')) THEN + NROWA = M + ELSE + NROWA = N + END IF + UPPER = LSAME(UPLO,'U') +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.LSAME(SIDE,'L')) .AND. + + (.NOT.LSAME(SIDE,'R'))) THEN + INFO = 1 + ELSE IF ((.NOT.UPPER) .AND. + + (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 7 + ELSE IF (LDB.LT.MAX(1,M)) THEN + INFO = 9 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 12 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SSKEWSYMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,M + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (LSAME(SIDE,'L')) THEN +* +* Form C := alpha*A*B + beta*C. +* + IF (UPPER) THEN + DO 70 J = 1,N + DO 60 I = 1,M + TEMP1 = ALPHA*B(I,J) + TEMP2 = ZERO + DO 50 K = 1,I - 1 + C(K,J) = C(K,J) + TEMP1*A(K,I) + TEMP2 = TEMP2 - B(K,J)*A(K,I) + 50 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + + + ALPHA*TEMP2 + END IF + 60 CONTINUE + 70 CONTINUE + ELSE + DO 100 J = 1,N + DO 90 I = M,1,-1 + TEMP1 = ALPHA*B(I,J) + TEMP2 = ZERO + DO 80 K = I + 1,M + C(K,J) = C(K,J) + TEMP1*A(K,I) + TEMP2 = TEMP2 - B(K,J)*A(K,I) + 80 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + + + ALPHA*TEMP2 + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* Form C := alpha*B*A + beta*C. +* + DO 170 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 110 I = 1,M + C(I,J) = ZERO + 110 CONTINUE + ELSE + DO 120 I = 1,M + C(I,J) = BETA*C(I,J) + 120 CONTINUE + END IF + DO 140 K = 1,J - 1 + IF (UPPER) THEN + TEMP1 = ALPHA*A(K,J) + ELSE + TEMP1 = -ALPHA*A(J,K) + END IF + DO 130 I = 1,M + C(I,J) = C(I,J) + TEMP1*B(I,K) + 130 CONTINUE + 140 CONTINUE + DO 160 K = J + 1,N + IF (UPPER) THEN + TEMP1 = -ALPHA*A(J,K) + ELSE + TEMP1 = ALPHA*A(K,J) + END IF + DO 150 I = 1,M + C(I,J) = C(I,J) + TEMP1*B(I,K) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + END IF +* + RETURN +* +* End of SSKEWSYMM +* + END diff --git a/BLAS/SRC/sskewsymv.f b/BLAS/SRC/sskewsymv.f new file mode 100644 index 0000000000..564cf1e152 --- /dev/null +++ b/BLAS/SRC/sskewsymv.f @@ -0,0 +1,327 @@ +*> \brief \b SSKEWSYMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSKEWSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* REAL ALPHA,BETA +* INTEGER INCX,INCY,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSKEWSYMV performs the matrix-vector operation +*> +*> y := alpha*A*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are n element vectors and +*> A is an n by n skew-symmetric matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array A is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of A +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of A +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the strictly n by n +*> upper triangular part of the array A must contain the upper +*> triangular part of the skew-symmetric matrix and the leading +*> lower triangular part of A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the strictly n by n +*> lower triangular part of the array A must contain the lower +*> triangular part of the skew-symmetric matrix and the leading +*> upper triangular part of A is not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is REAL +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then Y need not be set on input. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. On exit, Y is overwritten by the updated +*> vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup skewhemv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> Derived from subroutine ssymv. +*> +*> -- Written on 6-Jul-2025. +*> Shuo Zheng, China. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SSKEWSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + IMPLICIT NONE +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA,BETA + INTEGER INCX,INCY,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 5 + ELSE IF (INCX.EQ.0) THEN + INFO = 7 + ELSE IF (INCY.EQ.0) THEN + INFO = 10 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SSKEWSYMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN +* +* Set up the start points in X and Y. +* + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the triangular part +* of A. +* +* First form y := beta*y. +* + IF (BETA.NE.ONE) THEN + IF (INCY.EQ.1) THEN + IF (BETA.EQ.ZERO) THEN + DO 10 I = 1,N + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1,N + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF (BETA.EQ.ZERO) THEN + DO 30 I = 1,N + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1,N + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF (ALPHA.EQ.ZERO) RETURN + IF (LSAME(UPLO,'U')) THEN +* +* Form y when A is stored in upper triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + DO 50 I = 1,J - 1 + Y(I) = Y(I) + TEMP1*A(I,J) + TEMP2 = TEMP2 - A(I,J)*X(I) + 50 CONTINUE + Y(J) = Y(J) + ALPHA*TEMP2 + 60 CONTINUE + ELSE + JX = KX + JY = KY + DO 80 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + IX = KX + IY = KY + DO 70 I = 1,J - 1 + Y(IY) = Y(IY) + TEMP1*A(I,J) + TEMP2 = TEMP2 - A(I,J)*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + ELSE +* +* Form y when A is stored in lower triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 100 J = 1,N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + DO 90 I = J + 1,N + Y(I) = Y(I) + TEMP1*A(I,J) + TEMP2 = TEMP2 - A(I,J)*X(I) + 90 CONTINUE + Y(J) = Y(J) + ALPHA*TEMP2 + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120 J = 1,N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + IX = JX + IY = JY + DO 110 I = J + 1,N + IX = IX + INCX + IY = IY + INCY + Y(IY) = Y(IY) + TEMP1*A(I,J) + TEMP2 = TEMP2 - A(I,J)*X(IX) + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of SSKEWSYMV +* + END diff --git a/BLAS/SRC/sskewsyr2.f b/BLAS/SRC/sskewsyr2.f new file mode 100644 index 0000000000..8d96834caf --- /dev/null +++ b/BLAS/SRC/sskewsyr2.f @@ -0,0 +1,294 @@ +*> \brief \b SSKEWSYR2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSKEWSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* REAL ALPHA +* INTEGER INCX,INCY,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSKEWSYR2 performs the skew-symmetric rank 2 operation +*> +*> A := -alpha*x*y**T + alpha*y*x**T + A, +*> +*> where alpha is a scalar, x and y are n element vectors and A is an n +*> by n skew-symmetric matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array A is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of A +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of A +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix A. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> Before entry, the incremented array X must contain the n +*> element vector x. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> X. INCX must not be zero. +*> \endverbatim +*> +*> \param[in] Y +*> \verbatim +*> Y is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> Before entry, the incremented array Y must contain the n +*> element vector y. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> Y. INCY must not be zero. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension ( LDA, N ) +*> Before entry with UPLO = 'U' or 'u', the strictly n by n +*> upper triangular part of the array A must contain the upper +*> triangular part of the skew-symmetric matrix and the leading +*> lower triangular part of A is not referenced. On exit, the +*> upper triangular part of the array A is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the strictly n by n +*> lower triangular part of the array A must contain the lower +*> triangular part of the skew-symmetric matrix and the leading +*> upper triangular part of A is not referenced. On exit, the +*> lower triangular part of the array A is overwritten by the +*> lower triangular part of the updated matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. LDA must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup skewher2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> Derived from subroutine ssyr2. +*> +*> -- Written on 6-Jul-2025. +*> Shuo Zheng, China. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SSKEWSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) + IMPLICIT NONE +* +* -- Reference BLAS level2 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA + INTEGER INCX,INCY,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER (ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* Test the input parameters. +* + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + ELSE IF (INCY.EQ.0) THEN + INFO = 7 + ELSE IF (LDA.LT.MAX(1,N)) THEN + INFO = 9 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SSKEWSYR2 ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN +* +* Set up the start points in X and Y if the increments are not both +* unity. +* + IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN + IF (INCX.GT.0) THEN + KX = 1 + ELSE + KX = 1 - (N-1)*INCX + END IF + IF (INCY.GT.0) THEN + KY = 1 + ELSE + KY = 1 - (N-1)*INCY + END IF + JX = KX + JY = KY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the triangular part +* of A. +* + IF (LSAME(UPLO,'U')) THEN +* +* Form A when A is stored in the upper triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 20 J = 1,N + IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(J) + TEMP2 = ALPHA*X(J) + DO 10 I = 1,J-1 + A(I,J) = A(I,J) - X(I)*TEMP1 + Y(I)*TEMP2 + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + DO 40 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = KX + IY = KY + DO 30 I = 1,J-1 + A(I,J) = A(I,J) - X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 30 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + 40 CONTINUE + END IF + ELSE +* +* Form A when A is stored in the lower triangle. +* + IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN + DO 60 J = 1,N + IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(J) + TEMP2 = ALPHA*X(J) + DO 50 I = J+1,N + A(I,J) = A(I,J) - X(I)*TEMP1 + Y(I)*TEMP2 + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + DO 80 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = JX + INCX + IY = JY + INCY + DO 70 I = J+1,N + A(I,J) = A(I,J) - X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of SSKEWSYR2 +* + END diff --git a/BLAS/SRC/sskewsyr2k.f b/BLAS/SRC/sskewsyr2k.f new file mode 100644 index 0000000000..58081743fe --- /dev/null +++ b/BLAS/SRC/sskewsyr2k.f @@ -0,0 +1,395 @@ +*> \brief \b SSKEWSYR2K +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSKEWSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* REAL ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,N +* CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSKEWSYR2K performs one of the skew-symmetric rank 2k operations +*> +*> C := -alpha*A*B**T + alpha*B*A**T + beta*C, +*> +*> or +*> +*> C := -alpha*A**T*B + alpha*B**T*A + beta*C, +*> +*> where alpha and beta are scalars, C is an n by n skew-symmetric matrix +*> and A and B are n by k matrices in the first case and k by n +*> matrices in the second case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the array C is to be referenced as +*> follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of C +*> is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of C +*> is to be referenced. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> On entry, TRANS specifies the operation to be performed as +*> follows: +*> +*> TRANS = 'N' or 'n' C := -alpha*A*B**T + alpha*B*A**T + +*> beta*C. +*> +*> TRANS = 'T' or 't' C := -alpha*A**T*B + alpha*B**T*A + +*> beta*C. +*> +*> TRANS = 'C' or 'c' C := -alpha*A**T*B + alpha*B**T*A + +*> beta*C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry with TRANS = 'N' or 'n', K specifies the number +*> of columns of the matrices A and B, and on entry with +*> TRANS = 'T' or 't' or 'C' or 'c', K specifies the number +*> of rows of the matrices A and B. K must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension ( LDA, ka ), where ka is +*> k when TRANS = 'N' or 'n', and is n otherwise. +*> Before entry with TRANS = 'N' or 'n', the leading n by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by n part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANS = 'N' or 'n' +*> then LDA must be at least max( 1, n ), otherwise LDA must +*> be at least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is REAL array, dimension ( LDB, kb ), where kb is +*> k when TRANS = 'N' or 'n', and is n otherwise. +*> Before entry with TRANS = 'N' or 'n', the leading n by k +*> part of the array B must contain the matrix B, otherwise +*> the leading k by n part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANS = 'N' or 'n' +*> then LDB must be at least max( 1, n ), otherwise LDB must +*> be at least max( 1, k ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is REAL +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is REAL array, dimension ( LDC, N ) +*> Before entry with UPLO = 'U' or 'u', the strictly n by n +*> upper triangular part of the array C must contain the upper +*> triangular part of the skew-symmetric matrix and the leading +*> lower triangular part of C is not referenced. On exit, the +*> upper triangular part of the array C is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the strictly n by n +*> lower triangular part of the array C must contain the lower +*> triangular part of the skew-symmetric matrix and the leading +*> upper triangular part of C is not referenced. On exit, the +*> lower triangular part of the array C is overwritten by the +*> lower triangular part of the updated matrix. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, n ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup skewher2k +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> Derived from subroutine ssyr2k. +*> +*> -- Written on 6-Jul-2025. +*> Shuo Zheng, China. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SSKEWSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B, + + LDB,BETA,C,LDC) + IMPLICIT NONE +* +* -- Reference BLAS level3 routine -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + REAL ALPHA,BETA + INTEGER K,LDA,LDB,LDC,N + CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + REAL TEMP1,TEMP2 + INTEGER I,INFO,J,L,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* +* Test the input parameters. +* + IF (LSAME(TRANS,'N')) THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME(UPLO,'U') +* + INFO = 0 + IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN + INFO = 1 + ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND. + + (.NOT.LSAME(TRANS,'T')) .AND. + + (.NOT.LSAME(TRANS,'C'))) THEN + INFO = 2 + ELSE IF (N.LT.0) THEN + INFO = 3 + ELSE IF (K.LT.0) THEN + INFO = 4 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 7 + ELSE IF (LDB.LT.MAX(1,NROWA)) THEN + INFO = 9 + ELSE IF (LDC.LT.MAX(1,N)) THEN + INFO = 12 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SSKEWSYR2K',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR. + + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (UPPER) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,J-1 + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,J-1 + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE + IF (BETA.EQ.ZERO) THEN + DO 60 J = 1,N + DO 50 I = J+1,N + C(I,J) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80 J = 1,N + DO 70 I = J+1,N + C(I,J) = BETA*C(I,J) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* Start the operations. +* + IF (LSAME(TRANS,'N')) THEN +* +* Form C := alpha*A*B**T + alpha*B*A**T + C. +* + IF (UPPER) THEN + DO 130 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 90 I = 1,J-1 + C(I,J) = ZERO + 90 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 100 I = 1,J-1 + C(I,J) = BETA*C(I,J) + 100 CONTINUE + END IF + DO 120 L = 1,K + IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN + TEMP1 = ALPHA*B(J,L) + TEMP2 = ALPHA*A(J,L) + DO 110 I = 1,J-1 + C(I,J) = C(I,J) - A(I,L)*TEMP1 + + + B(I,L)*TEMP2 + 110 CONTINUE + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 140 I = J+1,N + C(I,J) = ZERO + 140 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 150 I = J+1,N + C(I,J) = BETA*C(I,J) + 150 CONTINUE + END IF + DO 170 L = 1,K + IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN + TEMP1 = ALPHA*B(J,L) + TEMP2 = ALPHA*A(J,L) + DO 160 I = J+1,N + C(I,J) = C(I,J) - A(I,L)*TEMP1 + + + B(I,L)*TEMP2 + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* Form C := alpha*A**T*B + alpha*B**T*A + C. +* + IF (UPPER) THEN + DO 210 J = 1,N + DO 200 I = 1,J-1 + TEMP1 = ZERO + TEMP2 = ZERO + DO 190 L = 1,K + TEMP1 = TEMP1 + A(L,I)*B(L,J) + TEMP2 = TEMP2 + B(L,I)*A(L,J) + 190 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = -ALPHA*TEMP1 + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) - ALPHA*TEMP1 + + + ALPHA*TEMP2 + END IF + 200 CONTINUE + 210 CONTINUE + ELSE + DO 240 J = 1,N + DO 230 I = J+1,N + TEMP1 = ZERO + TEMP2 = ZERO + DO 220 L = 1,K + TEMP1 = TEMP1 + A(L,I)*B(L,J) + TEMP2 = TEMP2 + B(L,I)*A(L,J) + 220 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = -ALPHA*TEMP1 + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) - ALPHA*TEMP1 + + + ALPHA*TEMP2 + END IF + 230 CONTINUE + 240 CONTINUE + END IF + END IF +* + RETURN +* +* End of SSKEWSYR2K +* + END diff --git a/BLAS/TESTING/dblat2.f b/BLAS/TESTING/dblat2.f index ae1c8e8dcb..24cf3707ea 100644 --- a/BLAS/TESTING/dblat2.f +++ b/BLAS/TESTING/dblat2.f @@ -20,7 +20,7 @@ *> *> The program must be driven by a short data file. The first 18 records *> of the file are read using list-directed input, the last 16 records -*> are read using the format ( A6, L2 ). An annotated example of a data +*> are read using the format ( A10, L2 ). An annotated example of a data *> file can be obtained by deleting the first 3 characters from the *> following 34 lines: *> 'dblat2.out' NAME OF SUMMARY OUTPUT FILE @@ -57,6 +57,8 @@ *> DSPR T PUT F FOR NO TEST. SAME COLUMNS. *> DSYR2 T PUT F FOR NO TEST. SAME COLUMNS. *> DSPR2 T PUT F FOR NO TEST. SAME COLUMNS. +*> DSKEWSYMV T PUT F FOR NO TEST. SAME COLUMNS. +*> DSKEWSYR T PUT F FOR NO TEST. SAME COLUMNS. *> *> Further Details *> =============== @@ -111,7 +113,7 @@ PROGRAM DBLAT2 INTEGER NIN PARAMETER ( NIN = 5 ) INTEGER NSUBS - PARAMETER ( NSUBS = 16 ) + PARAMETER ( NSUBS = 18 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER NMAX, INCMAX @@ -126,7 +128,7 @@ PROGRAM DBLAT2 LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, $ TSTERR CHARACTER*1 TRANS - CHARACTER*6 SNAMET + CHARACTER*10 SNAMET CHARACTER*32 SNAPS, SUMMRY * .. Local Arrays .. DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), @@ -137,7 +139,7 @@ PROGRAM DBLAT2 $ YY( NMAX*INCMAX ), Z( 2*NMAX ) INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX ) LOGICAL LTEST( NSUBS ) - CHARACTER*6 SNAMES( NSUBS ) + CHARACTER*10 SNAMES( NSUBS ) * .. External Functions .. DOUBLE PRECISION DDIFF LOGICAL LDE @@ -150,15 +152,20 @@ PROGRAM DBLAT2 * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK - CHARACTER*6 SRNAMT + CHARACTER*10 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR COMMON /SRNAMC/SRNAMT * .. Data statements .. - DATA SNAMES/'DGEMV ', 'DGBMV ', 'DSYMV ', 'DSBMV ', - $ 'DSPMV ', 'DTRMV ', 'DTBMV ', 'DTPMV ', - $ 'DTRSV ', 'DTBSV ', 'DTPSV ', 'DGER ', - $ 'DSYR ', 'DSPR ', 'DSYR2 ', 'DSPR2 '/ + DATA SNAMES/'DGEMV ', 'DGBMV ', + $ 'DSYMV ', 'DSBMV ', + $ 'DSPMV ', 'DTRMV ', + $ 'DTBMV ', 'DTPMV ', + $ 'DTRSV ', 'DTBSV ', + $ 'DTPSV ', 'DGER ', + $ 'DSYR ', 'DSPR ', + $ 'DSYR2 ', 'DSPR2 ', + $ 'DSKEWSYMV ', 'DSKEWSYR2 '/ * .. Executable Statements .. * * Read name and unit number for summary output file and open file. @@ -334,14 +341,14 @@ PROGRAM DBLAT2 FATAL = .FALSE. GO TO ( 140, 140, 150, 150, 150, 160, 160, $ 160, 160, 160, 160, 170, 180, 180, - $ 190, 190 )ISNUM + $ 190, 190, 150, 190 )ISNUM * Test DGEMV, 01, and DGBMV, 02. 140 CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, $ X, XX, XS, Y, YY, YS, YT, G ) GO TO 200 -* Test DSYMV, 03, DSBMV, 04, and DSPMV, 05. +* Test DSYMV, 03, DSBMV, 04, DSPMV, 05, and DSKEWSYMV, 17. 150 CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, @@ -365,7 +372,7 @@ PROGRAM DBLAT2 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, $ YT, G, Z ) GO TO 200 -* Test DSYR2, 15, and DSPR2, 16. +* Test DSYR2, 15, DSPR2, 16, and DSKEWSYR2, 18. 190 CALL DCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, @@ -409,15 +416,15 @@ PROGRAM DBLAT2 9988 FORMAT( ' FOR BETA ', 7F6.1 ) 9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', $ /' ******* TESTS ABANDONED *******' ) - 9986 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', + 9986 FORMAT( ' SUBPROGRAM NAME ', A10, ' NOT RECOGNIZED', /' ******* T', $ 'ESTS ABANDONED *******' ) 9985 FORMAT( ' ERROR IN DMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', $ 'ATED WRONGLY.', /' DMVCH WAS CALLED WITH TRANS = ', A1, $ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', / $ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.' $ , /' ******* TESTS ABANDONED *******' ) - 9984 FORMAT( A6, L2 ) - 9983 FORMAT( 1X, A6, ' WAS NOT TESTED' ) + 9984 FORMAT( A10, L2 ) + 9983 FORMAT( 1X, A10, ' WAS NOT TESTED' ) 9982 FORMAT( /' END OF TESTS' ) 9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) @@ -447,7 +454,7 @@ SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, $ NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*10 SNAME * .. Array Arguments .. DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), @@ -776,17 +783,17 @@ SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 140 CONTINUE RETURN * - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A10, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A10, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 4( I3, ',' ), F4.1, + 9996 FORMAT( ' ******* ', A10, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A10, '(''', A1, ''',', 4( I3, ',' ), F4.1, $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1, + 9994 FORMAT( 1X, I6, ': ', A10, '(''', A1, ''',', 2( I3, ',' ), F4.1, $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, $ ') .' ) 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', @@ -801,7 +808,7 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ XS, Y, YY, YS, YT, G ) IMPLICIT NONE * -* Tests DSYMV, DSBMV and DSPMV. +* Tests DSYMV, DSKEWSYMV, DSBMV and DSPMV. * * Auxiliary routine for test program for Level 2 Blas. * @@ -817,7 +824,7 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, $ NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*10 SNAME * .. Array Arguments .. DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), @@ -831,7 +838,8 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY, $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY, $ N, NARGS, NC, NK, NS - LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME + LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME, + $ SKEWFULL CHARACTER*1 UPLO, UPLOS CHARACTER*2 ICH * .. Local Arrays .. @@ -840,7 +848,7 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, LOGICAL LDE, LDERES EXTERNAL LDE, LDERES * .. External Subroutines .. - EXTERNAL DMAKE, DMVCH, DSBMV, DSPMV, DSYMV + EXTERNAL DMAKE, DMVCH, DSBMV, DSPMV, DSYMV, DSKEWSYMV * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. Scalars in Common .. @@ -854,8 +862,9 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, FULL = SNAME( 3: 3 ).EQ.'Y' BANDED = SNAME( 3: 3 ).EQ.'B' PACKED = SNAME( 3: 3 ).EQ.'P' + SKEWFULL = SNAME( 2: 2 ).EQ.'S'.AND.SNAME( 3: 3 ).EQ.'K' * Define the number of arguments. - IF( FULL )THEN + IF( FULL.OR.SKEWFULL )THEN NARGS = 10 ELSE IF( BANDED )THEN NARGS = 11 @@ -972,6 +981,14 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ REWIND NTRA CALL DSYMV( UPLO, N, ALPHA, AA, LDA, XX, $ INCX, BETA, YY, INCY ) + ELSE IF( SKEWFULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, + $ UPLO, N, ALPHA, LDA, INCX, BETA, INCY + IF( REWI ) + $ REWIND NTRA + CALL DSKEWSYMV( UPLO, N, ALPHA, AA, LDA, + $ XX, INCX, BETA, YY, INCY ) ELSE IF( BANDED )THEN IF( TRACE ) $ WRITE( NTRA, FMT = 9994 )NC, SNAME, @@ -1003,7 +1020,7 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * ISAME( 1 ) = UPLO.EQ.UPLOS ISAME( 2 ) = NS.EQ.N - IF( FULL )THEN + IF( FULL.OR.SKEWFULL )THEN ISAME( 3 ) = ALS.EQ.ALPHA ISAME( 4 ) = LDE( AS, AA, LAA ) ISAME( 5 ) = LDAS.EQ.LDA @@ -1118,20 +1135,20 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 130 CONTINUE RETURN * - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A10, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A10, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', AP', + 9996 FORMAT( ' ******* ', A10, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A10, '(''', A1, ''',', I3, ',', F4.1, ', AP', $ ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1, + 9994 FORMAT( 1X, I6, ': ', A10, '(''', A1, ''',', 2( I3, ',' ), F4.1, $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, $ ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', A,', + 9993 FORMAT( 1X, I6, ': ', A10, '(''', A1, ''',', I3, ',', F4.1, ', A,', $ I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) @@ -1159,7 +1176,7 @@ SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DOUBLE PRECISION EPS, THRESH INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*10 SNAME * .. Array Arguments .. DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), @@ -1477,19 +1494,19 @@ SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 130 CONTINUE RETURN * - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A10, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A10, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', AP, ', + 9996 FORMAT( ' ******* ', A10, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A10, '(', 3( '''', A1, ''',' ), I3, ', AP, ', $ 'X,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), 2( I3, ',' ), + 9994 FORMAT( 1X, I6, ': ', A10, '(', 3( '''', A1, ''',' ), 2( I3, ',' ), $ ' A,', I3, ', X,', I2, ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', A,', + 9993 FORMAT( 1X, I6, ': ', A10, '(', 3( '''', A1, ''',' ), I3, ', A,', $ I3, ', X,', I2, ') .' ) 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) @@ -1518,7 +1535,7 @@ SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DOUBLE PRECISION EPS, THRESH INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*10 SNAME * .. Array Arguments .. DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), @@ -1742,16 +1759,16 @@ SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 150 CONTINUE RETURN * - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A10, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A10, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) + 9996 FORMAT( ' ******* ', A10, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( I3, ',' ), F4.1, ', X,', I2, + 9994 FORMAT( 1X, I6, ': ', A10, '(', 2( I3, ',' ), F4.1, ', X,', I2, $ ', Y,', I2, ', A,', I3, ') .' ) 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) @@ -1780,7 +1797,7 @@ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DOUBLE PRECISION EPS, THRESH INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*10 SNAME * .. Array Arguments .. DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), @@ -2019,18 +2036,18 @@ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 130 CONTINUE RETURN * - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A10, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A10, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) + 9996 FORMAT( ' ******* ', A10, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', + 9994 FORMAT( 1X, I6, ': ', A10, '(''', A1, ''',', I3, ',', F4.1, ', X,', $ I2, ', AP) .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', + 9993 FORMAT( 1X, I6, ': ', A10, '(''', A1, ''',', I3, ',', F4.1, ', X,', $ I2, ', A,', I3, ') .' ) 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) @@ -2044,7 +2061,7 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ Z ) IMPLICIT NONE * -* Tests DSYR2 and DSPR2. +* Tests DSYR2, DSKEWSYR2 and DSPR2. * * Auxiliary routine for test program for Level 2 Blas. * @@ -2059,7 +2076,7 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DOUBLE PRECISION EPS, THRESH INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*10 SNAME * .. Array Arguments .. DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), @@ -2072,7 +2089,8 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX, $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N, $ NARGS, NC, NS - LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER + LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER, + $ SKEWFULL CHARACTER*1 UPLO, UPLOS CHARACTER*2 ICH * .. Local Arrays .. @@ -2082,7 +2100,7 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, LOGICAL LDE, LDERES EXTERNAL LDE, LDERES * .. External Subroutines .. - EXTERNAL DMAKE, DMVCH, DSPR2, DSYR2 + EXTERNAL DMAKE, DMVCH, DSPR2, DSYR2, DSKEWSYR2 * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. Scalars in Common .. @@ -2095,8 +2113,9 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * .. Executable Statements .. FULL = SNAME( 3: 3 ).EQ.'Y' PACKED = SNAME( 3: 3 ).EQ.'P' + SKEWFULL = SNAME( 2: 2 ).EQ.'S'.AND.SNAME( 3: 3 ).EQ.'K' * Define the number of arguments. - IF( FULL )THEN + IF( FULL.OR.SKEWFULL )THEN NARGS = 9 ELSE IF( PACKED )THEN NARGS = 8 @@ -2194,6 +2213,14 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ REWIND NTRA CALL DSYR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, $ AA, LDA ) + ELSE IF( SKEWFULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, + $ ALPHA, INCX, INCY, LDA + IF( REWI ) + $ REWIND NTRA + CALL DSKEWSYR2( UPLO, N, ALPHA, XX, INCX, YY, + $ INCY, AA, LDA ) ELSE IF( PACKED )THEN IF( TRACE ) $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, @@ -2266,22 +2293,36 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, Z( I, 2 ) = Y( N - I + 1 ) 80 CONTINUE END IF - JA = 1 + IF( .NOT.SKEWFULL.OR.UPPER )THEN + JA = 1 + ELSE + JA = 2 + END IF DO 90 J = 1, N - W( 1 ) = Z( J, 2 ) + IF( .NOT.SKEWFULL )THEN + W( 1 ) = Z( J, 2 ) + ELSE + W( 1 ) = -Z( J, 2 ) + END IF W( 2 ) = Z( J, 1 ) - IF( UPPER )THEN + IF( .NOT.SKEWFULL.AND.UPPER )THEN JJ = 1 LJ = J - ELSE + ELSE IF( .NOT.SKEWFULL.AND..NOT.UPPER )THEN JJ = J LJ = N - J + 1 + ELSE IF( SKEWFULL.AND.UPPER )THEN + JJ = 1 + LJ = J - 1 + ELSE + JJ = J + 1 + LJ = N - J END IF CALL DMVCH( 'N', LJ, 2, ALPHA, Z( JJ, 1 ), $ NMAX, W, 1, ONE, A( JJ, J ), 1, $ YT, G, AA( JA ), EPS, ERR, FATAL, $ NOUT, .TRUE. ) - IF( FULL )THEN + IF( FULL.OR.SKEWFULL )THEN IF( UPPER )THEN JA = JA + LDA ELSE @@ -2325,7 +2366,7 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * 160 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN + IF( FULL.OR.SKEWFULL )THEN WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, $ INCY, LDA ELSE IF( PACKED )THEN @@ -2335,18 +2376,18 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 170 CONTINUE RETURN * - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A10, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A10, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) + 9996 FORMAT( ' ******* ', A10, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', + 9994 FORMAT( 1X, I6, ': ', A10, '(''', A1, ''',', I3, ',', F4.1, ', X,', $ I2, ', Y,', I2, ', AP) .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', + 9993 FORMAT( 1X, I6, ': ', A10, '(''', A1, ''',', I3, ',', F4.1, ', X,', $ I2, ', Y,', I2, ', A,', I3, ') .' ) 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) @@ -2369,7 +2410,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) * * .. Scalar Arguments .. INTEGER ISNUM, NOUT - CHARACTER*6 SRNAMT + CHARACTER*10 SRNAMT * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK @@ -2392,7 +2433,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) LERR = .FALSE. GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, $ 90, 100, 110, 120, 130, 140, 150, - $ 160 )ISNUM + $ 160, 170, 180 )ISNUM 10 INFOT = 1 CALL DGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2411,7 +2452,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 11 CALL DGEMV( 'N', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 20 INFOT = 1 CALL DGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2436,7 +2477,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 13 CALL DGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 30 INFOT = 1 CALL DSYMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2452,7 +2493,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 10 CALL DSYMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 40 INFOT = 1 CALL DSBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2471,7 +2512,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 11 CALL DSBMV( 'U', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 50 INFOT = 1 CALL DSPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2484,7 +2525,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 9 CALL DSPMV( 'U', 0, ALPHA, A, X, 1, BETA, Y, 0 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 60 INFOT = 1 CALL DTRMV( '/', 'N', 'N', 0, A, 1, X, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2503,7 +2544,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 8 CALL DTRMV( 'U', 'N', 'N', 0, A, 1, X, 0 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 70 INFOT = 1 CALL DTBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2525,7 +2566,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 9 CALL DTBMV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 80 INFOT = 1 CALL DTPMV( '/', 'N', 'N', 0, A, X, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2541,7 +2582,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 7 CALL DTPMV( 'U', 'N', 'N', 0, A, X, 0 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 90 INFOT = 1 CALL DTRSV( '/', 'N', 'N', 0, A, 1, X, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2560,7 +2601,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 8 CALL DTRSV( 'U', 'N', 'N', 0, A, 1, X, 0 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 100 INFOT = 1 CALL DTBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2582,7 +2623,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 9 CALL DTBSV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 110 INFOT = 1 CALL DTPSV( '/', 'N', 'N', 0, A, X, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2598,7 +2639,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 7 CALL DTPSV( 'U', 'N', 'N', 0, A, X, 0 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 120 INFOT = 1 CALL DGER( -1, 0, ALPHA, X, 1, Y, 1, A, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2614,7 +2655,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 9 CALL DGER( 2, 0, ALPHA, X, 1, Y, 1, A, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 130 INFOT = 1 CALL DSYR( '/', 0, ALPHA, X, 1, A, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2627,7 +2668,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 7 CALL DSYR( 'U', 2, ALPHA, X, 1, A, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 140 INFOT = 1 CALL DSPR( '/', 0, ALPHA, X, 1, A ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2637,7 +2678,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 5 CALL DSPR( 'U', 0, ALPHA, X, 0, A ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 150 INFOT = 1 CALL DSYR2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2653,7 +2694,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 9 CALL DSYR2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 160 INFOT = 1 CALL DSPR2( '/', 0, ALPHA, X, 1, Y, 1, A ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2666,16 +2707,48 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 7 CALL DSPR2( 'U', 0, ALPHA, X, 1, Y, 0, A ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + GO TO 190 + 170 INFOT = 1 + CALL DSKEWSYMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSKEWSYMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSKEWSYMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSKEWSYMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSKEWSYMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + GO TO 190 + 180 INFOT = 1 + CALL DSKEWSYR2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSKEWSYR2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSKEWSYR2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSKEWSYR2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSKEWSYR2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * - 170 IF( OK )THEN + 190 IF( OK )THEN WRITE( NOUT, FMT = 9999 )SRNAMT ELSE WRITE( NOUT, FMT = 9998 )SRNAMT END IF RETURN * - 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) - 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', + 9999 FORMAT( ' ', A10, ' PASSED THE TESTS OF ERROR-EXITS' ) + 9998 FORMAT( ' ******* ', A10, ' FAILED THE TESTS OF ERROR-EXITS *****', $ '**' ) * * End of DCHKE @@ -2690,7 +2763,7 @@ SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, * Stores the values in the array AA in the data structure required * by the routine, with unwanted elements set to rogue value. * -* TYPE is 'GE', 'GB', 'SY', 'SB', 'SP', 'TR', 'TB' OR 'TP'. +* TYPE is 'GE', 'GB', 'SY', 'SB', 'SP', 'SK', 'TR', 'TB' OR 'TP'. * * Auxiliary routine for test program for Level 2 Blas. * @@ -2713,7 +2786,8 @@ SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, DOUBLE PRECISION A( NMAX, * ), AA( * ) * .. Local Scalars .. INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, KK - LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER + LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER, + $ SKEW * .. External Functions .. DOUBLE PRECISION DBEG EXTERNAL DBEG @@ -2721,10 +2795,11 @@ SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, INTRINSIC MAX, MIN * .. Executable Statements .. GEN = TYPE( 1: 1 ).EQ.'G' - SYM = TYPE( 1: 1 ).EQ.'S' + SYM = TYPE( 1: 1 ).EQ.'S'.AND.TYPE( 2: 2 ).NE.'K' + SKEW = TYPE( 1: 1 ).EQ.'S'.AND.TYPE( 2: 2 ).EQ.'K' TRI = TYPE( 1: 1 ).EQ.'T' - UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' - LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' + UPPER = ( SYM.OR.SKEW.OR.TRI ).AND.UPLO.EQ.'U' + LOWER = ( SYM.OR.SKEW.OR.TRI ).AND.UPLO.EQ.'L' UNIT = TRI.AND.DIAG.EQ.'U' * * Generate data in array A. @@ -2742,6 +2817,8 @@ SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, IF( I.NE.J )THEN IF( SYM )THEN A( J, I ) = A( I, J ) + ELSE IF( SKEW )THEN + A( J, I ) = -A( I, J ) ELSE IF( TRI )THEN A( J, I ) = ZERO END IF @@ -2752,6 +2829,8 @@ SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, $ A( J, J ) = A( J, J ) + ONE IF( UNIT ) $ A( J, J ) = ONE + IF( SKEW ) + $ A( J, J ) = ZERO 20 CONTINUE * * Store elements in array AS in data structure required by routine. @@ -2777,17 +2856,17 @@ SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, AA( I3 + ( J - 1 )*LDA ) = ROGUE 80 CONTINUE 90 CONTINUE - ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN + ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'SK'.OR.TYPE.EQ.'TR' )THEN DO 130 J = 1, N IF( UPPER )THEN IBEG = 1 - IF( UNIT )THEN + IF( UNIT.OR.SKEW )THEN IEND = J - 1 ELSE IEND = J END IF ELSE - IF( UNIT )THEN + IF( UNIT.OR.SKEW )THEN IBEG = J + 1 ELSE IBEG = J @@ -3012,7 +3091,7 @@ LOGICAL FUNCTION LDERES( TYPE, UPLO, M, N, AA, AS, LDA ) * * Tests if selected elements in two arrays are equal. * -* TYPE is 'GE', 'SY' or 'SP'. +* TYPE is 'GE', 'SY', 'SK' or 'SP'. * * Auxiliary routine for test program for Level 2 Blas. * @@ -3038,14 +3117,20 @@ LOGICAL FUNCTION LDERES( TYPE, UPLO, M, N, AA, AS, LDA ) $ GO TO 70 10 CONTINUE 20 CONTINUE - ELSE IF( TYPE.EQ.'SY' )THEN + ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'SK' )THEN DO 50 J = 1, N - IF( UPPER )THEN + IF( UPPER.AND.TYPE.EQ.'SY' )THEN IBEG = 1 IEND = J - ELSE + ELSE IF( .NOT.UPPER.AND.TYPE.EQ.'SY' )THEN IBEG = J IEND = N + ELSE IF( UPPER.AND.TYPE.EQ.'SK' )THEN + IBEG = 1 + IEND = J - 1 + ELSE + IBEG = J + 1 + IEND = N END IF DO 30 I = 1, IBEG - 1 IF( AA( I, J ).NE.AS( I, J ) ) @@ -3145,7 +3230,7 @@ SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * .. Scalar Arguments .. INTEGER INFOT, NOUT LOGICAL LERR, OK - CHARACTER*6 SRNAMT + CHARACTER*10 SRNAMT * .. Executable Statements .. IF( .NOT.LERR )THEN WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT @@ -3155,7 +3240,7 @@ SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) RETURN * 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', - $ 'ETECTED BY ', A6, ' *****' ) + $ 'ETECTED BY ', A10, ' *****' ) * * End of CHKXER * @@ -3214,14 +3299,16 @@ SUBROUTINE XERBLA( SRNAME, INFO ) * * .. Scalar Arguments .. INTEGER INFO - CHARACTER*6 SRNAME + CHARACTER*10 SRNAME * .. Scalars in Common .. INTEGER INFOT, NOUT LOGICAL LERR, OK - CHARACTER*6 SRNAMT + CHARACTER*10 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUT, OK, LERR COMMON /SRNAMC/SRNAMT +* .. Locals .. + INTEGER SRLEN * .. Executable Statements .. LERR = .TRUE. IF( INFO.NE.INFOT )THEN @@ -3232,7 +3319,8 @@ SUBROUTINE XERBLA( SRNAME, INFO ) END IF OK = .FALSE. END IF - IF( SRNAME.NE.SRNAMT )THEN + SRLEN = MIN(LEN_TRIM(SRNAME), LEN_TRIM(SRNAMT)) + IF( SRNAME(1:SRLEN).NE.SRNAMT(1:SRLEN) )THEN WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT OK = .FALSE. END IF @@ -3240,8 +3328,8 @@ SUBROUTINE XERBLA( SRNAME, INFO ) * 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', $ ' OF ', I2, ' *******' ) - 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', - $ 'AD OF ', A6, ' *******' ) + 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A10, ' INSTE', + $ 'AD OF ', A10, ' *******' ) 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, $ ' *******' ) * diff --git a/BLAS/TESTING/dblat2.in b/BLAS/TESTING/dblat2.in index d436350a4f..6293cf6795 100644 --- a/BLAS/TESTING/dblat2.in +++ b/BLAS/TESTING/dblat2.in @@ -16,19 +16,21 @@ T LOGICAL FLAG, T TO TEST ERROR EXITS. 0.0 1.0 0.7 VALUES OF ALPHA 3 NUMBER OF VALUES OF BETA 0.0 1.0 0.9 VALUES OF BETA -DGEMV T PUT F FOR NO TEST. SAME COLUMNS. -DGBMV T PUT F FOR NO TEST. SAME COLUMNS. -DSYMV T PUT F FOR NO TEST. SAME COLUMNS. -DSBMV T PUT F FOR NO TEST. SAME COLUMNS. -DSPMV T PUT F FOR NO TEST. SAME COLUMNS. -DTRMV T PUT F FOR NO TEST. SAME COLUMNS. -DTBMV T PUT F FOR NO TEST. SAME COLUMNS. -DTPMV T PUT F FOR NO TEST. SAME COLUMNS. -DTRSV T PUT F FOR NO TEST. SAME COLUMNS. -DTBSV T PUT F FOR NO TEST. SAME COLUMNS. -DTPSV T PUT F FOR NO TEST. SAME COLUMNS. -DGER T PUT F FOR NO TEST. SAME COLUMNS. -DSYR T PUT F FOR NO TEST. SAME COLUMNS. -DSPR T PUT F FOR NO TEST. SAME COLUMNS. -DSYR2 T PUT F FOR NO TEST. SAME COLUMNS. -DSPR2 T PUT F FOR NO TEST. SAME COLUMNS. +DGEMV T PUT F FOR NO TEST. SAME COLUMNS. +DGBMV T PUT F FOR NO TEST. SAME COLUMNS. +DSYMV T PUT F FOR NO TEST. SAME COLUMNS. +DSBMV T PUT F FOR NO TEST. SAME COLUMNS. +DSPMV T PUT F FOR NO TEST. SAME COLUMNS. +DTRMV T PUT F FOR NO TEST. SAME COLUMNS. +DTBMV T PUT F FOR NO TEST. SAME COLUMNS. +DTPMV T PUT F FOR NO TEST. SAME COLUMNS. +DTRSV T PUT F FOR NO TEST. SAME COLUMNS. +DTBSV T PUT F FOR NO TEST. SAME COLUMNS. +DTPSV T PUT F FOR NO TEST. SAME COLUMNS. +DGER T PUT F FOR NO TEST. SAME COLUMNS. +DSYR T PUT F FOR NO TEST. SAME COLUMNS. +DSPR T PUT F FOR NO TEST. SAME COLUMNS. +DSYR2 T PUT F FOR NO TEST. SAME COLUMNS. +DSPR2 T PUT F FOR NO TEST. SAME COLUMNS. +DSKEWSYMV T PUT F FOR NO TEST. SAME COLUMNS. +DSKEWSYR2 T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/BLAS/TESTING/dblat3.f b/BLAS/TESTING/dblat3.f index 281c428f47..8fd942fd08 100644 --- a/BLAS/TESTING/dblat3.f +++ b/BLAS/TESTING/dblat3.f @@ -19,8 +19,8 @@ *> Test program for the DOUBLE PRECISION Level 3 Blas. *> *> The program must be driven by a short data file. The first 14 records -*> of the file are read using list-directed input, the last 7 records -*> are read using the format ( A7, L2 ). An annotated example of a data +*> of the file are read using list-directed input, the last 9 records +*> are read using the format ( A11, L2 ). An annotated example of a data *> file can be obtained by deleting the first 3 characters from the *> following 21 lines: *> 'dblat3.out' NAME OF SUMMARY OUTPUT FILE @@ -44,6 +44,8 @@ *> DSYRK T PUT F FOR NO TEST. SAME COLUMNS. *> DSYR2K T PUT F FOR NO TEST. SAME COLUMNS. *> DGEMMTR T PUT F FOR NO TEST. SAME COLUMNS. +*> DSKEWSYMM T PUT F FOR NO TEST. SAME COLUMNS. +*> DSKEWSYR2K T PUT F FOR NO TEST. SAME COLUMNS. *> *> Further Details *> =============== @@ -92,7 +94,7 @@ PROGRAM DBLAT3 INTEGER NIN PARAMETER ( NIN = 5 ) INTEGER NSUBS - PARAMETER ( NSUBS = 7 ) + PARAMETER ( NSUBS = 9 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER NMAX @@ -105,7 +107,7 @@ PROGRAM DBLAT3 LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, $ TSTERR CHARACTER*1 TRANSA, TRANSB - CHARACTER*7 SNAMET + CHARACTER*11 SNAMET CHARACTER*32 SNAPS, SUMMRY * .. Local Arrays .. DOUBLE PRECISION AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), @@ -116,7 +118,7 @@ PROGRAM DBLAT3 $ G( NMAX ), W( 2*NMAX ) INTEGER IDIM( NIDMAX ) LOGICAL LTEST( NSUBS ) - CHARACTER*7 SNAMES( NSUBS ) + CHARACTER*11 SNAMES( NSUBS ) * .. External Functions .. DOUBLE PRECISION DDIFF LOGICAL LDE @@ -129,13 +131,16 @@ PROGRAM DBLAT3 * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK - CHARACTER*7 SRNAMT + CHARACTER*11 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR COMMON /SRNAMC/SRNAMT * .. Data statements .. - DATA SNAMES/'DGEMM ', 'DSYMM ', 'DTRMM ', 'DTRSM ', - $ 'DSYRK ', 'DSYR2K', 'DGEMMTR'/ + DATA SNAMES/'DGEMM ', 'DSYMM ', + $ 'DTRMM ', 'DTRSM ', + $ 'DSYRK ', 'DSYR2K ', + $ 'DGEMMTR ', + $ 'DSKEWSYMM ', 'DSKEWSYR2K '/ * .. Executable Statements .. * * Read name and unit number for summary output file and open file. @@ -312,14 +317,14 @@ PROGRAM DBLAT3 INFOT = 0 OK = .TRUE. FATAL = .FALSE. - GO TO ( 140, 150, 160, 160, 170, 180, 185 )ISNUM + GO TO ( 140, 150, 160, 160, 170, 180, 185, 150, 180 )ISNUM * Test DGEMM, 01. 140 CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, $ CC, CS, CT, G ) GO TO 190 -* Test DSYMM, 02. +* Test SSYMM, 02, DSKEWSYMM, 07. 150 CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, @@ -336,7 +341,7 @@ PROGRAM DBLAT3 $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, $ CC, CS, CT, G ) GO TO 190 -* Test DSYR2K, 06. +* Test SSYR2K, 06, DSKEWSYR2K, 08. 180 CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) @@ -381,7 +386,7 @@ PROGRAM DBLAT3 9992 FORMAT( ' FOR BETA ', 7F6.1 ) 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', $ /' ******* TESTS ABANDONED *******' ) - 9990 FORMAT( ' SUBPROGRAM NAME ', A7, ' NOT RECOGNIZED', /' ******* T', + 9990 FORMAT( ' SUBPROGRAM NAME ', A11, ' NOT RECOGNIZED', /' ******* T', $ 'ESTS ABANDONED *******' ) 9989 FORMAT( ' ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', $ 'ATED WRONGLY.', /' DMMCH WAS CALLED WITH TRANSA = ', A1, @@ -389,8 +394,8 @@ PROGRAM DBLAT3 $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ', $ '*******' ) - 9988 FORMAT( A7, L2 ) - 9987 FORMAT( 1X, A7, ' WAS NOT TESTED' ) + 9988 FORMAT( A11, L2 ) + 9987 FORMAT( 1X, A11, ' WAS NOT TESTED' ) 9986 FORMAT( /' END OF TESTS' ) 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) @@ -420,7 +425,7 @@ SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DOUBLE PRECISION EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*7 SNAME + CHARACTER*11 SNAME * .. Array Arguments .. DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -663,15 +668,15 @@ SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 130 CONTINUE RETURN * - 9999 FORMAT( ' ', A7, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A11, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A7, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A11, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A7, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A7, '(''', A1, ''',''', A1, ''',', + 9996 FORMAT( ' ******* ', A11, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A11, '(''', A1, ''',''', A1, ''',', $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', $ 'C,', I3, ').' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', @@ -702,7 +707,7 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DOUBLE PRECISION EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*7 SNAME + CHARACTER*11 SNAME * .. Array Arguments .. DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -715,7 +720,7 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC, $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA, $ NARGS, NC, NS - LOGICAL LEFT, NULL, RESET, SAME + LOGICAL LEFT, NULL, RESET, SAME, SKEWFULL CHARACTER*1 SIDE, SIDES, UPLO, UPLOS CHARACTER*2 ICHS, ICHU * .. Local Arrays .. @@ -724,7 +729,7 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, LOGICAL LDE, LDERES EXTERNAL LDE, LDERES * .. External Subroutines .. - EXTERNAL DMAKE, DMMCH, DSYMM + EXTERNAL DMAKE, DMMCH, DSYMM, DSKEWSYMM * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. @@ -736,6 +741,7 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DATA ICHS/'LR'/, ICHU/'UL'/ * .. Executable Statements .. * + SKEWFULL = SNAME( 2: 2 ).EQ.'S'.AND.SNAME( 3: 3 ).EQ.'K' NARGS = 12 NC = 0 RESET = .TRUE. @@ -793,8 +799,13 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * * Generate the symmetric matrix A. * - CALL DMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, LDA, - $ RESET, ZERO ) + IF(.NOT.SKEWFULL) THEN + CALL DMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, + $ LDA, RESET, ZERO ) + ELSE + CALL DMAKE( 'SK', UPLO, ' ', NA, NA, A, NMAX, AA, + $ LDA, RESET, ZERO ) + END IF * DO 60 IA = 1, NALF ALPHA = ALF( IA ) @@ -838,8 +849,13 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC IF( REWI ) $ REWIND NTRA - CALL DSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, - $ BB, LDB, BETA, CC, LDC ) + IF(.NOT.SKEWFULL) THEN + CALL DSYMM( SIDE, UPLO, M, N, ALPHA, AA, + $ LDA, BB, LDB, BETA, CC, LDC ) + ELSE + CALL DSKEWSYMM( SIDE, UPLO, M, N, ALPHA, AA, + $ LDA, BB, LDB, BETA, CC, LDC ) + END IF * * Check if error-exit was taken incorrectly. * @@ -934,15 +950,15 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 120 CONTINUE RETURN * - 9999 FORMAT( ' ', A7, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A11, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A7, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A11, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A7, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A7, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), + 9996 FORMAT( ' ******* ', A11, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A11, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', $ ' .' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', @@ -973,7 +989,7 @@ SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DOUBLE PRECISION EPS, THRESH INTEGER NALF, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*7 SNAME + CHARACTER*11 SNAME * .. Array Arguments .. DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -1241,15 +1257,15 @@ SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 160 CONTINUE RETURN * - 9999 FORMAT( ' ', A7, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A11, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A7, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A11, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A7, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A7, '(', 4( '''', A1, ''',' ), 2( I3, ',' ), + 9996 FORMAT( ' ******* ', A11, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A11, '(', 4( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ', B,', I3, ') .' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) @@ -1279,7 +1295,7 @@ SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DOUBLE PRECISION EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*7 SNAME + CHARACTER*11 SNAME * .. Array Arguments .. DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -1516,16 +1532,16 @@ SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 130 CONTINUE RETURN * - 9999 FORMAT( ' ', A7, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A11, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A7, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A11, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A7, ' FAILED ON CALL NUMBER:' ) + 9996 FORMAT( ' ******* ', A11, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A7, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), + 9994 FORMAT( 1X, I6, ': ', A11, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' ) 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) @@ -1555,7 +1571,7 @@ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DOUBLE PRECISION EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*7 SNAME + CHARACTER*11 SNAME * .. Array Arguments .. DOUBLE PRECISION AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), @@ -1568,7 +1584,7 @@ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS - LOGICAL NULL, RESET, SAME, TRAN, UPPER + LOGICAL NULL, RESET, SAME, TRAN, UPPER, SKEWFULL CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS CHARACTER*2 ICHU CHARACTER*3 ICHT @@ -1578,7 +1594,7 @@ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, LOGICAL LDE, LDERES EXTERNAL LDE, LDERES * .. External Subroutines .. - EXTERNAL DMAKE, DMMCH, DSYR2K + EXTERNAL DMAKE, DMMCH, DSYR2K, DSKEWSYR2K * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. @@ -1590,6 +1606,7 @@ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DATA ICHT/'NTC'/, ICHU/'UL'/ * .. Executable Statements .. * + SKEWFULL = SNAME( 2: 2 ).EQ.'S'.AND.SNAME( 3: 3 ).EQ.'K' NARGS = 12 NC = 0 RESET = .TRUE. @@ -1663,8 +1680,13 @@ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * * Generate the matrix C. * - CALL DMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC, - $ LDC, RESET, ZERO ) + IF(.NOT.SKEWFULL) THEN + CALL DMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, + $ CC, LDC, RESET, ZERO ) + ELSE + CALL DMAKE( 'SK', UPLO, ' ', N, N, C, NMAX, + $ CC, LDC, RESET, ZERO ) + END IF * NC = NC + 1 * @@ -1696,8 +1718,14 @@ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC IF( REWI ) $ REWIND NTRA - CALL DSYR2K( UPLO, TRANS, N, K, ALPHA, AA, LDA, - $ BB, LDB, BETA, CC, LDC ) + IF(.NOT.SKEWFULL) THEN + CALL DSYR2K( UPLO, TRANS, N, K, ALPHA, AA, + $ LDA, BB, LDB, BETA, CC, LDC ) + ELSE + CALL DSKEWSYR2K( UPLO, TRANS, N, K, ALPHA, + $ AA, LDA, BB, LDB, BETA, CC, + $ LDC ) + END IF * * Check if error-exit was taken incorrectly. * @@ -1722,8 +1750,13 @@ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, IF( NULL )THEN ISAME( 11 ) = LDE( CS, CC, LCC ) ELSE - ISAME( 11 ) = LDERES( 'SY', UPLO, N, N, CS, - $ CC, LDC ) + IF(.NOT.SKEWFULL) THEN + ISAME( 11 ) = LDERES( 'SY', UPLO, N, N, + $ CS, CC, LDC ) + ELSE + ISAME( 11 ) = LDERES( 'SK', UPLO, N, N, + $ CS, CC, LDC ) + END IF END IF ISAME( 12 ) = LDCS.EQ.LDC * @@ -1745,20 +1778,37 @@ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * * Check the result column by column. * + IF( .NOT.SKEWFULL.OR.UPPER )THEN JJAB = 1 JC = 1 + ELSE + JJAB = 1 + 2*NMAX + JC = 2 + END IF DO 70 J = 1, N - IF( UPPER )THEN + IF( .NOT.SKEWFULL.AND.UPPER )THEN JJ = 1 LJ = J - ELSE + ELSE IF( .NOT.SKEWFULL.AND..NOT.UPPER ) + $ THEN JJ = J LJ = N - J + 1 + ELSE IF( SKEWFULL.AND.UPPER )THEN + JJ = 1 + LJ = J - 1 + ELSE + JJ = J + 1 + LJ = N - J END IF IF( TRAN )THEN DO 50 I = 1, K - W( I ) = AB( ( J - 1 )*2*NMAX + K + - $ I ) + IF(.NOT.SKEWFULL) THEN + W( I ) = AB( ( J - 1 )*2*NMAX + $ + K + I ) + ELSE + W( I ) = -AB( ( J - 1 )*2*NMAX + $ + K + I ) + END IF W( K + I ) = AB( ( J - 1 )*2*NMAX + $ I ) 50 CONTINUE @@ -1770,8 +1820,13 @@ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NOUT, .TRUE. ) ELSE DO 60 I = 1, K - W( I ) = AB( ( K + I - 1 )*NMAX + - $ J ) + IF(.NOT.SKEWFULL) THEN + W( I ) = AB( ( K + I - 1 )*NMAX + $ + J ) + ELSE + W( I ) = -AB( ( K + I - 1 )*NMAX + $ + J ) + END IF W( K + I ) = AB( ( I - 1 )*NMAX + $ J ) 60 CONTINUE @@ -1830,16 +1885,16 @@ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 160 CONTINUE RETURN * - 9999 FORMAT( ' ', A7, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A11, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A7, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A11, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A7, ' FAILED ON CALL NUMBER:' ) + 9996 FORMAT( ' ******* ', A11, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A7, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), + 9994 FORMAT( 1X, I6, ': ', A11, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', $ ' .' ) 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', @@ -1868,7 +1923,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) * * .. Scalar Arguments .. INTEGER ISNUM, NOUT - CHARACTER*7 SRNAMT + CHARACTER*11 SRNAMT * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK @@ -1897,7 +1952,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) ALPHA = ONE BETA = TWO * - GO TO ( 10, 20, 30, 40, 50, 60, 70 )ISNUM + GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, 90 )ISNUM 10 INFOT = 1 CALL DGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -1982,7 +2037,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 13 CALL DGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 80 + GO TO 100 20 INFOT = 1 CALL DSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2049,7 +2104,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 12 CALL DSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 80 + GO TO 100 30 INFOT = 1 CALL DTRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2158,7 +2213,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 11 CALL DTRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 80 + GO TO 100 40 INFOT = 1 CALL DTRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2267,7 +2322,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 11 CALL DTRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 80 + GO TO 100 50 INFOT = 1 CALL DSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2322,7 +2377,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 10 CALL DSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 80 + GO TO 100 60 INFOT = 1 CALL DSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2389,7 +2444,7 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 12 CALL DSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 80 + GO TO 100 70 INFOT = 1 CALL DGEMMTR( '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2468,16 +2523,150 @@ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 13 CALL DGEMMTR( 'U', 'T', 'T', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + GO TO 100 + 80 INFOT = 1 + CALL DSKEWSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSKEWSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSKEWSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSKEWSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSKEWSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSKEWSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSKEWSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSKEWSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSKEWSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSKEWSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSKEWSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSKEWSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSKEWSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSKEWSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSKEWSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSKEWSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSKEWSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSKEWSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DSKEWSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DSKEWSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DSKEWSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DSKEWSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + GO TO 100 + 90 INFOT = 1 + CALL DSKEWSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSKEWSYR2K( 'U', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSKEWSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSKEWSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSKEWSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSKEWSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSKEWSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSKEWSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSKEWSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSKEWSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSKEWSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSKEWSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSKEWSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSKEWSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSKEWSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSKEWSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSKEWSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSKEWSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DSKEWSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DSKEWSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DSKEWSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DSKEWSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * - 80 IF( OK )THEN + 100 IF( OK )THEN WRITE( NOUT, FMT = 9999 )SRNAMT ELSE WRITE( NOUT, FMT = 9998 )SRNAMT END IF RETURN * - 9999 FORMAT( ' ', A7, ' PASSED THE TESTS OF ERROR-EXITS' ) - 9998 FORMAT( ' ******* ', A7, ' FAILED THE TESTS OF ERROR-EXITS *****', + 9999 FORMAT( ' ', A11, ' PASSED THE TESTS OF ERROR-EXITS' ) + 9998 FORMAT( ' ******* ', A11, ' FAILED THE TESTS OF ERROR-EXITS *****', $ '**' ) * * End of DCHKE @@ -2491,7 +2680,7 @@ SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, * Stores the values in the array AA in the data structure required * by the routine, with unwanted elements set to rogue value. * -* TYPE is 'GE', 'SY' or 'TR'. +* TYPE is 'GE', 'SY', 'SK' or 'TR'. * * Auxiliary routine for test program for Level 3 Blas. * @@ -2516,7 +2705,8 @@ SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, DOUBLE PRECISION A( NMAX, * ), AA( * ) * .. Local Scalars .. INTEGER I, IBEG, IEND, J - LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER + LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER, + $ SKEW * .. External Functions .. DOUBLE PRECISION DBEG EXTERNAL DBEG @@ -2524,8 +2714,9 @@ SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, GEN = TYPE.EQ.'GE' SYM = TYPE.EQ.'SY' TRI = TYPE.EQ.'TR' - UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' - LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' + SKEW = TYPE.EQ.'SK' + UPPER = ( SYM.OR.SKEW.OR.TRI ).AND.UPLO.EQ.'U' + LOWER = ( SYM.OR.SKEW.OR.TRI ).AND.UPLO.EQ.'L' UNIT = TRI.AND.DIAG.EQ.'U' * * Generate data in array A. @@ -2541,6 +2732,8 @@ SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, $ A( I, J ) = ZERO IF( SYM )THEN A( J, I ) = A( I, J ) + ELSE IF( SKEW )THEN + A( J, I ) = -A( I, J ) ELSE IF( TRI )THEN A( J, I ) = ZERO END IF @@ -2551,6 +2744,8 @@ SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, $ A( J, J ) = A( J, J ) + ONE IF( UNIT ) $ A( J, J ) = ONE + IF( SKEW ) + $ A( J, J ) = ZERO 20 CONTINUE * * Store elements in array AS in data structure required by routine. @@ -2564,17 +2759,17 @@ SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, AA( I + ( J - 1 )*LDA ) = ROGUE 40 CONTINUE 50 CONTINUE - ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN + ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'SK'.OR.TYPE.EQ.'TR' )THEN DO 90 J = 1, N IF( UPPER )THEN IBEG = 1 - IF( UNIT )THEN + IF( UNIT.OR.SKEW )THEN IEND = J - 1 ELSE IEND = J END IF ELSE - IF( UNIT )THEN + IF( UNIT.OR.SKEW )THEN IBEG = J + 1 ELSE IBEG = J @@ -2758,7 +2953,7 @@ LOGICAL FUNCTION LDERES( TYPE, UPLO, M, N, AA, AS, LDA ) * * Tests if selected elements in two arrays are equal. * -* TYPE is 'GE' or 'SY'. +* TYPE is 'GE' or 'SY' or 'SK'. * * Auxiliary routine for test program for Level 3 Blas. * @@ -2786,14 +2981,20 @@ LOGICAL FUNCTION LDERES( TYPE, UPLO, M, N, AA, AS, LDA ) $ GO TO 70 10 CONTINUE 20 CONTINUE - ELSE IF( TYPE.EQ.'SY' )THEN + ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'SK' )THEN DO 50 J = 1, N - IF( UPPER )THEN + IF( UPPER.AND.TYPE.EQ.'SY' )THEN IBEG = 1 IEND = J - ELSE + ELSE IF( .NOT.UPPER.AND.TYPE.EQ.'SY' )THEN IBEG = J IEND = N + ELSE IF( UPPER.AND.TYPE.EQ.'SK' )THEN + IBEG = 1 + IEND = J - 1 + ELSE + IBEG = J + 1 + IEND = N END IF DO 30 I = 1, IBEG - 1 IF( AA( I, J ).NE.AS( I, J ) ) @@ -2898,7 +3099,7 @@ SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * .. Scalar Arguments .. INTEGER INFOT, NOUT LOGICAL LERR, OK - CHARACTER*7 SRNAMT + CHARACTER*11 SRNAMT * .. Executable Statements .. IF( .NOT.LERR )THEN WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT @@ -2908,7 +3109,7 @@ SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) RETURN * 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', - $ 'ETECTED BY ', A7, ' *****' ) + $ 'ETECTED BY ', A11, ' *****' ) * * End of CHKXER * @@ -2939,7 +3140,7 @@ SUBROUTINE XERBLA( SRNAME, INFO ) * .. Scalars in Common .. INTEGER INFOT, NOUT LOGICAL LERR, OK - CHARACTER*7 SRNAMT + CHARACTER*11 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUT, OK, LERR COMMON /SRNAMC/SRNAMT @@ -2964,8 +3165,8 @@ SUBROUTINE XERBLA( SRNAME, INFO ) * 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', $ ' OF ', I2, ' *******' ) - 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A7, ' INSTE', - $ 'AD OF ', A7, ' *******' ) + 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A11, ' INSTE', + $ 'AD OF ', A11, ' *******' ) 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, $ ' *******' ) * @@ -2992,7 +3193,7 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DOUBLE PRECISION EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*7 SNAME + CHARACTER*11 SNAME * .. Array Arguments .. DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -3241,15 +3442,15 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 130 CONTINUE RETURN * - 9999 FORMAT( ' ', A7, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A11, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A7, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A11, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A7, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A7, '(''',A1, ''',''',A1, ''',''', A1,''',', + 9996 FORMAT( ' ******* ', A11, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A11, '(''',A1, ''',''',A1, ''',''', A1,''',', $ 2( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', $ 'C,', I3, ').' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', diff --git a/BLAS/TESTING/dblat3.in b/BLAS/TESTING/dblat3.in index 30b74c6e40..df1037a162 100644 --- a/BLAS/TESTING/dblat3.in +++ b/BLAS/TESTING/dblat3.in @@ -12,10 +12,12 @@ T LOGICAL FLAG, T TO TEST ERROR EXITS. 0.0 1.0 0.7 VALUES OF ALPHA 3 NUMBER OF VALUES OF BETA 0.0 1.0 1.3 VALUES OF BETA -DGEMM T PUT F FOR NO TEST. SAME COLUMNS. -DSYMM T PUT F FOR NO TEST. SAME COLUMNS. -DTRMM T PUT F FOR NO TEST. SAME COLUMNS. -DTRSM T PUT F FOR NO TEST. SAME COLUMNS. -DSYRK T PUT F FOR NO TEST. SAME COLUMNS. -DSYR2K T PUT F FOR NO TEST. SAME COLUMNS. -DGEMMTR T PUT F FOR NO TEST. SAME COLUMNS. +DGEMM T PUT F FOR NO TEST. SAME COLUMNS. +DSYMM T PUT F FOR NO TEST. SAME COLUMNS. +DTRMM T PUT F FOR NO TEST. SAME COLUMNS. +DTRSM T PUT F FOR NO TEST. SAME COLUMNS. +DSYRK T PUT F FOR NO TEST. SAME COLUMNS. +DSYR2K T PUT F FOR NO TEST. SAME COLUMNS. +DGEMMTR T PUT F FOR NO TEST. SAME COLUMNS. +DSKEWSYMM T PUT F FOR NO TEST. SAME COLUMNS. +DSKEWSYR2K T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/BLAS/TESTING/sblat2.f b/BLAS/TESTING/sblat2.f index ff5acffa83..faae008258 100644 --- a/BLAS/TESTING/sblat2.f +++ b/BLAS/TESTING/sblat2.f @@ -20,7 +20,7 @@ *> *> The program must be driven by a short data file. The first 18 records *> of the file are read using list-directed input, the last 16 records -*> are read using the format ( A6, L2 ). An annotated example of a data +*> are read using the format ( A10, L2 ). An annotated example of a data *> file can be obtained by deleting the first 3 characters from the *> following 34 lines: *> 'sblat2.out' NAME OF SUMMARY OUTPUT FILE @@ -57,6 +57,8 @@ *> SSPR T PUT F FOR NO TEST. SAME COLUMNS. *> SSYR2 T PUT F FOR NO TEST. SAME COLUMNS. *> SSPR2 T PUT F FOR NO TEST. SAME COLUMNS. +*> SSKEWSYMV T PUT F FOR NO TEST. SAME COLUMNS. +*> SSKEWSYR T PUT F FOR NO TEST. SAME COLUMNS. *> *> Further Details *> =============== @@ -111,7 +113,7 @@ PROGRAM SBLAT2 INTEGER NIN PARAMETER ( NIN = 5 ) INTEGER NSUBS - PARAMETER ( NSUBS = 16 ) + PARAMETER ( NSUBS = 18 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0, ONE = 1.0 ) INTEGER NMAX, INCMAX @@ -126,7 +128,7 @@ PROGRAM SBLAT2 LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, $ TSTERR CHARACTER*1 TRANS - CHARACTER*6 SNAMET + CHARACTER*10 SNAMET CHARACTER*32 SNAPS, SUMMRY * .. Local Arrays .. REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), @@ -137,7 +139,7 @@ PROGRAM SBLAT2 $ YY( NMAX*INCMAX ), Z( 2*NMAX ) INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX ) LOGICAL LTEST( NSUBS ) - CHARACTER*6 SNAMES( NSUBS ) + CHARACTER*10 SNAMES( NSUBS ) * .. External Functions .. REAL SDIFF LOGICAL LSE @@ -150,15 +152,20 @@ PROGRAM SBLAT2 * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK - CHARACTER*6 SRNAMT + CHARACTER*10 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR COMMON /SRNAMC/SRNAMT * .. Data statements .. - DATA SNAMES/'SGEMV ', 'SGBMV ', 'SSYMV ', 'SSBMV ', - $ 'SSPMV ', 'STRMV ', 'STBMV ', 'STPMV ', - $ 'STRSV ', 'STBSV ', 'STPSV ', 'SGER ', - $ 'SSYR ', 'SSPR ', 'SSYR2 ', 'SSPR2 '/ + DATA SNAMES/'SGEMV ', 'SGBMV ', + $ 'SSYMV ', 'SSBMV ', + $ 'SSPMV ', 'STRMV ', + $ 'STBMV ', 'STPMV ', + $ 'STRSV ', 'STBSV ', + $ 'STPSV ', 'SGER ', + $ 'SSYR ', 'SSPR ', + $ 'SSYR2 ', 'SSPR2 ', + $ 'SSKEWSYMV ', 'SSKEWSYR2 '/ * .. Executable Statements .. * * Read name and unit number for summary output file and open file. @@ -334,14 +341,14 @@ PROGRAM SBLAT2 FATAL = .FALSE. GO TO ( 140, 140, 150, 150, 150, 160, 160, $ 160, 160, 160, 160, 170, 180, 180, - $ 190, 190 )ISNUM + $ 190, 190, 150, 190 )ISNUM * Test SGEMV, 01, and SGBMV, 02. 140 CALL SCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, $ X, XX, XS, Y, YY, YS, YT, G ) GO TO 200 -* Test SSYMV, 03, SSBMV, 04, and SSPMV, 05. +* Test SSYMV, 03, SSBMV, 04, SSPMV, 05, and SSKEWSYMV, 17. 150 CALL SCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, @@ -365,7 +372,7 @@ PROGRAM SBLAT2 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, $ YT, G, Z ) GO TO 200 -* Test SSYR2, 15, and SSPR2, 16. +* Test SSYR2, 15, SSPR2, 16, and SSKEWSYR2, 18. 190 CALL SCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, @@ -409,15 +416,15 @@ PROGRAM SBLAT2 9988 FORMAT( ' FOR BETA ', 7F6.1 ) 9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', $ /' ******* TESTS ABANDONED *******' ) - 9986 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', + 9986 FORMAT( ' SUBPROGRAM NAME ', A10, ' NOT RECOGNIZED', /' ******* T', $ 'ESTS ABANDONED *******' ) 9985 FORMAT( ' ERROR IN SMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', $ 'ATED WRONGLY.', /' SMVCH WAS CALLED WITH TRANS = ', A1, $ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', / $ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.' $ , /' ******* TESTS ABANDONED *******' ) - 9984 FORMAT( A6, L2 ) - 9983 FORMAT( 1X, A6, ' WAS NOT TESTED' ) + 9984 FORMAT( A10, L2 ) + 9983 FORMAT( 1X, A10, ' WAS NOT TESTED' ) 9982 FORMAT( /' END OF TESTS' ) 9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) @@ -447,7 +454,7 @@ SUBROUTINE SCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, $ NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*10 SNAME * .. Array Arguments .. REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), @@ -776,17 +783,17 @@ SUBROUTINE SCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 140 CONTINUE RETURN * - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A10, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A10, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 4( I3, ',' ), F4.1, + 9996 FORMAT( ' ******* ', A10, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A10, '(''', A1, ''',', 4( I3, ',' ), F4.1, $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1, + 9994 FORMAT( 1X, I6, ': ', A10, '(''', A1, ''',', 2( I3, ',' ), F4.1, $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, $ ') .' ) 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', @@ -801,7 +808,7 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ XS, Y, YY, YS, YT, G ) IMPLICIT NONE * -* Tests SSYMV, SSBMV and SSPMV. +* Tests SSYMV, SSKEWSYMV, SSBMV and SSPMV. * * Auxiliary routine for test program for Level 2 Blas. * @@ -817,7 +824,7 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, $ NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*10 SNAME * .. Array Arguments .. REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), @@ -831,7 +838,8 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY, $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY, $ N, NARGS, NC, NK, NS - LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME + LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME, + $ SKEWFULL CHARACTER*1 UPLO, UPLOS CHARACTER*2 ICH * .. Local Arrays .. @@ -840,7 +848,7 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, LOGICAL LSE, LSERES EXTERNAL LSE, LSERES * .. External Subroutines .. - EXTERNAL SMAKE, SMVCH, SSBMV, SSPMV, SSYMV + EXTERNAL SMAKE, SMVCH, SSBMV, SSPMV, SSYMV, SSKEWSYMV * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. Scalars in Common .. @@ -854,8 +862,9 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, FULL = SNAME( 3: 3 ).EQ.'Y' BANDED = SNAME( 3: 3 ).EQ.'B' PACKED = SNAME( 3: 3 ).EQ.'P' + SKEWFULL = SNAME( 2: 2 ).EQ.'S'.AND.SNAME( 3: 3 ).EQ.'K' * Define the number of arguments. - IF( FULL )THEN + IF( FULL.OR.SKEWFULL )THEN NARGS = 10 ELSE IF( BANDED )THEN NARGS = 11 @@ -972,6 +981,14 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ REWIND NTRA CALL SSYMV( UPLO, N, ALPHA, AA, LDA, XX, $ INCX, BETA, YY, INCY ) + ELSE IF( SKEWFULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, + $ UPLO, N, ALPHA, LDA, INCX, BETA, INCY + IF( REWI ) + $ REWIND NTRA + CALL SSKEWSYMV( UPLO, N, ALPHA, AA, LDA, + $ XX, INCX, BETA, YY, INCY ) ELSE IF( BANDED )THEN IF( TRACE ) $ WRITE( NTRA, FMT = 9994 )NC, SNAME, @@ -1003,7 +1020,7 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * ISAME( 1 ) = UPLO.EQ.UPLOS ISAME( 2 ) = NS.EQ.N - IF( FULL )THEN + IF( FULL.OR.SKEWFULL )THEN ISAME( 3 ) = ALS.EQ.ALPHA ISAME( 4 ) = LSE( AS, AA, LAA ) ISAME( 5 ) = LDAS.EQ.LDA @@ -1118,20 +1135,20 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 130 CONTINUE RETURN * - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A10, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A10, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', AP', + 9996 FORMAT( ' ******* ', A10, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A10, '(''', A1, ''',', I3, ',', F4.1, ', AP', $ ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1, + 9994 FORMAT( 1X, I6, ': ', A10, '(''', A1, ''',', 2( I3, ',' ), F4.1, $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, $ ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', A,', + 9993 FORMAT( 1X, I6, ': ', A10, '(''', A1, ''',', I3, ',', F4.1, ', A,', $ I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) @@ -1159,7 +1176,7 @@ SUBROUTINE SCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, REAL EPS, THRESH INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*10 SNAME * .. Array Arguments .. REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), @@ -1477,19 +1494,19 @@ SUBROUTINE SCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 130 CONTINUE RETURN * - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A10, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A10, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', AP, ', + 9996 FORMAT( ' ******* ', A10, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A10, '(', 3( '''', A1, ''',' ), I3, ', AP, ', $ 'X,', I2, ') .' ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), 2( I3, ',' ), + 9994 FORMAT( 1X, I6, ': ', A10, '(', 3( '''', A1, ''',' ), 2( I3, ',' ), $ ' A,', I3, ', X,', I2, ') .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', A,', + 9993 FORMAT( 1X, I6, ': ', A10, '(', 3( '''', A1, ''',' ), I3, ', A,', $ I3, ', X,', I2, ') .' ) 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) @@ -1518,7 +1535,7 @@ SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, REAL EPS, THRESH INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*10 SNAME * .. Array Arguments .. REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), @@ -1742,16 +1759,16 @@ SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 150 CONTINUE RETURN * - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A10, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A10, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) + 9996 FORMAT( ' ******* ', A10, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( I3, ',' ), F4.1, ', X,', I2, + 9994 FORMAT( 1X, I6, ': ', A10, '(', 2( I3, ',' ), F4.1, ', X,', I2, $ ', Y,', I2, ', A,', I3, ') .' ) 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) @@ -1780,7 +1797,7 @@ SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, REAL EPS, THRESH INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*10 SNAME * .. Array Arguments .. REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), @@ -2019,18 +2036,18 @@ SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 130 CONTINUE RETURN * - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A10, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A10, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) + 9996 FORMAT( ' ******* ', A10, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', + 9994 FORMAT( 1X, I6, ': ', A10, '(''', A1, ''',', I3, ',', F4.1, ', X,', $ I2, ', AP) .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', + 9993 FORMAT( 1X, I6, ': ', A10, '(''', A1, ''',', I3, ',', F4.1, ', X,', $ I2, ', A,', I3, ') .' ) 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) @@ -2044,7 +2061,7 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ Z ) IMPLICIT NONE * -* Tests SSYR2 and SSPR2. +* Tests SSYR2, SSKEWSYR2 and SSPR2. * * Auxiliary routine for test program for Level 2 Blas. * @@ -2059,7 +2076,7 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, REAL EPS, THRESH INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*6 SNAME + CHARACTER*10 SNAME * .. Array Arguments .. REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), @@ -2072,7 +2089,8 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX, $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N, $ NARGS, NC, NS - LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER + LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER, + $ SKEWFULL CHARACTER*1 UPLO, UPLOS CHARACTER*2 ICH * .. Local Arrays .. @@ -2082,7 +2100,7 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, LOGICAL LSE, LSERES EXTERNAL LSE, LSERES * .. External Subroutines .. - EXTERNAL SMAKE, SMVCH, SSPR2, SSYR2 + EXTERNAL SMAKE, SMVCH, SSPR2, SSYR2, SSKEWSYR2 * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. Scalars in Common .. @@ -2095,8 +2113,9 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * .. Executable Statements .. FULL = SNAME( 3: 3 ).EQ.'Y' PACKED = SNAME( 3: 3 ).EQ.'P' + SKEWFULL = SNAME( 2: 2 ).EQ.'S'.AND.SNAME( 3: 3 ).EQ.'K' * Define the number of arguments. - IF( FULL )THEN + IF( FULL.OR.SKEWFULL )THEN NARGS = 9 ELSE IF( PACKED )THEN NARGS = 8 @@ -2194,6 +2213,14 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ REWIND NTRA CALL SSYR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, $ AA, LDA ) + ELSE IF( SKEWFULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, + $ ALPHA, INCX, INCY, LDA + IF( REWI ) + $ REWIND NTRA + CALL SSKEWSYR2( UPLO, N, ALPHA, XX, INCX, YY, + $ INCY, AA, LDA ) ELSE IF( PACKED )THEN IF( TRACE ) $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, @@ -2266,22 +2293,36 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, Z( I, 2 ) = Y( N - I + 1 ) 80 CONTINUE END IF - JA = 1 + IF( .NOT.SKEWFULL.OR.UPPER )THEN + JA = 1 + ELSE + JA = 2 + END IF DO 90 J = 1, N - W( 1 ) = Z( J, 2 ) + IF( .NOT.SKEWFULL )THEN + W( 1 ) = Z( J, 2 ) + ELSE + W( 1 ) = -Z( J, 2 ) + END IF W( 2 ) = Z( J, 1 ) - IF( UPPER )THEN + IF( .NOT.SKEWFULL.AND.UPPER )THEN JJ = 1 LJ = J - ELSE + ELSE IF( .NOT.SKEWFULL.AND..NOT.UPPER )THEN JJ = J LJ = N - J + 1 + ELSE IF( SKEWFULL.AND.UPPER )THEN + JJ = 1 + LJ = J - 1 + ELSE + JJ = J + 1 + LJ = N - J END IF CALL SMVCH( 'N', LJ, 2, ALPHA, Z( JJ, 1 ), $ NMAX, W, 1, ONE, A( JJ, J ), 1, $ YT, G, AA( JA ), EPS, ERR, FATAL, $ NOUT, .TRUE. ) - IF( FULL )THEN + IF( FULL.OR.SKEWFULL )THEN IF( UPPER )THEN JA = JA + LDA ELSE @@ -2325,7 +2366,7 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * 160 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN + IF( FULL.OR.SKEWFULL )THEN WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, $ INCY, LDA ELSE IF( PACKED )THEN @@ -2335,18 +2376,18 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 170 CONTINUE RETURN * - 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A10, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A10, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) + 9996 FORMAT( ' ******* ', A10, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', + 9994 FORMAT( 1X, I6, ': ', A10, '(''', A1, ''',', I3, ',', F4.1, ', X,', $ I2, ', Y,', I2, ', AP) .' ) - 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', + 9993 FORMAT( 1X, I6, ': ', A10, '(''', A1, ''',', I3, ',', F4.1, ', X,', $ I2, ', Y,', I2, ', A,', I3, ') .' ) 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) @@ -2369,7 +2410,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) * * .. Scalar Arguments .. INTEGER ISNUM, NOUT - CHARACTER*6 SRNAMT + CHARACTER*10 SRNAMT * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK @@ -2392,7 +2433,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) LERR = .FALSE. GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, $ 90, 100, 110, 120, 130, 140, 150, - $ 160 )ISNUM + $ 160, 170, 180 )ISNUM 10 INFOT = 1 CALL SGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2411,7 +2452,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 11 CALL SGEMV( 'N', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 20 INFOT = 1 CALL SGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2436,7 +2477,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 13 CALL SGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 30 INFOT = 1 CALL SSYMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2452,7 +2493,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 10 CALL SSYMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 40 INFOT = 1 CALL SSBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2471,7 +2512,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 11 CALL SSBMV( 'U', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 50 INFOT = 1 CALL SSPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2484,7 +2525,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 9 CALL SSPMV( 'U', 0, ALPHA, A, X, 1, BETA, Y, 0 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 60 INFOT = 1 CALL STRMV( '/', 'N', 'N', 0, A, 1, X, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2503,7 +2544,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 8 CALL STRMV( 'U', 'N', 'N', 0, A, 1, X, 0 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 70 INFOT = 1 CALL STBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2525,7 +2566,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 9 CALL STBMV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 80 INFOT = 1 CALL STPMV( '/', 'N', 'N', 0, A, X, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2541,7 +2582,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 7 CALL STPMV( 'U', 'N', 'N', 0, A, X, 0 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 90 INFOT = 1 CALL STRSV( '/', 'N', 'N', 0, A, 1, X, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2560,7 +2601,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 8 CALL STRSV( 'U', 'N', 'N', 0, A, 1, X, 0 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 100 INFOT = 1 CALL STBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2582,7 +2623,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 9 CALL STBSV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 110 INFOT = 1 CALL STPSV( '/', 'N', 'N', 0, A, X, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2598,7 +2639,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 7 CALL STPSV( 'U', 'N', 'N', 0, A, X, 0 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 120 INFOT = 1 CALL SGER( -1, 0, ALPHA, X, 1, Y, 1, A, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2614,7 +2655,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 9 CALL SGER( 2, 0, ALPHA, X, 1, Y, 1, A, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 130 INFOT = 1 CALL SSYR( '/', 0, ALPHA, X, 1, A, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2627,7 +2668,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 7 CALL SSYR( 'U', 2, ALPHA, X, 1, A, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 140 INFOT = 1 CALL SSPR( '/', 0, ALPHA, X, 1, A ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2637,7 +2678,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 5 CALL SSPR( 'U', 0, ALPHA, X, 0, A ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 150 INFOT = 1 CALL SSYR2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2653,7 +2694,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 9 CALL SSYR2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 170 + GO TO 190 160 INFOT = 1 CALL SSPR2( '/', 0, ALPHA, X, 1, Y, 1, A ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2666,16 +2707,48 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 7 CALL SSPR2( 'U', 0, ALPHA, X, 1, Y, 0, A ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + GO TO 190 + 170 INFOT = 1 + CALL SSKEWSYMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSKEWSYMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSKEWSYMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSKEWSYMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSKEWSYMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + GO TO 190 + 180 INFOT = 1 + CALL SSKEWSYR2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSKEWSYR2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSKEWSYR2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSKEWSYR2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSKEWSYR2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * - 170 IF( OK )THEN + 190 IF( OK )THEN WRITE( NOUT, FMT = 9999 )SRNAMT ELSE WRITE( NOUT, FMT = 9998 )SRNAMT END IF RETURN * - 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) - 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', + 9999 FORMAT( ' ', A10, ' PASSED THE TESTS OF ERROR-EXITS' ) + 9998 FORMAT( ' ******* ', A10, ' FAILED THE TESTS OF ERROR-EXITS *****', $ '**' ) * * End of SCHKE @@ -2690,7 +2763,7 @@ SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, * Stores the values in the array AA in the data structure required * by the routine, with unwanted elements set to rogue value. * -* TYPE is 'GE', 'GB', 'SY', 'SB', 'SP', 'TR', 'TB' OR 'TP'. +* TYPE is 'GE', 'GB', 'SY', 'SB', 'SP', 'SK', 'TR', 'TB' OR 'TP'. * * Auxiliary routine for test program for Level 2 Blas. * @@ -2713,7 +2786,8 @@ SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, REAL A( NMAX, * ), AA( * ) * .. Local Scalars .. INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, KK - LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER + LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER, + $ SKEW * .. External Functions .. REAL SBEG EXTERNAL SBEG @@ -2721,10 +2795,11 @@ SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, INTRINSIC MAX, MIN * .. Executable Statements .. GEN = TYPE( 1: 1 ).EQ.'G' - SYM = TYPE( 1: 1 ).EQ.'S' + SYM = TYPE( 1: 1 ).EQ.'S'.AND.TYPE( 2: 2 ).NE.'K' + SKEW = TYPE( 1: 1 ).EQ.'S'.AND.TYPE( 2: 2 ).EQ.'K' TRI = TYPE( 1: 1 ).EQ.'T' - UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' - LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' + UPPER = ( SYM.OR.SKEW.OR.TRI ).AND.UPLO.EQ.'U' + LOWER = ( SYM.OR.SKEW.OR.TRI ).AND.UPLO.EQ.'L' UNIT = TRI.AND.DIAG.EQ.'U' * * Generate data in array A. @@ -2742,6 +2817,8 @@ SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, IF( I.NE.J )THEN IF( SYM )THEN A( J, I ) = A( I, J ) + ELSE IF( SKEW )THEN + A( J, I ) = -A( I, J ) ELSE IF( TRI )THEN A( J, I ) = ZERO END IF @@ -2752,6 +2829,8 @@ SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, $ A( J, J ) = A( J, J ) + ONE IF( UNIT ) $ A( J, J ) = ONE + IF( SKEW ) + $ A( J, J ) = ZERO 20 CONTINUE * * Store elements in array AS in data structure required by routine. @@ -2777,17 +2856,17 @@ SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, AA( I3 + ( J - 1 )*LDA ) = ROGUE 80 CONTINUE 90 CONTINUE - ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN + ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'SK'.OR.TYPE.EQ.'TR' )THEN DO 130 J = 1, N IF( UPPER )THEN IBEG = 1 - IF( UNIT )THEN + IF( UNIT.OR.SKEW )THEN IEND = J - 1 ELSE IEND = J END IF ELSE - IF( UNIT )THEN + IF( UNIT.OR.SKEW )THEN IBEG = J + 1 ELSE IBEG = J @@ -3012,7 +3091,7 @@ LOGICAL FUNCTION LSERES( TYPE, UPLO, M, N, AA, AS, LDA ) * * Tests if selected elements in two arrays are equal. * -* TYPE is 'GE', 'SY' or 'SP'. +* TYPE is 'GE', 'SY', 'SK' or 'SP'. * * Auxiliary routine for test program for Level 2 Blas. * @@ -3038,14 +3117,20 @@ LOGICAL FUNCTION LSERES( TYPE, UPLO, M, N, AA, AS, LDA ) $ GO TO 70 10 CONTINUE 20 CONTINUE - ELSE IF( TYPE.EQ.'SY' )THEN + ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'SK' )THEN DO 50 J = 1, N - IF( UPPER )THEN + IF( UPPER.AND.TYPE.EQ.'SY' )THEN IBEG = 1 IEND = J - ELSE + ELSE IF( .NOT.UPPER.AND.TYPE.EQ.'SY' )THEN IBEG = J IEND = N + ELSE IF( UPPER.AND.TYPE.EQ.'SK' )THEN + IBEG = 1 + IEND = J - 1 + ELSE + IBEG = J + 1 + IEND = N END IF DO 30 I = 1, IBEG - 1 IF( AA( I, J ).NE.AS( I, J ) ) @@ -3145,7 +3230,7 @@ SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * .. Scalar Arguments .. INTEGER INFOT, NOUT LOGICAL LERR, OK - CHARACTER*6 SRNAMT + CHARACTER*10 SRNAMT * .. Executable Statements .. IF( .NOT.LERR )THEN WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT @@ -3155,7 +3240,7 @@ SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) RETURN * 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', - $ 'ETECTED BY ', A6, ' *****' ) + $ 'ETECTED BY ', A10, ' *****' ) * * End of CHKXER * @@ -3214,14 +3299,16 @@ SUBROUTINE XERBLA( SRNAME, INFO ) * * .. Scalar Arguments .. INTEGER INFO - CHARACTER*6 SRNAME + CHARACTER*10 SRNAME * .. Scalars in Common .. INTEGER INFOT, NOUT LOGICAL LERR, OK - CHARACTER*6 SRNAMT + CHARACTER*10 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUT, OK, LERR COMMON /SRNAMC/SRNAMT +* .. Locals .. + INTEGER SRLEN * .. Executable Statements .. LERR = .TRUE. IF( INFO.NE.INFOT )THEN @@ -3232,7 +3319,8 @@ SUBROUTINE XERBLA( SRNAME, INFO ) END IF OK = .FALSE. END IF - IF( SRNAME.NE.SRNAMT )THEN + SRLEN = MIN(LEN_TRIM(SRNAME), LEN_TRIM(SRNAMT)) + IF( SRNAME(1:SRLEN).NE.SRNAMT(1:SRLEN) )THEN WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT OK = .FALSE. END IF @@ -3240,8 +3328,8 @@ SUBROUTINE XERBLA( SRNAME, INFO ) * 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', $ ' OF ', I2, ' *******' ) - 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', - $ 'AD OF ', A6, ' *******' ) + 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A10, ' INSTE', + $ 'AD OF ', A10, ' *******' ) 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, $ ' *******' ) * diff --git a/BLAS/TESTING/sblat2.in b/BLAS/TESTING/sblat2.in index fefc7e958a..a8e88d3a2b 100644 --- a/BLAS/TESTING/sblat2.in +++ b/BLAS/TESTING/sblat2.in @@ -16,19 +16,21 @@ T LOGICAL FLAG, T TO TEST ERROR EXITS. 0.0 1.0 0.7 VALUES OF ALPHA 3 NUMBER OF VALUES OF BETA 0.0 1.0 0.9 VALUES OF BETA -SGEMV T PUT F FOR NO TEST. SAME COLUMNS. -SGBMV T PUT F FOR NO TEST. SAME COLUMNS. -SSYMV T PUT F FOR NO TEST. SAME COLUMNS. -SSBMV T PUT F FOR NO TEST. SAME COLUMNS. -SSPMV T PUT F FOR NO TEST. SAME COLUMNS. -STRMV T PUT F FOR NO TEST. SAME COLUMNS. -STBMV T PUT F FOR NO TEST. SAME COLUMNS. -STPMV T PUT F FOR NO TEST. SAME COLUMNS. -STRSV T PUT F FOR NO TEST. SAME COLUMNS. -STBSV T PUT F FOR NO TEST. SAME COLUMNS. -STPSV T PUT F FOR NO TEST. SAME COLUMNS. -SGER T PUT F FOR NO TEST. SAME COLUMNS. -SSYR T PUT F FOR NO TEST. SAME COLUMNS. -SSPR T PUT F FOR NO TEST. SAME COLUMNS. -SSYR2 T PUT F FOR NO TEST. SAME COLUMNS. -SSPR2 T PUT F FOR NO TEST. SAME COLUMNS. +SGEMV T PUT F FOR NO TEST. SAME COLUMNS. +SGBMV T PUT F FOR NO TEST. SAME COLUMNS. +SSYMV T PUT F FOR NO TEST. SAME COLUMNS. +SSBMV T PUT F FOR NO TEST. SAME COLUMNS. +SSPMV T PUT F FOR NO TEST. SAME COLUMNS. +STRMV T PUT F FOR NO TEST. SAME COLUMNS. +STBMV T PUT F FOR NO TEST. SAME COLUMNS. +STPMV T PUT F FOR NO TEST. SAME COLUMNS. +STRSV T PUT F FOR NO TEST. SAME COLUMNS. +STBSV T PUT F FOR NO TEST. SAME COLUMNS. +STPSV T PUT F FOR NO TEST. SAME COLUMNS. +SGER T PUT F FOR NO TEST. SAME COLUMNS. +SSYR T PUT F FOR NO TEST. SAME COLUMNS. +SSPR T PUT F FOR NO TEST. SAME COLUMNS. +SSYR2 T PUT F FOR NO TEST. SAME COLUMNS. +SSPR2 T PUT F FOR NO TEST. SAME COLUMNS. +SSKEWSYMV T PUT F FOR NO TEST. SAME COLUMNS. +SSKEWSYR2 T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/BLAS/TESTING/sblat3.f b/BLAS/TESTING/sblat3.f index d8f2ed85cb..f13641b62b 100644 --- a/BLAS/TESTING/sblat3.f +++ b/BLAS/TESTING/sblat3.f @@ -19,8 +19,8 @@ *> Test program for the REAL Level 3 Blas. *> *> The program must be driven by a short data file. The first 14 records -*> of the file are read using list-directed input, the last 7 records -*> are read using the format ( A7, L2 ). An annotated example of a data +*> of the file are read using list-directed input, the last 9 records +*> are read using the format ( A11, L2 ). An annotated example of a data *> file can be obtained by deleting the first 3 characters from the *> following 20 lines: *> 'sblat3.out' NAME OF SUMMARY OUTPUT FILE @@ -44,6 +44,8 @@ *> SSYRK T PUT F FOR NO TEST. SAME COLUMNS. *> SSYR2K T PUT F FOR NO TEST. SAME COLUMNS. *> SGEMMTR T PUT F FOR NO TEST. SAME COLUMNS. +*> SSKEWSYMM T PUT F FOR NO TEST. SAME COLUMNS. +*> SSKEWSYR2K T PUT F FOR NO TEST. SAME COLUMNS. *> *> Further Details *> =============== @@ -92,7 +94,7 @@ PROGRAM SBLAT3 INTEGER NIN PARAMETER ( NIN = 5 ) INTEGER NSUBS - PARAMETER ( NSUBS = 7 ) + PARAMETER ( NSUBS = 9 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0, ONE = 1.0 ) INTEGER NMAX @@ -105,7 +107,7 @@ PROGRAM SBLAT3 LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, $ TSTERR CHARACTER*1 TRANSA, TRANSB - CHARACTER*7 SNAMET + CHARACTER*11 SNAMET CHARACTER*32 SNAPS, SUMMRY * .. Local Arrays .. REAL AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), @@ -116,7 +118,7 @@ PROGRAM SBLAT3 $ G( NMAX ), W( 2*NMAX ) INTEGER IDIM( NIDMAX ) LOGICAL LTEST( NSUBS ) - CHARACTER*7 SNAMES( NSUBS ) + CHARACTER*11 SNAMES( NSUBS ) * .. External Functions .. REAL SDIFF LOGICAL LSE @@ -129,13 +131,16 @@ PROGRAM SBLAT3 * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK - CHARACTER*7 SRNAMT + CHARACTER*11 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR COMMON /SRNAMC/SRNAMT * .. Data statements .. - DATA SNAMES/'SGEMM', 'SSYMM ', 'STRMM ', - $ 'STRSM ', 'SSYRK ', 'SSYR2K ', 'SGEMMTR'/ + DATA SNAMES/'SGEMM ', 'SSYMM ', + $ 'STRMM ', 'STRSM ', + $ 'SSYRK ', 'SSYR2K ', + $ 'SGEMMTR ', + $ 'SSKEWSYMM ', 'SSKEWSYR2K '/ * .. Executable Statements .. * * Read name and unit number for summary output file and open file. @@ -312,14 +317,14 @@ PROGRAM SBLAT3 INFOT = 0 OK = .TRUE. FATAL = .FALSE. - GO TO ( 140, 150, 160, 160, 170, 180, 185 )ISNUM + GO TO ( 140, 150, 160, 160, 170, 180, 185, 150, 180 )ISNUM * Test SGEMM, 01. 140 CALL SCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, $ CC, CS, CT, G ) GO TO 190 -* Test SSYMM, 02. +* Test SSYMM, 02, SSKEWSYMM, 07. 150 CALL SCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, @@ -336,7 +341,7 @@ PROGRAM SBLAT3 $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, $ CC, CS, CT, G ) GO TO 190 -* Test SSYR2K, 06. +* Test SSYR2K, 06, SSKEWSYR2K, 08. 180 CALL SCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) @@ -381,7 +386,7 @@ PROGRAM SBLAT3 9992 FORMAT( ' FOR BETA ', 7F6.1 ) 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', $ /' ******* TESTS ABANDONED *******' ) - 9990 FORMAT( ' SUBPROGRAM NAME ', A7, ' NOT RECOGNIZED', /' ******* T', + 9990 FORMAT( ' SUBPROGRAM NAME ', A11, ' NOT RECOGNIZED', /' ******* T', $ 'ESTS ABANDONED *******' ) 9989 FORMAT( ' ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', $ 'ATED WRONGLY.', /' SMMCH WAS CALLED WITH TRANSA = ', A1, @@ -389,8 +394,8 @@ PROGRAM SBLAT3 $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ', $ '*******' ) - 9988 FORMAT( A7, L2 ) - 9987 FORMAT( 1X, A7, ' WAS NOT TESTED' ) + 9988 FORMAT( A11, L2 ) + 9987 FORMAT( 1X, A11, ' WAS NOT TESTED' ) 9986 FORMAT( /' END OF TESTS' ) 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) @@ -420,7 +425,7 @@ SUBROUTINE SCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*7 SNAME + CHARACTER*11 SNAME * .. Array Arguments .. REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -663,15 +668,15 @@ SUBROUTINE SCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 130 CONTINUE RETURN * - 9999 FORMAT( ' ', A7, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A11, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A7, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A11, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A7, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A7, '(''', A1, ''',''', A1, ''',', + 9996 FORMAT( ' ******* ', A11, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A11, '(''', A1, ''',''', A1, ''',', $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', $ 'C,', I3, ').' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', @@ -702,7 +707,7 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*7 SNAME + CHARACTER*11 SNAME * .. Array Arguments .. REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -715,7 +720,7 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC, $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA, $ NARGS, NC, NS - LOGICAL LEFT, NULL, RESET, SAME + LOGICAL LEFT, NULL, RESET, SAME, SKEWFULL CHARACTER*1 SIDE, SIDES, UPLO, UPLOS CHARACTER*2 ICHS, ICHU * .. Local Arrays .. @@ -724,7 +729,7 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, LOGICAL LSE, LSERES EXTERNAL LSE, LSERES * .. External Subroutines .. - EXTERNAL SMAKE, SMMCH, SSYMM + EXTERNAL SMAKE, SMMCH, SSYMM, SSKEWSYMM * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. @@ -736,6 +741,7 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DATA ICHS/'LR'/, ICHU/'UL'/ * .. Executable Statements .. * + SKEWFULL = SNAME( 2: 2 ).EQ.'S'.AND.SNAME( 3: 3 ).EQ.'K' NARGS = 12 NC = 0 RESET = .TRUE. @@ -793,8 +799,13 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * * Generate the symmetric matrix A. * - CALL SMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, LDA, - $ RESET, ZERO ) + IF(.NOT.SKEWFULL) THEN + CALL SMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, + $ LDA, RESET, ZERO ) + ELSE + CALL SMAKE( 'SK', UPLO, ' ', NA, NA, A, NMAX, AA, + $ LDA, RESET, ZERO ) + END IF * DO 60 IA = 1, NALF ALPHA = ALF( IA ) @@ -838,8 +849,13 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC IF( REWI ) $ REWIND NTRA - CALL SSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, - $ BB, LDB, BETA, CC, LDC ) + IF(.NOT.SKEWFULL) THEN + CALL SSYMM( SIDE, UPLO, M, N, ALPHA, AA, + $ LDA, BB, LDB, BETA, CC, LDC ) + ELSE + CALL SSKEWSYMM( SIDE, UPLO, M, N, ALPHA, AA, + $ LDA, BB, LDB, BETA, CC, LDC ) + END IF * * Check if error-exit was taken incorrectly. * @@ -934,15 +950,15 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 120 CONTINUE RETURN * - 9999 FORMAT( ' ', A7, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A11, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A7, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A11, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A7, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A7, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), + 9996 FORMAT( ' ******* ', A11, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A11, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', $ ' .' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', @@ -973,7 +989,7 @@ SUBROUTINE SCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, REAL EPS, THRESH INTEGER NALF, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*7 SNAME + CHARACTER*11 SNAME * .. Array Arguments .. REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -1241,15 +1257,15 @@ SUBROUTINE SCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 160 CONTINUE RETURN * - 9999 FORMAT( ' ', A7, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A11, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A7, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A11, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A7, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A7, '(', 4( '''', A1, ''',' ), 2( I3, ',' ), + 9996 FORMAT( ' ******* ', A11, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A11, '(', 4( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ', B,', I3, ') .' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) @@ -1279,7 +1295,7 @@ SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*7 SNAME + CHARACTER*11 SNAME * .. Array Arguments .. REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -1516,16 +1532,16 @@ SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 130 CONTINUE RETURN * - 9999 FORMAT( ' ', A7, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A11, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A7, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A11, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A7, ' FAILED ON CALL NUMBER:' ) + 9996 FORMAT( ' ******* ', A11, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A7, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), + 9994 FORMAT( 1X, I6, ': ', A11, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' ) 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) @@ -1555,7 +1571,7 @@ SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*7 SNAME + CHARACTER*11 SNAME * .. Array Arguments .. REAL AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), @@ -1568,7 +1584,7 @@ SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS - LOGICAL NULL, RESET, SAME, TRAN, UPPER + LOGICAL NULL, RESET, SAME, TRAN, UPPER, SKEWFULL CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS CHARACTER*2 ICHU CHARACTER*3 ICHT @@ -1578,7 +1594,7 @@ SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, LOGICAL LSE, LSERES EXTERNAL LSE, LSERES * .. External Subroutines .. - EXTERNAL SMAKE, SMMCH, SSYR2K + EXTERNAL SMAKE, SMMCH, SSYR2K, SSKEWSYR2K * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. @@ -1590,6 +1606,7 @@ SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DATA ICHT/'NTC'/, ICHU/'UL'/ * .. Executable Statements .. * + SKEWFULL = SNAME( 2: 2 ).EQ.'S'.AND.SNAME( 3: 3 ).EQ.'K' NARGS = 12 NC = 0 RESET = .TRUE. @@ -1663,8 +1680,13 @@ SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * * Generate the matrix C. * - CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC, - $ LDC, RESET, ZERO ) + IF(.NOT.SKEWFULL) THEN + CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, + $ CC, LDC, RESET, ZERO ) + ELSE + CALL SMAKE( 'SK', UPLO, ' ', N, N, C, NMAX, + $ CC, LDC, RESET, ZERO ) + END IF * NC = NC + 1 * @@ -1696,8 +1718,14 @@ SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC IF( REWI ) $ REWIND NTRA - CALL SSYR2K( UPLO, TRANS, N, K, ALPHA, AA, LDA, - $ BB, LDB, BETA, CC, LDC ) + IF(.NOT.SKEWFULL) THEN + CALL SSYR2K( UPLO, TRANS, N, K, ALPHA, AA, + $ LDA, BB, LDB, BETA, CC, LDC ) + ELSE + CALL SSKEWSYR2K( UPLO, TRANS, N, K, ALPHA, + $ AA, LDA, BB, LDB, BETA, CC, + $ LDC ) + END IF * * Check if error-exit was taken incorrectly. * @@ -1722,8 +1750,13 @@ SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, IF( NULL )THEN ISAME( 11 ) = LSE( CS, CC, LCC ) ELSE - ISAME( 11 ) = LSERES( 'SY', UPLO, N, N, CS, - $ CC, LDC ) + IF(.NOT.SKEWFULL) THEN + ISAME( 11 ) = LSERES( 'SY', UPLO, N, N, + $ CS, CC, LDC ) + ELSE + ISAME( 11 ) = LSERES( 'SK', UPLO, N, N, + $ CS, CC, LDC ) + END IF END IF ISAME( 12 ) = LDCS.EQ.LDC * @@ -1745,20 +1778,37 @@ SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * * Check the result column by column. * + IF( .NOT.SKEWFULL.OR.UPPER )THEN JJAB = 1 JC = 1 + ELSE + JJAB = 1 + 2*NMAX + JC = 2 + END IF DO 70 J = 1, N - IF( UPPER )THEN + IF( .NOT.SKEWFULL.AND.UPPER )THEN JJ = 1 LJ = J - ELSE + ELSE IF( .NOT.SKEWFULL.AND..NOT.UPPER ) + $ THEN JJ = J LJ = N - J + 1 + ELSE IF( SKEWFULL.AND.UPPER )THEN + JJ = 1 + LJ = J - 1 + ELSE + JJ = J + 1 + LJ = N - J END IF IF( TRAN )THEN DO 50 I = 1, K - W( I ) = AB( ( J - 1 )*2*NMAX + K + - $ I ) + IF(.NOT.SKEWFULL) THEN + W( I ) = AB( ( J - 1 )*2*NMAX + $ + K + I ) + ELSE + W( I ) = -AB( ( J - 1 )*2*NMAX + $ + K + I ) + END IF W( K + I ) = AB( ( J - 1 )*2*NMAX + $ I ) 50 CONTINUE @@ -1770,8 +1820,13 @@ SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NOUT, .TRUE. ) ELSE DO 60 I = 1, K - W( I ) = AB( ( K + I - 1 )*NMAX + - $ J ) + IF(.NOT.SKEWFULL) THEN + W( I ) = AB( ( K + I - 1 )*NMAX + $ + J ) + ELSE + W( I ) = -AB( ( K + I - 1 )*NMAX + $ + J ) + END IF W( K + I ) = AB( ( I - 1 )*NMAX + $ J ) 60 CONTINUE @@ -1830,16 +1885,16 @@ SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 160 CONTINUE RETURN * - 9999 FORMAT( ' ', A7, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A11, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A7, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A11, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A7, ' FAILED ON CALL NUMBER:' ) + 9996 FORMAT( ' ******* ', A11, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) - 9994 FORMAT( 1X, I6, ': ', A7, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), + 9994 FORMAT( 1X, I6, ': ', A11, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', $ ' .' ) 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', @@ -1868,7 +1923,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) * * .. Scalar Arguments .. INTEGER ISNUM, NOUT - CHARACTER*7 SRNAMT + CHARACTER*11 SRNAMT * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK @@ -1897,7 +1952,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) ALPHA = ONE BETA = TWO * - GO TO ( 10, 20, 30, 40, 50, 60, 70 )ISNUM + GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, 90 )ISNUM 10 INFOT = 1 CALL SGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -1982,7 +2037,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 13 CALL SGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 80 + GO TO 100 20 INFOT = 1 CALL SSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2049,7 +2104,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 12 CALL SSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 80 + GO TO 100 30 INFOT = 1 CALL STRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2158,7 +2213,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 11 CALL STRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 80 + GO TO 100 40 INFOT = 1 CALL STRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2267,7 +2322,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 11 CALL STRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 80 + GO TO 100 50 INFOT = 1 CALL SSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2322,7 +2377,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 10 CALL SSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 80 + GO TO 100 60 INFOT = 1 CALL SSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2389,7 +2444,7 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 12 CALL SSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) - GO TO 80 + GO TO 100 70 INFOT = 1 CALL SGEMMTR( '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) @@ -2468,16 +2523,150 @@ SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) INFOT = 13 CALL SGEMMTR( 'U', 'T', 'T', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + GO TO 100 + 80 INFOT = 1 + CALL SSKEWSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSKEWSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSKEWSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSKEWSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSKEWSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSKEWSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSKEWSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSKEWSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSKEWSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSKEWSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSKEWSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSKEWSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSKEWSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSKEWSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSKEWSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSKEWSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSKEWSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSKEWSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SSKEWSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SSKEWSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SSKEWSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SSKEWSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + GO TO 100 + 90 INFOT = 1 + CALL SSKEWSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSKEWSYR2K( 'U', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSKEWSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSKEWSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSKEWSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSKEWSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSKEWSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSKEWSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSKEWSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSKEWSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSKEWSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSKEWSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSKEWSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSKEWSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSKEWSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSKEWSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSKEWSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSKEWSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SSKEWSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SSKEWSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SSKEWSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SSKEWSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * - 80 IF( OK )THEN + 100 IF( OK )THEN WRITE( NOUT, FMT = 9999 )SRNAMT ELSE WRITE( NOUT, FMT = 9998 )SRNAMT END IF RETURN * - 9999 FORMAT( ' ', A7, ' PASSED THE TESTS OF ERROR-EXITS' ) - 9998 FORMAT( ' ******* ', A7, ' FAILED THE TESTS OF ERROR-EXITS *****', + 9999 FORMAT( ' ', A11, ' PASSED THE TESTS OF ERROR-EXITS' ) + 9998 FORMAT( ' ******* ', A11, ' FAILED THE TESTS OF ERROR-EXITS *****', $ '**' ) * * End of SCHKE @@ -2491,7 +2680,7 @@ SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, * Stores the values in the array AA in the data structure required * by the routine, with unwanted elements set to rogue value. * -* TYPE is 'GE', 'SY' or 'TR'. +* TYPE is 'GE', 'SY', 'SK' or 'TR'. * * Auxiliary routine for test program for Level 3 Blas. * @@ -2516,7 +2705,8 @@ SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, REAL A( NMAX, * ), AA( * ) * .. Local Scalars .. INTEGER I, IBEG, IEND, J - LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER + LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER, + $ SKEW * .. External Functions .. REAL SBEG EXTERNAL SBEG @@ -2524,8 +2714,9 @@ SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, GEN = TYPE.EQ.'GE' SYM = TYPE.EQ.'SY' TRI = TYPE.EQ.'TR' - UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' - LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' + SKEW = TYPE.EQ.'SK' + UPPER = ( SYM.OR.SKEW.OR.TRI ).AND.UPLO.EQ.'U' + LOWER = ( SYM.OR.SKEW.OR.TRI ).AND.UPLO.EQ.'L' UNIT = TRI.AND.DIAG.EQ.'U' * * Generate data in array A. @@ -2541,6 +2732,8 @@ SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, $ A( I, J ) = ZERO IF( SYM )THEN A( J, I ) = A( I, J ) + ELSE IF( SKEW )THEN + A( J, I ) = -A( I, J ) ELSE IF( TRI )THEN A( J, I ) = ZERO END IF @@ -2551,6 +2744,8 @@ SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, $ A( J, J ) = A( J, J ) + ONE IF( UNIT ) $ A( J, J ) = ONE + IF( SKEW ) + $ A( J, J ) = ZERO 20 CONTINUE * * Store elements in array AS in data structure required by routine. @@ -2564,17 +2759,17 @@ SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, AA( I + ( J - 1 )*LDA ) = ROGUE 40 CONTINUE 50 CONTINUE - ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN + ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'SK'.OR.TYPE.EQ.'TR' )THEN DO 90 J = 1, N IF( UPPER )THEN IBEG = 1 - IF( UNIT )THEN + IF( UNIT.OR.SKEW )THEN IEND = J - 1 ELSE IEND = J END IF ELSE - IF( UNIT )THEN + IF( UNIT.OR.SKEW )THEN IBEG = J + 1 ELSE IBEG = J @@ -2758,7 +2953,7 @@ LOGICAL FUNCTION LSERES( TYPE, UPLO, M, N, AA, AS, LDA ) * * Tests if selected elements in two arrays are equal. * -* TYPE is 'GE' or 'SY'. +* TYPE is 'GE' or 'SY' or 'SK'. * * Auxiliary routine for test program for Level 3 Blas. * @@ -2786,14 +2981,20 @@ LOGICAL FUNCTION LSERES( TYPE, UPLO, M, N, AA, AS, LDA ) $ GO TO 70 10 CONTINUE 20 CONTINUE - ELSE IF( TYPE.EQ.'SY' )THEN + ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'SK' )THEN DO 50 J = 1, N - IF( UPPER )THEN + IF( UPPER.AND.TYPE.EQ.'SY' )THEN IBEG = 1 IEND = J - ELSE + ELSE IF( .NOT.UPPER.AND.TYPE.EQ.'SY' )THEN IBEG = J IEND = N + ELSE IF( UPPER.AND.TYPE.EQ.'SK' )THEN + IBEG = 1 + IEND = J - 1 + ELSE + IBEG = J + 1 + IEND = N END IF DO 30 I = 1, IBEG - 1 IF( AA( I, J ).NE.AS( I, J ) ) @@ -2898,7 +3099,7 @@ SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * .. Scalar Arguments .. INTEGER INFOT, NOUT LOGICAL LERR, OK - CHARACTER*7 SRNAMT + CHARACTER*11 SRNAMT * .. Executable Statements .. IF( .NOT.LERR )THEN WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT @@ -2908,7 +3109,7 @@ SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) RETURN * 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', - $ 'ETECTED BY ', A7, ' *****' ) + $ 'ETECTED BY ', A11, ' *****' ) * * End of CHKXER * @@ -2939,7 +3140,7 @@ SUBROUTINE XERBLA( SRNAME, INFO ) * .. Scalars in Common .. INTEGER INFOT, NOUT LOGICAL LERR, OK - CHARACTER*7 SRNAMT + CHARACTER*11 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUT, OK, LERR COMMON /SRNAMC/SRNAMT @@ -2964,8 +3165,8 @@ SUBROUTINE XERBLA( SRNAME, INFO ) * 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', $ ' OF ', I2, ' *******' ) - 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A7, ' INSTE', - $ 'AD OF ', A7, ' *******' ) + 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A11, ' INSTE', + $ 'AD OF ', A11, ' *******' ) 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, $ ' *******' ) * @@ -2993,7 +3194,7 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE - CHARACTER*7 SNAME + CHARACTER*11 SNAME * .. Array Arguments .. REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), @@ -3242,15 +3443,15 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 130 CONTINUE RETURN * - 9999 FORMAT( ' ', A7, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', + 9999 FORMAT( ' ', A11, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) - 9997 FORMAT( ' ', A7, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', + 9997 FORMAT( ' ', A11, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) - 9996 FORMAT( ' ******* ', A7, ' FAILED ON CALL NUMBER:' ) - 9995 FORMAT( 1X, I6, ': ', A7, '(''',A1, ''',''',A1, ''',''', A1,''',', + 9996 FORMAT( ' ******* ', A11, ' FAILED ON CALL NUMBER:' ) + 9995 FORMAT( 1X, I6, ': ', A11, '(''',A1, ''',''',A1, ''',''', A1,''',', $ 2( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', $ 'C,', I3, ').' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', diff --git a/BLAS/TESTING/sblat3.in b/BLAS/TESTING/sblat3.in index ea1a305875..6aac3da81b 100644 --- a/BLAS/TESTING/sblat3.in +++ b/BLAS/TESTING/sblat3.in @@ -12,10 +12,12 @@ T LOGICAL FLAG, T TO TEST ERROR EXITS. 0.0 1.0 0.7 VALUES OF ALPHA 3 NUMBER OF VALUES OF BETA 0.0 1.0 1.3 VALUES OF BETA -SGEMM T PUT F FOR NO TEST. SAME COLUMNS. -SSYMM T PUT F FOR NO TEST. SAME COLUMNS. -STRMM T PUT F FOR NO TEST. SAME COLUMNS. -STRSM T PUT F FOR NO TEST. SAME COLUMNS. -SSYRK T PUT F FOR NO TEST. SAME COLUMNS. -SSYR2K T PUT F FOR NO TEST. SAME COLUMNS. -SGEMMTR T PUT F FOR NO TEST. SAME COLUMNS. +SGEMM T PUT F FOR NO TEST. SAME COLUMNS. +SSYMM T PUT F FOR NO TEST. SAME COLUMNS. +STRMM T PUT F FOR NO TEST. SAME COLUMNS. +STRSM T PUT F FOR NO TEST. SAME COLUMNS. +SSYRK T PUT F FOR NO TEST. SAME COLUMNS. +SSYR2K T PUT F FOR NO TEST. SAME COLUMNS. +SGEMMTR T PUT F FOR NO TEST. SAME COLUMNS. +SSKEWSYMM T PUT F FOR NO TEST. SAME COLUMNS. +SSKEWSYR2K T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/DOCS/groups-usr.dox b/DOCS/groups-usr.dox index 2756150a66..2f62b984b2 100644 --- a/DOCS/groups-usr.dox +++ b/DOCS/groups-usr.dox @@ -937,6 +937,9 @@ https://www.netlib.org/xblas/ @defgroup hemv {he,sy}mv: Hermitian/symmetric matrix-vector multiply ([cz]symv in LAPACK) @defgroup her {he,sy}r: Hermitian/symmetric rank-1 update @defgroup her2 {he,sy}r2: Hermitian/symmetric rank-2 update + + @defgroup skewhemv skew{he,sy}mv: skew-Hermitian/symmetric matrix-vector multiply ([cz]skewsymv in LAPACK) + @defgroup skewher2 skew{he,sy}r2: skew-Hermitian/symmetric rank-2 update @defgroup trmv trmv: triangular matrix-vector multiply @defgroup trsv trsv: triangular matrix-vector solve @@ -966,6 +969,9 @@ https://www.netlib.org/xblas/ @defgroup hemm {he,sy}mm: Hermitian/symmetric matrix-matrix multiply @defgroup herk {he,sy}rk: Hermitian/symmetric rank-k update @defgroup her2k {he,sy}r2k: Hermitian/symmetric rank-2k update + + @defgroup skewhemm skew{he,sy}mm: skew-Hermitian/symmetric matrix-matrix multiply + @defgroup skewher2k skew{he,sy}r2k: skew-Hermitian/symmetric rank-2k update @defgroup trmm trmm: triangular matrix-matrix multiply @defgroup trsm trsm: triangular matrix-matrix solve