diff --git a/BLAS/SRC/CMakeLists.txt b/BLAS/SRC/CMakeLists.txt index b9e6f7c4a..7e5f52c74 100644 --- a/BLAS/SRC/CMakeLists.txt +++ b/BLAS/SRC/CMakeLists.txt @@ -63,17 +63,17 @@ set(ALLBLAS lsame.f xerbla.f xerbla_array.f) #--------------------------------------------------------- # Level 2 BLAS #--------------------------------------------------------- -set(SBLAS2 sgemv.f sgbmv.f ssymv.f ssbmv.f sspmv.f +set(SBLAS2 sgemv.f sgbmv.f ssymv.f skymv.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 skyr2.f sspr2.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 cgerc.f cgeru.f cher.f chpr.f cher2.f chpr2.f) -set(DBLAS2 dgemv.f dgbmv.f dsymv.f dsbmv.f dspmv.f +set(DBLAS2 dgemv.f dgbmv.f dsymv.f dkymv.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 dkyr2.f dspr2.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 +82,12 @@ 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 skymm.f ssyrk.f ssyr2k.f skyr2k.f strmm.f strsm.f sgemmtr.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 dkymm.f dsyrk.f dsyr2k.f dkyr2k.f dtrmm.f dtrsm.f dgemmtr.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 486571fec..446659293 100644 --- a/BLAS/SRC/Makefile +++ b/BLAS/SRC/Makefile @@ -103,9 +103,9 @@ $(ALLBLAS): $(FRC) # Comment out the next 4 definitions if you already have # the Level 2 BLAS. #--------------------------------------------------------- -SBLAS2 = sgemv.o sgbmv.o ssymv.o ssbmv.o sspmv.o \ +SBLAS2 = sgemv.o sgbmv.o ssymv.o skymv.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 skyr2.o sspr2.o $(SBLAS2): $(FRC) CBLAS2 = cgemv.o cgbmv.o chemv.o chbmv.o chpmv.o \ @@ -113,9 +113,9 @@ CBLAS2 = cgemv.o cgbmv.o chemv.o chbmv.o chpmv.o \ cgerc.o cgeru.o cher.o chpr.o cher2.o chpr2.o $(CBLAS2): $(FRC) -DBLAS2 = dgemv.o dgbmv.o dsymv.o dsbmv.o dspmv.o \ +DBLAS2 = dgemv.o dgbmv.o dsymv.o dkymv.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 dkyr2.o dspr2.o $(DBLAS2): $(FRC) ZBLAS2 = zgemv.o zgbmv.o zhemv.o zhbmv.o zhpmv.o \ @@ -127,14 +127,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 \ + skymm.o skyr2k.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 \ + dkymm.o dkyr2k.o $(DBLAS3): $(FRC) ZBLAS3 = zgemm.o zsymm.o zsyrk.o zsyr2k.o ztrmm.o ztrsm.o \ diff --git a/BLAS/SRC/dkymm.f b/BLAS/SRC/dkymm.f new file mode 100644 index 000000000..1aab84fef --- /dev/null +++ b/BLAS/SRC/dkymm.f @@ -0,0 +1,364 @@ +*> \brief \b DKYMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DKYMM(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 +*> +*> DKYMM 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 kymm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DKYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- 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('DKYMM ',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 DKYMM +* + END diff --git a/BLAS/SRC/dkymv.f b/BLAS/SRC/dkymv.f new file mode 100644 index 000000000..4117ed1a1 --- /dev/null +++ b/BLAS/SRC/dkymv.f @@ -0,0 +1,328 @@ +*> \brief \b DKYMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DKYMV(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 +*> +*> DKYMV 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 kymv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DKYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* -- 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('DKYMV ',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 DKYMV +* + END diff --git a/BLAS/SRC/dkyr2.f b/BLAS/SRC/dkyr2.f new file mode 100644 index 000000000..18b143fea --- /dev/null +++ b/BLAS/SRC/dkyr2.f @@ -0,0 +1,295 @@ +*> \brief \b DKYR2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DKYR2(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 +*> +*> DKYR2 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 kyr2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DKYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* -- 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('DKYR2 ',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 DKYR2 +* + END diff --git a/BLAS/SRC/dkyr2k.f b/BLAS/SRC/dkyr2k.f new file mode 100644 index 000000000..292963138 --- /dev/null +++ b/BLAS/SRC/dkyr2k.f @@ -0,0 +1,396 @@ +*> \brief \b DKYR2K +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DKYR2K(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 +*> +*> DKYR2K 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 kyr2k +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DKYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- 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('DKYR2K',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 DKYR2K +* + END diff --git a/BLAS/SRC/skymm.f b/BLAS/SRC/skymm.f new file mode 100644 index 000000000..140379869 --- /dev/null +++ b/BLAS/SRC/skymm.f @@ -0,0 +1,365 @@ +*> \brief \b SKYMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SKYMM(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 +*> +*> SKYMM 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 kymm +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SKYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- 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('SKYMM ',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 SKYMM +* + END diff --git a/BLAS/SRC/skymv.f b/BLAS/SRC/skymv.f new file mode 100644 index 000000000..e92962d7f --- /dev/null +++ b/BLAS/SRC/skymv.f @@ -0,0 +1,328 @@ +*> \brief \b SKYMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SKYMV(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 +*> +*> SKYMV 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 kymv +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> The vector and matrix arguments are not referenced when N = 0, or M = 0 +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SKYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* -- 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('SKYMV ',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 SKYMV +* + END diff --git a/BLAS/SRC/skyr2.f b/BLAS/SRC/skyr2.f new file mode 100644 index 000000000..0e1653717 --- /dev/null +++ b/BLAS/SRC/skyr2.f @@ -0,0 +1,295 @@ +*> \brief \b SKYR2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SKYR2(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 +*> +*> SKYR2 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 kyr2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 2 Blas routine. +*> +*> -- Written on 22-October-1986. +*> Jack Dongarra, Argonne National Lab. +*> Jeremy Du Croz, Nag Central Office. +*> Sven Hammarling, Nag Central Office. +*> Richard Hanson, Sandia National Labs. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SKYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* -- 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('SKYR2 ',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 SKYR2 +* + END diff --git a/BLAS/SRC/skyr2k.f b/BLAS/SRC/skyr2k.f new file mode 100644 index 000000000..97fe7f613 --- /dev/null +++ b/BLAS/SRC/skyr2k.f @@ -0,0 +1,396 @@ +*> \brief \b SKYR2K +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SKYR2K(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 +*> +*> SKYR2K 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 kyr2k +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SKYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- 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('SKYR2K',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 SKYR2K +* + END diff --git a/BLAS/TESTING/dblat2.f b/BLAS/TESTING/dblat2.f index 15d712499..331a9273e 100644 --- a/BLAS/TESTING/dblat2.f +++ b/BLAS/TESTING/dblat2.f @@ -110,7 +110,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 @@ -157,7 +157,8 @@ PROGRAM DBLAT2 DATA SNAMES/'DGEMV ', 'DGBMV ', 'DSYMV ', 'DSBMV ', $ 'DSPMV ', 'DTRMV ', 'DTBMV ', 'DTPMV ', $ 'DTRSV ', 'DTBSV ', 'DTPSV ', 'DGER ', - $ 'DSYR ', 'DSPR ', 'DSYR2 ', 'DSPR2 '/ + $ 'DSYR ', 'DSPR ', 'DSYR2 ', 'DSPR2 ', + $ 'DKYMV ', 'DKYR2 '/ * .. Executable Statements .. * * Read name and unit number for summary output file and open file. @@ -333,14 +334,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 DKYMV, 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, @@ -364,7 +365,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 DKYR2, 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, @@ -798,7 +799,7 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, $ XS, Y, YY, YS, YT, G ) * -* Tests DSYMV, DSBMV and DSPMV. +* Tests DSYMV, DKYMV, DSBMV and DSPMV. * * Auxiliary routine for test program for Level 2 Blas. * @@ -828,7 +829,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, + $ KYFULL CHARACTER*1 UPLO, UPLOS CHARACTER*2 ICH * .. Local Arrays .. @@ -837,7 +839,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, DKYMV * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. Scalars in Common .. @@ -848,11 +850,12 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * .. Data statements .. DATA ICH/'UL'/ * .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'Y' + FULL = SNAME( 2: 2 ).NE.'K'.AND.SNAME( 3: 3 ).EQ.'Y' BANDED = SNAME( 3: 3 ).EQ.'B' PACKED = SNAME( 3: 3 ).EQ.'P' + KYFULL = SNAME( 2: 2 ).EQ.'K' * Define the number of arguments. - IF( FULL )THEN + IF( FULL.OR.KYFULL )THEN NARGS = 10 ELSE IF( BANDED )THEN NARGS = 11 @@ -968,6 +971,14 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, IF( REWI ) $ REWIND NTRA CALL DSYMV( UPLO, N, ALPHA, AA, LDA, XX, + $ INCX, BETA, YY, INCY ) + ELSE IF( KYFULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, + $ UPLO, N, ALPHA, LDA, INCX, BETA, INCY + IF( REWI ) + $ REWIND NTRA + CALL DKYMV( UPLO, N, ALPHA, AA, LDA, XX, $ INCX, BETA, YY, INCY ) ELSE IF( BANDED )THEN IF( TRACE ) @@ -1000,7 +1011,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.KYFULL )THEN ISAME( 3 ) = ALS.EQ.ALPHA ISAME( 4 ) = LDE( AS, AA, LAA ) ISAME( 5 ) = LDAS.EQ.LDA @@ -2037,7 +2048,7 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, $ Z ) * -* Tests DSYR2 and DSPR2. +* Tests DSYR2, DKYR2 and DSPR2. * * Auxiliary routine for test program for Level 2 Blas. * @@ -2065,7 +2076,7 @@ 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, KYFULL CHARACTER*1 UPLO, UPLOS CHARACTER*2 ICH * .. Local Arrays .. @@ -2075,7 +2086,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, DKYR2 * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. Scalars in Common .. @@ -2086,10 +2097,11 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * .. Data statements .. DATA ICH/'UL'/ * .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'Y' + FULL = SNAME( 2: 2 ).NE.'K'.AND.SNAME( 3: 3 ).EQ.'Y' PACKED = SNAME( 3: 3 ).EQ.'P' + KYFULL = SNAME( 2: 2 ).EQ.'K' * Define the number of arguments. - IF( FULL )THEN + IF( FULL.OR.KYFULL )THEN NARGS = 9 ELSE IF( PACKED )THEN NARGS = 8 @@ -2186,6 +2198,14 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, IF( REWI ) $ REWIND NTRA CALL DSYR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, + $ AA, LDA ) + ELSE IF( KYFULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, + $ ALPHA, INCX, INCY, LDA + IF( REWI ) + $ REWIND NTRA + CALL DKYR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, $ AA, LDA ) ELSE IF( PACKED )THEN IF( TRACE ) @@ -2259,22 +2279,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.KYFULL.OR.UPPER )THEN + JA = 1 + ELSE + JA = 2 + END IF DO 90 J = 1, N - W( 1 ) = Z( J, 2 ) + IF( .NOT.KYFULL )THEN + W( 1 ) = Z( J, 2 ) + ELSE + W( 1 ) = -Z( J, 2 ) + END IF W( 2 ) = Z( J, 1 ) - IF( UPPER )THEN + IF( .NOT.KYFULL.AND.UPPER )THEN JJ = 1 LJ = J - ELSE + ELSE IF( .NOT.KYFULL.AND..NOT.UPPER )THEN JJ = J LJ = N - J + 1 + ELSE IF( KYFULL.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.KYFULL )THEN IF( UPPER )THEN JA = JA + LDA ELSE @@ -2318,7 +2352,7 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * 160 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN + IF( FULL.OR.KYFULL )THEN WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, $ INCY, LDA ELSE IF( PACKED )THEN @@ -2384,7 +2418,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 ) @@ -2403,7 +2437,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 ) @@ -2428,7 +2462,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 ) @@ -2444,7 +2478,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 ) @@ -2463,7 +2497,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 ) @@ -2476,7 +2510,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 ) @@ -2495,7 +2529,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 ) @@ -2517,7 +2551,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 ) @@ -2533,7 +2567,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 ) @@ -2552,7 +2586,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 ) @@ -2574,7 +2608,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 ) @@ -2590,7 +2624,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 ) @@ -2606,7 +2640,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 ) @@ -2619,7 +2653,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 ) @@ -2629,7 +2663,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 ) @@ -2645,7 +2679,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 ) @@ -2658,8 +2692,40 @@ 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 DKYMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DKYMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DKYMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DKYMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DKYMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + GO TO 190 + 180 INFOT = 1 + CALL DKYR2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DKYR2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DKYR2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DKYR2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DKYR2( '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 @@ -2681,7 +2747,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', 'KY', 'TR', 'TB' OR 'TP'. * * Auxiliary routine for test program for Level 2 Blas. * @@ -2704,7 +2770,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, + $ SKY * .. External Functions .. DOUBLE PRECISION DBEG EXTERNAL DBEG @@ -2713,9 +2780,10 @@ SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, * .. Executable Statements .. GEN = TYPE( 1: 1 ).EQ.'G' SYM = TYPE( 1: 1 ).EQ.'S' + SKY = TYPE( 1: 1 ).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.SKY.OR.TRI ).AND.UPLO.EQ.'U' + LOWER = ( SYM.OR.SKY.OR.TRI ).AND.UPLO.EQ.'L' UNIT = TRI.AND.DIAG.EQ.'U' * * Generate data in array A. @@ -2733,6 +2801,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( SKY )THEN + A( J, I ) = -A( I, J ) ELSE IF( TRI )THEN A( J, I ) = ZERO END IF @@ -2743,6 +2813,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( SKY ) + $ A( J, J ) = ZERO 20 CONTINUE * * Store elements in array AS in data structure required by routine. @@ -2768,17 +2840,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.'KY'.OR.TYPE.EQ.'TR' )THEN DO 130 J = 1, N IF( UPPER )THEN IBEG = 1 - IF( UNIT )THEN + IF( UNIT.OR.SKY )THEN IEND = J - 1 ELSE IEND = J END IF ELSE - IF( UNIT )THEN + IF( UNIT.OR.SKY )THEN IBEG = J + 1 ELSE IBEG = J @@ -3026,14 +3098,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.'KY' )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.'KY' )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 ) ) diff --git a/BLAS/TESTING/dblat2.in b/BLAS/TESTING/dblat2.in index d436350a4..fa059a3e8 100644 --- a/BLAS/TESTING/dblat2.in +++ b/BLAS/TESTING/dblat2.in @@ -32,3 +32,5 @@ 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. +DKYMV T PUT F FOR NO TEST. SAME COLUMNS. +DKYR2 T PUT F FOR NO TEST. SAME COLUMNS. \ No newline at end of file diff --git a/BLAS/TESTING/dblat3.f b/BLAS/TESTING/dblat3.f index e95da164a..a18efba9d 100644 --- a/BLAS/TESTING/dblat3.f +++ b/BLAS/TESTING/dblat3.f @@ -19,7 +19,7 @@ *> 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 +*> of the file are read using list-directed input, the last 9 records *> are read using the format ( A6, L2 ). An annotated example of a data *> file can be obtained by deleting the first 3 characters from the *> following 21 lines: @@ -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. +*> DKYRK T PUT F FOR NO TEST. SAME COLUMNS. +*> DKYR2K T PUT F FOR NO TEST. SAME COLUMNS. *> *> Further Details *> =============== @@ -91,7 +93,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 @@ -133,7 +135,8 @@ PROGRAM DBLAT3 COMMON /SRNAMC/SRNAMT * .. Data statements .. DATA SNAMES/'DGEMM ', 'DSYMM ', 'DTRMM ', 'DTRSM ', - $ 'DSYRK ', 'DSYR2K', 'DGEMMTR'/ + $ 'DSYRK ', 'DSYR2K', 'DGEMMTR', + $ 'DKYMM ', 'DKYR2K '/ * .. Executable Statements .. * * Read name and unit number for summary output file and open file. @@ -310,14 +313,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, DKYMM, 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, @@ -334,7 +337,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, DKYR2K, 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 ) @@ -711,7 +714,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, KYFULL CHARACTER*1 SIDE, SIDES, UPLO, UPLOS CHARACTER*2 ICHS, ICHU * .. Local Arrays .. @@ -720,7 +723,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, DKYMM * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. @@ -732,6 +735,7 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DATA ICHS/'LR'/, ICHU/'UL'/ * .. Executable Statements .. * + KYFULL = SNAME( 2: 2 ).EQ.'K' NARGS = 12 NC = 0 RESET = .TRUE. @@ -789,8 +793,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.KYFULL) THEN + CALL DMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, + $ LDA, RESET, ZERO ) + ELSE + CALL DMAKE( 'KY', UPLO, ' ', NA, NA, A, NMAX, AA, + $ LDA, RESET, ZERO ) + END IF * DO 60 IA = 1, NALF ALPHA = ALF( IA ) @@ -834,8 +843,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.KYFULL) THEN + CALL DSYMM( SIDE, UPLO, M, N, ALPHA, AA, + $ LDA, BB, LDB, BETA, CC, LDC ) + ELSE + CALL DKYMM( SIDE, UPLO, M, N, ALPHA, AA, + $ LDA, BB, LDB, BETA, CC, LDC ) + END IF * * Check if error-exit was taken incorrectly. * @@ -1561,7 +1575,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, KYFULL CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS CHARACTER*2 ICHU CHARACTER*3 ICHT @@ -1571,7 +1585,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, DKYR2K * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. @@ -1583,6 +1597,7 @@ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DATA ICHT/'NTC'/, ICHU/'UL'/ * .. Executable Statements .. * + KYFULL = SNAME( 2: 2 ).EQ.'K' NARGS = 12 NC = 0 RESET = .TRUE. @@ -1656,8 +1671,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.KYFULL) THEN + CALL DMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, + $ CC, LDC, RESET, ZERO ) + ELSE + CALL DMAKE( 'KY', UPLO, ' ', N, N, C, NMAX, + $ CC, LDC, RESET, ZERO ) + END IF * NC = NC + 1 * @@ -1689,8 +1709,13 @@ 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.KYFULL) THEN + CALL DSYR2K( UPLO, TRANS, N, K, ALPHA, AA, + $ LDA, BB, LDB, BETA, CC, LDC ) + ELSE + CALL DKYR2K( UPLO, TRANS, N, K, ALPHA, AA, + $ LDA, BB, LDB, BETA, CC, LDC ) + END IF * * Check if error-exit was taken incorrectly. * @@ -1715,8 +1740,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.KYFULL) THEN + ISAME( 11 ) = LDERES( 'SY', UPLO, N, N, + $ CS, CC, LDC ) + ELSE + ISAME( 11 ) = LDERES( 'KY', UPLO, N, N, + $ CS, CC, LDC ) + END IF END IF ISAME( 12 ) = LDCS.EQ.LDC * @@ -1738,20 +1768,36 @@ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * * Check the result column by column. * + IF( .NOT.KYFULL.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.KYFULL.AND.UPPER )THEN JJ = 1 LJ = J - ELSE + ELSE IF( .NOT.KYFULL.AND..NOT.UPPER )THEN JJ = J LJ = N - J + 1 + ELSE IF( KYFULL.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.KYFULL) 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 @@ -1763,8 +1809,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.KYFULL) 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 @@ -1889,7 +1940,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 ) @@ -1974,7 +2025,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 ) @@ -2041,7 +2092,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 ) @@ -2150,7 +2201,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 ) @@ -2259,7 +2310,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 ) @@ -2314,7 +2365,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 ) @@ -2381,7 +2432,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 ) @@ -2460,8 +2511,142 @@ 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 DKYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DKYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DKYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DKYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DKYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DKYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DKYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DKYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DKYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DKYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DKYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DKYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DKYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DKYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DKYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DKYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DKYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DKYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DKYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DKYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DKYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DKYMM( '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 DKYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DKYR2K( 'U', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DKYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DKYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DKYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DKYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DKYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DKYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DKYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DKYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DKYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DKYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DKYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DKYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DKYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DKYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DKYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DKYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DKYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DKYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DKYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DKYR2K( '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 @@ -2482,7 +2667,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', 'KY' or 'TR'. * * Auxiliary routine for test program for Level 3 Blas. * @@ -2507,7 +2692,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, + $ SKY * .. External Functions .. DOUBLE PRECISION DBEG EXTERNAL DBEG @@ -2515,8 +2701,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' + SKY = TYPE.EQ.'KY' + UPPER = ( SYM.OR.SKY.OR.TRI ).AND.UPLO.EQ.'U' + LOWER = ( SYM.OR.SKY.OR.TRI ).AND.UPLO.EQ.'L' UNIT = TRI.AND.DIAG.EQ.'U' * * Generate data in array A. @@ -2532,6 +2719,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( SKY )THEN + A( J, I ) = -A( I, J ) ELSE IF( TRI )THEN A( J, I ) = ZERO END IF @@ -2542,6 +2731,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( SKY ) + $ A( J, J ) = ZERO 20 CONTINUE * * Store elements in array AS in data structure required by routine. @@ -2555,17 +2746,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.'KY'.OR.TYPE.EQ.'TR' )THEN DO 90 J = 1, N IF( UPPER )THEN IBEG = 1 - IF( UNIT )THEN + IF( UNIT.OR.SKY )THEN IEND = J - 1 ELSE IEND = J END IF ELSE - IF( UNIT )THEN + IF( UNIT.OR.SKY )THEN IBEG = J + 1 ELSE IBEG = J @@ -2746,7 +2937,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 'KY'. * * Auxiliary routine for test program for Level 3 Blas. * @@ -2774,14 +2965,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.'KY' )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.'KY' )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 ) ) diff --git a/BLAS/TESTING/dblat3.in b/BLAS/TESTING/dblat3.in index 30b74c6e4..41abdd814 100644 --- a/BLAS/TESTING/dblat3.in +++ b/BLAS/TESTING/dblat3.in @@ -19,3 +19,5 @@ 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. +DKYMM T PUT F FOR NO TEST. SAME COLUMNS. +DKYR2K T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/BLAS/TESTING/sblat2.f b/BLAS/TESTING/sblat2.f index 01b5c357f..23afeeff0 100644 --- a/BLAS/TESTING/sblat2.f +++ b/BLAS/TESTING/sblat2.f @@ -110,7 +110,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 @@ -157,7 +157,8 @@ PROGRAM SBLAT2 DATA SNAMES/'SGEMV ', 'SGBMV ', 'SSYMV ', 'SSBMV ', $ 'SSPMV ', 'STRMV ', 'STBMV ', 'STPMV ', $ 'STRSV ', 'STBSV ', 'STPSV ', 'SGER ', - $ 'SSYR ', 'SSPR ', 'SSYR2 ', 'SSPR2 '/ + $ 'SSYR ', 'SSPR ', 'SSYR2 ', 'SSPR2 ', + $ 'SKYMV ', 'SKYR2 '/ * .. Executable Statements .. * * Read name and unit number for summary output file and open file. @@ -333,14 +334,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 SKYMV, 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, @@ -364,7 +365,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 SKYR2, 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, @@ -798,7 +799,7 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, $ XS, Y, YY, YS, YT, G ) * -* Tests SSYMV, SSBMV and SSPMV. +* Tests SSYMV, SKYMV, SSBMV and SSPMV. * * Auxiliary routine for test program for Level 2 Blas. * @@ -828,7 +829,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, + $ KYFULL CHARACTER*1 UPLO, UPLOS CHARACTER*2 ICH * .. Local Arrays .. @@ -837,7 +839,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, SKYMV * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. Scalars in Common .. @@ -848,11 +850,12 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * .. Data statements .. DATA ICH/'UL'/ * .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'Y' + FULL = SNAME( 2: 2 ).NE.'K'.AND.SNAME( 3: 3 ).EQ.'Y' BANDED = SNAME( 3: 3 ).EQ.'B' PACKED = SNAME( 3: 3 ).EQ.'P' + KYFULL = SNAME( 2: 2 ).EQ.'K' * Define the number of arguments. - IF( FULL )THEN + IF( FULL.OR.KYFULL )THEN NARGS = 10 ELSE IF( BANDED )THEN NARGS = 11 @@ -968,6 +971,14 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, IF( REWI ) $ REWIND NTRA CALL SSYMV( UPLO, N, ALPHA, AA, LDA, XX, + $ INCX, BETA, YY, INCY ) + ELSE IF( KYFULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, + $ UPLO, N, ALPHA, LDA, INCX, BETA, INCY + IF( REWI ) + $ REWIND NTRA + CALL SKYMV( UPLO, N, ALPHA, AA, LDA, XX, $ INCX, BETA, YY, INCY ) ELSE IF( BANDED )THEN IF( TRACE ) @@ -1000,7 +1011,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.KYFULL )THEN ISAME( 3 ) = ALS.EQ.ALPHA ISAME( 4 ) = LSE( AS, AA, LAA ) ISAME( 5 ) = LDAS.EQ.LDA @@ -2037,7 +2048,7 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, $ Z ) * -* Tests SSYR2 and SSPR2. +* Tests SSYR2, SKYR2 and SSPR2. * * Auxiliary routine for test program for Level 2 Blas. * @@ -2065,7 +2076,7 @@ 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, KYFULL CHARACTER*1 UPLO, UPLOS CHARACTER*2 ICH * .. Local Arrays .. @@ -2075,7 +2086,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, SKYR2 * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. Scalars in Common .. @@ -2086,10 +2097,11 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * .. Data statements .. DATA ICH/'UL'/ * .. Executable Statements .. - FULL = SNAME( 3: 3 ).EQ.'Y' + FULL = SNAME( 2: 2 ).NE.'K'.AND.SNAME( 3: 3 ).EQ.'Y' PACKED = SNAME( 3: 3 ).EQ.'P' + KYFULL = SNAME( 2: 2 ).EQ.'K' * Define the number of arguments. - IF( FULL )THEN + IF( FULL.OR.KYFULL )THEN NARGS = 9 ELSE IF( PACKED )THEN NARGS = 8 @@ -2186,6 +2198,14 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, IF( REWI ) $ REWIND NTRA CALL SSYR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, + $ AA, LDA ) + ELSE IF( KYFULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, + $ ALPHA, INCX, INCY, LDA + IF( REWI ) + $ REWIND NTRA + CALL SKYR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, $ AA, LDA ) ELSE IF( PACKED )THEN IF( TRACE ) @@ -2259,22 +2279,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.KYFULL.OR.UPPER )THEN + JA = 1 + ELSE + JA = 2 + END IF DO 90 J = 1, N - W( 1 ) = Z( J, 2 ) + IF( .NOT.KYFULL )THEN + W( 1 ) = Z( J, 2 ) + ELSE + W( 1 ) = -Z( J, 2 ) + END IF W( 2 ) = Z( J, 1 ) - IF( UPPER )THEN + IF( .NOT.KYFULL.AND.UPPER )THEN JJ = 1 LJ = J - ELSE + ELSE IF( .NOT.KYFULL.AND..NOT.UPPER )THEN JJ = J LJ = N - J + 1 + ELSE IF( KYFULL.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.KYFULL )THEN IF( UPPER )THEN JA = JA + LDA ELSE @@ -2318,7 +2352,7 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * 160 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN + IF( FULL.OR.KYFULL )THEN WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, $ INCY, LDA ELSE IF( PACKED )THEN @@ -2384,7 +2418,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 ) @@ -2403,7 +2437,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 ) @@ -2428,7 +2462,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 ) @@ -2444,7 +2478,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 ) @@ -2463,7 +2497,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 ) @@ -2476,7 +2510,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 ) @@ -2495,7 +2529,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 ) @@ -2517,7 +2551,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 ) @@ -2533,7 +2567,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 ) @@ -2552,7 +2586,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 ) @@ -2574,7 +2608,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 ) @@ -2590,7 +2624,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 ) @@ -2606,7 +2640,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 ) @@ -2619,7 +2653,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 ) @@ -2629,7 +2663,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 ) @@ -2645,7 +2679,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 ) @@ -2658,8 +2692,40 @@ 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 SKYMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SKYMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SKYMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SKYMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SKYMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + GO TO 190 + 180 INFOT = 1 + CALL SKYR2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SKYR2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SKYR2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SKYR2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SKYR2( '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 @@ -2681,7 +2747,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', 'KY', 'TR', 'TB' OR 'TP'. * * Auxiliary routine for test program for Level 2 Blas. * @@ -2704,7 +2770,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, + $ SKY * .. External Functions .. REAL SBEG EXTERNAL SBEG @@ -2713,9 +2780,10 @@ SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, * .. Executable Statements .. GEN = TYPE( 1: 1 ).EQ.'G' SYM = TYPE( 1: 1 ).EQ.'S' + SKY = TYPE( 1: 1 ).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.SKY.OR.TRI ).AND.UPLO.EQ.'U' + LOWER = ( SYM.OR.SKY.OR.TRI ).AND.UPLO.EQ.'L' UNIT = TRI.AND.DIAG.EQ.'U' * * Generate data in array A. @@ -2733,6 +2801,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( SKY )THEN + A( J, I ) = -A( I, J ) ELSE IF( TRI )THEN A( J, I ) = ZERO END IF @@ -2743,6 +2813,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( SKY ) + $ A( J, J ) = ZERO 20 CONTINUE * * Store elements in array AS in data structure required by routine. @@ -2768,17 +2840,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.'KY'.OR.TYPE.EQ.'TR' )THEN DO 130 J = 1, N IF( UPPER )THEN IBEG = 1 - IF( UNIT )THEN + IF( UNIT.OR.SKY )THEN IEND = J - 1 ELSE IEND = J END IF ELSE - IF( UNIT )THEN + IF( UNIT.OR.SKY )THEN IBEG = J + 1 ELSE IBEG = J @@ -3026,14 +3098,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.'KY' )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.'KY' )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 ) ) diff --git a/BLAS/TESTING/sblat2.in b/BLAS/TESTING/sblat2.in index fefc7e958..c0c1d9b3b 100644 --- a/BLAS/TESTING/sblat2.in +++ b/BLAS/TESTING/sblat2.in @@ -32,3 +32,5 @@ 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. +SKYMV T PUT F FOR NO TEST. SAME COLUMNS. +SKYR2 T PUT F FOR NO TEST. SAME COLUMNS. \ No newline at end of file diff --git a/BLAS/TESTING/sblat3.f b/BLAS/TESTING/sblat3.f index d5c2aa7ed..1a9df74f9 100644 --- a/BLAS/TESTING/sblat3.f +++ b/BLAS/TESTING/sblat3.f @@ -19,7 +19,7 @@ *> 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 +*> of the file are read using list-directed input, the last 9 records *> are read using the format ( A7, L2 ). An annotated example of a data *> file can be obtained by deleting the first 3 characters from the *> following 20 lines: @@ -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. +*> SKYRK T PUT F FOR NO TEST. SAME COLUMNS. +*> SKYR2K T PUT F FOR NO TEST. SAME COLUMNS. *> *> Further Details *> =============== @@ -91,7 +93,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 @@ -133,7 +135,8 @@ PROGRAM SBLAT3 COMMON /SRNAMC/SRNAMT * .. Data statements .. DATA SNAMES/'SGEMM', 'SSYMM ', 'STRMM ', - $ 'STRSM ', 'SSYRK ', 'SSYR2K ', 'SGEMMTR'/ + $ 'STRSM ', 'SSYRK ', 'SSYR2K ', 'SGEMMTR', + $ 'SKYMM ', 'SKYR2K '/ * .. Executable Statements .. * * Read name and unit number for summary output file and open file. @@ -310,14 +313,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, SKYMM, 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, @@ -334,7 +337,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, SKYR2K, 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 ) @@ -711,7 +714,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, KYFULL CHARACTER*1 SIDE, SIDES, UPLO, UPLOS CHARACTER*2 ICHS, ICHU * .. Local Arrays .. @@ -720,7 +723,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, SKYMM * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. @@ -732,6 +735,7 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DATA ICHS/'LR'/, ICHU/'UL'/ * .. Executable Statements .. * + KYFULL = SNAME( 2: 2 ).EQ.'K' NARGS = 12 NC = 0 RESET = .TRUE. @@ -789,8 +793,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.KYFULL) THEN + CALL SMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, + $ LDA, RESET, ZERO ) + ELSE + CALL SMAKE( 'KY', UPLO, ' ', NA, NA, A, NMAX, AA, + $ LDA, RESET, ZERO ) + END IF * DO 60 IA = 1, NALF ALPHA = ALF( IA ) @@ -834,8 +843,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.KYFULL) THEN + CALL SSYMM( SIDE, UPLO, M, N, ALPHA, AA, + $ LDA, BB, LDB, BETA, CC, LDC ) + ELSE + CALL SKYMM( SIDE, UPLO, M, N, ALPHA, AA, + $ LDA, BB, LDB, BETA, CC, LDC ) + END IF * * Check if error-exit was taken incorrectly. * @@ -1561,7 +1575,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, KYFULL CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS CHARACTER*2 ICHU CHARACTER*3 ICHT @@ -1571,7 +1585,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, SKYR2K * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. @@ -1583,6 +1597,7 @@ SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DATA ICHT/'NTC'/, ICHU/'UL'/ * .. Executable Statements .. * + KYFULL = SNAME( 2: 2 ).EQ.'K' NARGS = 12 NC = 0 RESET = .TRUE. @@ -1656,8 +1671,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.KYFULL) THEN + CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, + $ CC, LDC, RESET, ZERO ) + ELSE + CALL SMAKE( 'KY', UPLO, ' ', N, N, C, NMAX, + $ CC, LDC, RESET, ZERO ) + END IF * NC = NC + 1 * @@ -1689,8 +1709,13 @@ 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.KYFULL) THEN + CALL SSYR2K( UPLO, TRANS, N, K, ALPHA, AA, + $ LDA, BB, LDB, BETA, CC, LDC ) + ELSE + CALL SKYR2K( UPLO, TRANS, N, K, ALPHA, AA, + $ LDA, BB, LDB, BETA, CC, LDC ) + END IF * * Check if error-exit was taken incorrectly. * @@ -1715,8 +1740,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.KYFULL) THEN + ISAME( 11 ) = LSERES( 'SY', UPLO, N, N, + $ CS, CC, LDC ) + ELSE + ISAME( 11 ) = LSERES( 'KY', UPLO, N, N, + $ CS, CC, LDC ) + END IF END IF ISAME( 12 ) = LDCS.EQ.LDC * @@ -1738,20 +1768,36 @@ SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * * Check the result column by column. * + IF( .NOT.KYFULL.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.KYFULL.AND.UPPER )THEN JJ = 1 LJ = J - ELSE + ELSE IF( .NOT.KYFULL.AND..NOT.UPPER )THEN JJ = J LJ = N - J + 1 + ELSE IF( KYFULL.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.KYFULL) 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 @@ -1763,8 +1809,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.KYFULL) 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 @@ -1889,7 +1940,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 ) @@ -1974,7 +2025,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 ) @@ -2041,7 +2092,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 ) @@ -2150,7 +2201,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 ) @@ -2259,7 +2310,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 ) @@ -2314,7 +2365,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 ) @@ -2381,7 +2432,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 ) @@ -2460,8 +2511,142 @@ 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 SKYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SKYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SKYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SKYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SKYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SKYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SKYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SKYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SKYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SKYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SKYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SKYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SKYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SKYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SKYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SKYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SKYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SKYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SKYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SKYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SKYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SKYMM( '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 SKYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SKYR2K( 'U', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SKYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SKYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SKYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SKYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SKYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SKYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SKYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SKYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SKYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SKYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SKYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SKYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SKYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SKYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SKYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SKYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SKYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SKYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SKYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) + CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SKYR2K( '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 @@ -2482,7 +2667,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', 'KY' or 'TR'. * * Auxiliary routine for test program for Level 3 Blas. * @@ -2507,7 +2692,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, + $ SKY * .. External Functions .. REAL SBEG EXTERNAL SBEG @@ -2515,8 +2701,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' + SKY = TYPE.EQ.'KY' + UPPER = ( SYM.OR.SKY.OR.TRI ).AND.UPLO.EQ.'U' + LOWER = ( SYM.OR.SKY.OR.TRI ).AND.UPLO.EQ.'L' UNIT = TRI.AND.DIAG.EQ.'U' * * Generate data in array A. @@ -2532,6 +2719,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( SKY )THEN + A( J, I ) = -A( I, J ) ELSE IF( TRI )THEN A( J, I ) = ZERO END IF @@ -2542,6 +2731,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( SKY ) + $ A( J, J ) = ZERO 20 CONTINUE * * Store elements in array AS in data structure required by routine. @@ -2555,17 +2746,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.'KY'.OR.TYPE.EQ.'TR' )THEN DO 90 J = 1, N IF( UPPER )THEN IBEG = 1 - IF( UNIT )THEN + IF( UNIT.OR.SKY )THEN IEND = J - 1 ELSE IEND = J END IF ELSE - IF( UNIT )THEN + IF( UNIT.OR.SKY )THEN IBEG = J + 1 ELSE IBEG = J @@ -2746,7 +2937,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 'KY'. * * Auxiliary routine for test program for Level 3 Blas. * @@ -2774,14 +2965,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.'KY' )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.'KY' )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 ) ) diff --git a/BLAS/TESTING/sblat3.in b/BLAS/TESTING/sblat3.in index ea1a30587..ff638286a 100644 --- a/BLAS/TESTING/sblat3.in +++ b/BLAS/TESTING/sblat3.in @@ -19,3 +19,5 @@ 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. +SKYMM T PUT F FOR NO TEST. SAME COLUMNS. +SKYR2K T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/CBLAS/include/cblas.h b/CBLAS/include/cblas.h index b8baf4eca..01f78acca 100644 --- a/CBLAS/include/cblas.h +++ b/CBLAS/include/cblas.h @@ -338,6 +338,10 @@ void cblas_ssymv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const CBLAS_INT N, const float alpha, const float *A, const CBLAS_INT lda, const float *X, const CBLAS_INT incX, const float beta, float *Y, const CBLAS_INT incY); +void cblas_skymv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const CBLAS_INT N, const float alpha, const float *A, + const CBLAS_INT lda, const float *X, const CBLAS_INT incX, + const float beta, float *Y, const CBLAS_INT incY); void cblas_ssbmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const CBLAS_INT N, const CBLAS_INT K, const float alpha, const float *A, const CBLAS_INT lda, const float *X, const CBLAS_INT incX, @@ -359,6 +363,10 @@ void cblas_ssyr2(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const CBLAS_INT N, const float alpha, const float *X, const CBLAS_INT incX, const float *Y, const CBLAS_INT incY, float *A, const CBLAS_INT lda); +void cblas_skyr2(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const CBLAS_INT N, const float alpha, const float *X, + const CBLAS_INT incX, const float *Y, const CBLAS_INT incY, float *A, + const CBLAS_INT lda); void cblas_sspr2(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const CBLAS_INT N, const float alpha, const float *X, const CBLAS_INT incX, const float *Y, const CBLAS_INT incY, float *A); @@ -367,6 +375,10 @@ void cblas_dsymv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const CBLAS_INT N, const double alpha, const double *A, const CBLAS_INT lda, const double *X, const CBLAS_INT incX, const double beta, double *Y, const CBLAS_INT incY); +void cblas_dkymv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const CBLAS_INT N, const double alpha, const double *A, + const CBLAS_INT lda, const double *X, const CBLAS_INT incX, + const double beta, double *Y, const CBLAS_INT incY); void cblas_dsbmv(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const CBLAS_INT N, const CBLAS_INT K, const double alpha, const double *A, const CBLAS_INT lda, const double *X, const CBLAS_INT incX, @@ -388,6 +400,10 @@ void cblas_dsyr2(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const CBLAS_INT N, const double alpha, const double *X, const CBLAS_INT incX, const double *Y, const CBLAS_INT incY, double *A, const CBLAS_INT lda); +void cblas_dkyr2(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const CBLAS_INT N, const double alpha, const double *X, + const CBLAS_INT incX, const double *Y, const CBLAS_INT incY, double *A, + const CBLAS_INT lda); void cblas_dspr2(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const CBLAS_INT N, const double alpha, const double *X, const CBLAS_INT incX, const double *Y, const CBLAS_INT incY, double *A); @@ -483,6 +499,11 @@ void cblas_ssymm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, const float alpha, const float *A, const CBLAS_INT lda, const float *B, const CBLAS_INT ldb, const float beta, float *C, const CBLAS_INT ldc); +void cblas_skymm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, + CBLAS_UPLO Uplo, const CBLAS_INT M, const CBLAS_INT N, + const float alpha, const float *A, const CBLAS_INT lda, + const float *B, const CBLAS_INT ldb, const float beta, + float *C, const CBLAS_INT ldc); void cblas_ssyrk(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE Trans, const CBLAS_INT N, const CBLAS_INT K, const float alpha, const float *A, const CBLAS_INT lda, @@ -492,6 +513,11 @@ void cblas_ssyr2k(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const float alpha, const float *A, const CBLAS_INT lda, const float *B, const CBLAS_INT ldb, const float beta, float *C, const CBLAS_INT ldc); +void cblas_skyr2k(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE Trans, const CBLAS_INT N, const CBLAS_INT K, + const float alpha, const float *A, const CBLAS_INT lda, + const float *B, const CBLAS_INT ldb, const float beta, + float *C, const CBLAS_INT ldc); void cblas_strmm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, const CBLAS_INT M, const CBLAS_INT N, @@ -518,6 +544,11 @@ void cblas_dsymm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, const double alpha, const double *A, const CBLAS_INT lda, const double *B, const CBLAS_INT ldb, const double beta, double *C, const CBLAS_INT ldc); +void cblas_dkymm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, + CBLAS_UPLO Uplo, const CBLAS_INT M, const CBLAS_INT N, + const double alpha, const double *A, const CBLAS_INT lda, + const double *B, const CBLAS_INT ldb, const double beta, + double *C, const CBLAS_INT ldc); void cblas_dsyrk(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE Trans, const CBLAS_INT N, const CBLAS_INT K, const double alpha, const double *A, const CBLAS_INT lda, @@ -527,6 +558,11 @@ void cblas_dsyr2k(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const double alpha, const double *A, const CBLAS_INT lda, const double *B, const CBLAS_INT ldb, const double beta, double *C, const CBLAS_INT ldc); +void cblas_dkyr2k(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE Trans, const CBLAS_INT N, const CBLAS_INT K, + const double alpha, const double *A, const CBLAS_INT lda, + const double *B, const CBLAS_INT ldb, const double beta, + double *C, const CBLAS_INT ldc); void cblas_dtrmm(CBLAS_LAYOUT layout, CBLAS_SIDE Side, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, const CBLAS_INT M, const CBLAS_INT N, diff --git a/CBLAS/include/cblas_64.h b/CBLAS/include/cblas_64.h index 16504d914..2397f82bc 100644 --- a/CBLAS/include/cblas_64.h +++ b/CBLAS/include/cblas_64.h @@ -289,6 +289,10 @@ void cblas_ssymv_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const int64_t N, const float alpha, const float *A, const int64_t lda, const float *X, const int64_t incX, const float beta, float *Y, const int64_t incY); +void cblas_skymv_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int64_t N, const float alpha, const float *A, + const int64_t lda, const float *X, const int64_t incX, + const float beta, float *Y, const int64_t incY); void cblas_ssbmv_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const int64_t N, const int64_t K, const float alpha, const float *A, const int64_t lda, const float *X, const int64_t incX, @@ -310,6 +314,10 @@ void cblas_ssyr2_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const int64_t N, const float alpha, const float *X, const int64_t incX, const float *Y, const int64_t incY, float *A, const int64_t lda); +void cblas_skyr2_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int64_t N, const float alpha, const float *X, + const int64_t incX, const float *Y, const int64_t incY, float *A, + const int64_t lda); void cblas_sspr2_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const int64_t N, const float alpha, const float *X, const int64_t incX, const float *Y, const int64_t incY, float *A); @@ -318,6 +326,10 @@ void cblas_dsymv_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const int64_t N, const double alpha, const double *A, const int64_t lda, const double *X, const int64_t incX, const double beta, double *Y, const int64_t incY); +void cblas_dkymv_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int64_t N, const double alpha, const double *A, + const int64_t lda, const double *X, const int64_t incX, + const double beta, double *Y, const int64_t incY); void cblas_dsbmv_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const int64_t N, const int64_t K, const double alpha, const double *A, const int64_t lda, const double *X, const int64_t incX, @@ -339,6 +351,10 @@ void cblas_dsyr2_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const int64_t N, const double alpha, const double *X, const int64_t incX, const double *Y, const int64_t incY, double *A, const int64_t lda); +void cblas_dkyr2_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + const int64_t N, const double alpha, const double *X, + const int64_t incX, const double *Y, const int64_t incY, double *A, + const int64_t lda); void cblas_dspr2_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const int64_t N, const double alpha, const double *X, const int64_t incX, const double *Y, const int64_t incY, double *A); @@ -434,6 +450,11 @@ void cblas_ssymm_64(CBLAS_LAYOUT layout, CBLAS_SIDE Side, const float alpha, const float *A, const int64_t lda, const float *B, const int64_t ldb, const float beta, float *C, const int64_t ldc); +void cblas_skymm_64(CBLAS_LAYOUT layout, CBLAS_SIDE Side, + CBLAS_UPLO Uplo, const int64_t M, const int64_t N, + const float alpha, const float *A, const int64_t lda, + const float *B, const int64_t ldb, const float beta, + float *C, const int64_t ldc); void cblas_ssyrk_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE Trans, const int64_t N, const int64_t K, const float alpha, const float *A, const int64_t lda, @@ -443,6 +464,11 @@ void cblas_ssyr2k_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const float alpha, const float *A, const int64_t lda, const float *B, const int64_t ldb, const float beta, float *C, const int64_t ldc); +void cblas_skyr2k_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE Trans, const int64_t N, const int64_t K, + const float alpha, const float *A, const int64_t lda, + const float *B, const int64_t ldb, const float beta, + float *C, const int64_t ldc); void cblas_strmm_64(CBLAS_LAYOUT layout, CBLAS_SIDE Side, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, const int64_t M, const int64_t N, @@ -469,6 +495,11 @@ void cblas_dsymm_64(CBLAS_LAYOUT layout, CBLAS_SIDE Side, const double alpha, const double *A, const int64_t lda, const double *B, const int64_t ldb, const double beta, double *C, const int64_t ldc); +void cblas_dkymm_64(CBLAS_LAYOUT layout, CBLAS_SIDE Side, + CBLAS_UPLO Uplo, const int64_t M, const int64_t N, + const double alpha, const double *A, const int64_t lda, + const double *B, const int64_t ldb, const double beta, + double *C, const int64_t ldc); void cblas_dsyrk_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE Trans, const int64_t N, const int64_t K, const double alpha, const double *A, const int64_t lda, @@ -478,6 +509,11 @@ void cblas_dsyr2k_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const double alpha, const double *A, const int64_t lda, const double *B, const int64_t ldb, const double beta, double *C, const int64_t ldc); +void cblas_dkyr2k_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, + CBLAS_TRANSPOSE Trans, const int64_t N, const int64_t K, + const double alpha, const double *A, const int64_t lda, + const double *B, const int64_t ldb, const double beta, + double *C, const int64_t ldc); void cblas_dtrmm_64(CBLAS_LAYOUT layout, CBLAS_SIDE Side, CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, const int64_t M, const int64_t N, diff --git a/CBLAS/include/cblas_f77.h b/CBLAS/include/cblas_f77.h index 4880690f6..074ff0970 100644 --- a/CBLAS/include/cblas_f77.h +++ b/CBLAS/include/cblas_f77.h @@ -122,20 +122,24 @@ * Level 2 BLAS */ #define F77_ssymv_base F77_GLOBAL_SUFFIX(ssymv,SSYMV) +#define F77_skymv_base F77_GLOBAL_SUFFIX(skymv,SKYMV) #define F77_ssbmv_base F77_GLOBAL_SUFFIX(ssbmv,SSBMV) #define F77_sspmv_base F77_GLOBAL_SUFFIX(sspmv,SSPMV) #define F77_sger_base F77_GLOBAL_SUFFIX(sger,SGER) #define F77_ssyr_base F77_GLOBAL_SUFFIX(ssyr,SSYR) #define F77_sspr_base F77_GLOBAL_SUFFIX(sspr,SSPR) #define F77_ssyr2_base F77_GLOBAL_SUFFIX(ssyr2,SSYR2) +#define F77_skyr2_base F77_GLOBAL_SUFFIX(skyr2,SKYR2) #define F77_sspr2_base F77_GLOBAL_SUFFIX(sspr2,SSPR2) #define F77_dsymv_base F77_GLOBAL_SUFFIX(dsymv,DSYMV) +#define F77_dkymv_base F77_GLOBAL_SUFFIX(dkymv,DKYMV) #define F77_dsbmv_base F77_GLOBAL_SUFFIX(dsbmv,DSBMV) #define F77_dspmv_base F77_GLOBAL_SUFFIX(dspmv,DSPMV) #define F77_dger_base F77_GLOBAL_SUFFIX(dger,DGER) #define F77_dsyr_base F77_GLOBAL_SUFFIX(dsyr,DSYR) #define F77_dspr_base F77_GLOBAL_SUFFIX(dspr,DSPR) #define F77_dsyr2_base F77_GLOBAL_SUFFIX(dsyr2,DSYR2) +#define F77_dkyr2_base F77_GLOBAL_SUFFIX(dkyr2,DKYR2) #define F77_dspr2_base F77_GLOBAL_SUFFIX(dspr2,DSPR2) #define F77_chemv_base F77_GLOBAL_SUFFIX(chemv,CHEMV) #define F77_chbmv_base F77_GLOBAL_SUFFIX(chbmv,CHBMV) @@ -199,15 +203,19 @@ #define F77_sgemm_base F77_GLOBAL_SUFFIX(sgemm,SGEMM) #define F77_sgemmtr_base F77_GLOBAL_SUFFIX(sgemmtr,SGEMMTR) #define F77_ssymm_base F77_GLOBAL_SUFFIX(ssymm,SSYMM) +#define F77_skymm_base F77_GLOBAL_SUFFIX(skymm,SKYMM) #define F77_ssyrk_base F77_GLOBAL_SUFFIX(ssyrk,SSYRK) #define F77_ssyr2k_base F77_GLOBAL_SUFFIX(ssyr2k,SSYR2K) +#define F77_skyr2k_base F77_GLOBAL_SUFFIX(skyr2k,SKYR2K) #define F77_strmm_base F77_GLOBAL_SUFFIX(strmm,STRMM) #define F77_strsm_base F77_GLOBAL_SUFFIX(strsm,STRSM) #define F77_dgemm_base F77_GLOBAL_SUFFIX(dgemm,DGEMM) #define F77_dgemmtr_base F77_GLOBAL_SUFFIX(dgemmtr,DGEMMTR) #define F77_dsymm_base F77_GLOBAL_SUFFIX(dsymm,DSYMM) +#define F77_dkymm_base F77_GLOBAL_SUFFIX(dkymm,DKYMM) #define F77_dsyrk_base F77_GLOBAL_SUFFIX(dsyrk,DSYRK) #define F77_dsyr2k_base F77_GLOBAL_SUFFIX(dsyr2k,DSYR2K) +#define F77_dkyr2k_base F77_GLOBAL_SUFFIX(dkyr2k,DKYR2K) #define F77_dtrmm_base F77_GLOBAL_SUFFIX(dtrmm,DTRMM) #define F77_dtrsm_base F77_GLOBAL_SUFFIX(dtrsm,DTRSM) #define F77_cgemm_base F77_GLOBAL_SUFFIX(cgemm,CGEMM) @@ -319,6 +327,7 @@ #define F77_sgemv(...) F77_sgemv_base(__VA_ARGS__, 1) #define F77_sgbmv(...) F77_sgbmv_base(__VA_ARGS__, 1) #define F77_ssymv(...) F77_ssymv_base(__VA_ARGS__, 1) + #define F77_skymv(...) F77_skymv_base(__VA_ARGS__, 1) #define F77_ssbmv(...) F77_ssbmv_base(__VA_ARGS__, 1) #define F77_sspmv(...) F77_sspmv_base(__VA_ARGS__, 1) #define F77_strmv(...) F77_strmv_base(__VA_ARGS__, 1, 1, 1) @@ -331,12 +340,14 @@ #define F77_sspr(...) F77_sspr_base(__VA_ARGS__, 1) #define F77_sspr2(...) F77_sspr2_base(__VA_ARGS__, 1) #define F77_ssyr2(...) F77_ssyr2_base(__VA_ARGS__, 1) + #define F77_skyr2(...) F77_skyr2_base(__VA_ARGS__, 1) /* Double Precision */ #define F77_dgemv(...) F77_dgemv_base(__VA_ARGS__, 1) #define F77_dgbmv(...) F77_dgbmv_base(__VA_ARGS__, 1) #define F77_dsymv(...) F77_dsymv_base(__VA_ARGS__, 1) + #define F77_dkymv(...) F77_dkymv_base(__VA_ARGS__, 1) #define F77_dsbmv(...) F77_dsbmv_base(__VA_ARGS__, 1) #define F77_dspmv(...) F77_dspmv_base(__VA_ARGS__, 1) #define F77_dtrmv(...) F77_dtrmv_base(__VA_ARGS__, 1, 1, 1) @@ -349,6 +360,7 @@ #define F77_dspr(...) F77_dspr_base(__VA_ARGS__, 1) #define F77_dspr2(...) F77_dspr2_base(__VA_ARGS__, 1) #define F77_dsyr2(...) F77_dsyr2_base(__VA_ARGS__, 1) + #define F77_dkyr2(...) F77_dkyr2_base(__VA_ARGS__, 1) /* Single Complex Precision */ @@ -395,8 +407,10 @@ #define F77_sgemm(...) F77_sgemm_base(__VA_ARGS__, 1, 1) #define F77_sgemmtr(...) F77_sgemmtr_base(__VA_ARGS__, 1, 1, 1) #define F77_ssymm(...) F77_ssymm_base(__VA_ARGS__, 1, 1) + #define F77_skymm(...) F77_skymm_base(__VA_ARGS__, 1, 1) #define F77_ssyrk(...) F77_ssyrk_base(__VA_ARGS__, 1, 1) #define F77_ssyr2k(...) F77_ssyr2k_base(__VA_ARGS__, 1, 1) + #define F77_skyr2k(...) F77_skyr2k_base(__VA_ARGS__, 1, 1) #define F77_strmm(...) F77_strmm_base(__VA_ARGS__, 1, 1, 1, 1) #define F77_strsm(...) F77_strsm_base(__VA_ARGS__, 1, 1, 1, 1) @@ -405,8 +419,10 @@ #define F77_dgemm(...) F77_dgemm_base(__VA_ARGS__, 1, 1) #define F77_dgemmtr(...) F77_dgemmtr_base(__VA_ARGS__, 1, 1, 1) #define F77_dsymm(...) F77_dsymm_base(__VA_ARGS__, 1, 1) + #define F77_dkymm(...) F77_dkymm_base(__VA_ARGS__, 1, 1) #define F77_dsyrk(...) F77_dsyrk_base(__VA_ARGS__, 1, 1) #define F77_dsyr2k(...) F77_dsyr2k_base(__VA_ARGS__, 1, 1) + #define F77_dkyr2k(...) F77_dkyr2k_base(__VA_ARGS__, 1, 1) #define F77_dtrmm(...) F77_dtrmm_base(__VA_ARGS__, 1, 1, 1, 1) #define F77_dtrsm(...) F77_dtrsm_base(__VA_ARGS__, 1, 1, 1, 1) @@ -447,6 +463,7 @@ #define F77_sgemv(...) F77_sgemv_base(__VA_ARGS__) #define F77_sgbmv(...) F77_sgbmv_base(__VA_ARGS__) #define F77_ssymv(...) F77_ssymv_base(__VA_ARGS__) + #define F77_skymv(...) F77_skymv_base(__VA_ARGS__) #define F77_ssbmv(...) F77_ssbmv_base(__VA_ARGS__) #define F77_sspmv(...) F77_sspmv_base(__VA_ARGS__) #define F77_strmv(...) F77_strmv_base(__VA_ARGS__) @@ -459,12 +476,14 @@ #define F77_sspr(...) F77_sspr_base(__VA_ARGS__) #define F77_sspr2(...) F77_sspr2_base(__VA_ARGS__) #define F77_ssyr2(...) F77_ssyr2_base(__VA_ARGS__) + #define F77_skyr2(...) F77_skyr2_base(__VA_ARGS__) /* Double Precision */ #define F77_dgemv(...) F77_dgemv_base(__VA_ARGS__) #define F77_dgbmv(...) F77_dgbmv_base(__VA_ARGS__) #define F77_dsymv(...) F77_dsymv_base(__VA_ARGS__) + #define F77_dkymv(...) F77_dkymv_base(__VA_ARGS__) #define F77_dsbmv(...) F77_dsbmv_base(__VA_ARGS__) #define F77_dspmv(...) F77_dspmv_base(__VA_ARGS__) #define F77_dtrmv(...) F77_dtrmv_base(__VA_ARGS__) @@ -477,6 +496,7 @@ #define F77_dspr(...) F77_dspr_base(__VA_ARGS__) #define F77_dspr2(...) F77_dspr2_base(__VA_ARGS__) #define F77_dsyr2(...) F77_dsyr2_base(__VA_ARGS__) + #define F77_dkyr2(...) F77_dkyr2_base(__VA_ARGS__) /* Single Complex Precision */ @@ -523,8 +543,10 @@ #define F77_sgemm(...) F77_sgemm_base(__VA_ARGS__) #define F77_sgemmtr(...) F77_sgemmtr_base(__VA_ARGS__) #define F77_ssymm(...) F77_ssymm_base(__VA_ARGS__) + #define F77_skymm(...) F77_skymm_base(__VA_ARGS__) #define F77_ssyrk(...) F77_ssyrk_base(__VA_ARGS__) #define F77_ssyr2k(...) F77_ssyr2k_base(__VA_ARGS__) + #define F77_skyr2k(...) F77_skyr2k_base(__VA_ARGS__) #define F77_strmm(...) F77_strmm_base(__VA_ARGS__) #define F77_strsm(...) F77_strsm_base(__VA_ARGS__) @@ -533,8 +555,10 @@ #define F77_dgemm(...) F77_dgemm_base(__VA_ARGS__) #define F77_dgemmtr(...) F77_dgemmtr_base(__VA_ARGS__) #define F77_dsymm(...) F77_dsymm_base(__VA_ARGS__) + #define F77_dkymm(...) F77_dkymm_base(__VA_ARGS__) #define F77_dsyrk(...) F77_dsyrk_base(__VA_ARGS__) #define F77_dsyr2k(...) F77_dsyr2k_base(__VA_ARGS__) + #define F77_dkyr2k(...) F77_dkyr2k_base(__VA_ARGS__) #define F77_dtrmm(...) F77_dtrmm_base(__VA_ARGS__) #define F77_dtrsm(...) F77_dtrsm_base(__VA_ARGS__) @@ -681,6 +705,11 @@ void F77_ssymv_base(FCHAR, FINT, const float *, const float *, FINT, const float , FORTRAN_STRLEN #endif ); +void F77_skymv_base(FCHAR, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT +#ifdef BLAS_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); void F77_ssbmv_base(FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT #ifdef BLAS_FORTRAN_STRLEN_END , FORTRAN_STRLEN @@ -742,6 +771,11 @@ void F77_ssyr2_base(FCHAR, FINT, const float *, const float *, FINT, const float , FORTRAN_STRLEN #endif ); +void F77_skyr2_base(FCHAR, FINT, const float *, const float *, FINT, const float *, FINT, float *, FINT +#ifdef BLAS_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); /* Double Precision */ @@ -760,6 +794,11 @@ void F77_dsymv_base(FCHAR, FINT, const double *, const double *, FINT, const dou , FORTRAN_STRLEN #endif ); +void F77_dkymv_base(FCHAR, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT +#ifdef BLAS_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); void F77_dsbmv_base(FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT #ifdef BLAS_FORTRAN_STRLEN_END , FORTRAN_STRLEN @@ -821,6 +860,11 @@ void F77_dsyr2_base(FCHAR, FINT, const double *, const double *, FINT, const dou , FORTRAN_STRLEN #endif ); +void F77_dkyr2_base(FCHAR, FINT, const double *, const double *, FINT, const double *, FINT, double *, FINT +#ifdef BLAS_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); /* Single Complex Precision */ @@ -998,12 +1042,16 @@ void F77_sgemmtr_base(FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, const floa , size_t, size_t, size_t #endif ); - void F77_ssymm_base(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT #ifdef BLAS_FORTRAN_STRLEN_END , FORTRAN_STRLEN, FORTRAN_STRLEN #endif ); +void F77_skymm_base(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT +#ifdef BLAS_FORTRAN_STRLEN_END + , FORTRAN_STRLEN, FORTRAN_STRLEN +#endif +); void F77_ssyrk_base(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, float *, FINT #ifdef BLAS_FORTRAN_STRLEN_END , FORTRAN_STRLEN, FORTRAN_STRLEN @@ -1014,6 +1062,11 @@ void F77_ssyr2k_base(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FIN , FORTRAN_STRLEN, FORTRAN_STRLEN #endif ); +void F77_skyr2k_base(FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, const float *, FINT, const float *, float *, FINT +#ifdef BLAS_FORTRAN_STRLEN_END + , FORTRAN_STRLEN, FORTRAN_STRLEN +#endif +); void F77_strmm_base(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const float *, const float *, FINT, float *, FINT #ifdef BLAS_FORTRAN_STRLEN_END , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN @@ -1043,6 +1096,11 @@ void F77_dsymm_base(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FI , FORTRAN_STRLEN, FORTRAN_STRLEN #endif ); +void F77_dkymm_base(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT +#ifdef BLAS_FORTRAN_STRLEN_END + , FORTRAN_STRLEN, FORTRAN_STRLEN +#endif +); void F77_dsyrk_base(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, double *, FINT #ifdef BLAS_FORTRAN_STRLEN_END , FORTRAN_STRLEN, FORTRAN_STRLEN @@ -1053,6 +1111,11 @@ void F77_dsyr2k_base(FCHAR, FCHAR, FINT, FINT, const double *, const double *, F , FORTRAN_STRLEN, FORTRAN_STRLEN #endif ); +void F77_dkyr2k_base(FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, const double *, FINT, const double *, double *, FINT +#ifdef BLAS_FORTRAN_STRLEN_END + , FORTRAN_STRLEN, FORTRAN_STRLEN +#endif +); void F77_dtrmm_base(FCHAR, FCHAR, FCHAR, FCHAR, FINT, FINT, const double *, const double *, FINT, double *, FINT #ifdef BLAS_FORTRAN_STRLEN_END , FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN, FORTRAN_STRLEN diff --git a/CBLAS/include/cblas_test.h b/CBLAS/include/cblas_test.h index 4374cb378..bd4ee0523 100644 --- a/CBLAS/include/cblas_test.h +++ b/CBLAS/include/cblas_test.h @@ -88,20 +88,24 @@ typedef struct { double real; double imag; } CBLAS_TEST_ZOMPLEX; #define F77_c2chke F77_GLOBAL(cc2chke,CC2CHKE) #define F77_z2chke F77_GLOBAL(cz2chke,CZ2CHKE) #define F77_ssymv F77_GLOBAL(cssymv,CSSYMV) +#define F77_skymv F77_GLOBAL(cskymv,CSKYMV) #define F77_ssbmv F77_GLOBAL(cssbmv,CSSBMV) #define F77_sspmv F77_GLOBAL(csspmv,CSSPMV) #define F77_sger F77_GLOBAL(csger,CSGER) #define F77_ssyr F77_GLOBAL(cssyr,CSSYR) #define F77_sspr F77_GLOBAL(csspr,CSSPR) #define F77_ssyr2 F77_GLOBAL(cssyr2,CSSYR2) +#define F77_skyr2 F77_GLOBAL(cskyr2,CSKYR2) #define F77_sspr2 F77_GLOBAL(csspr2,CSSPR2) #define F77_dsymv F77_GLOBAL(cdsymv,CDSYMV) +#define F77_dkymv F77_GLOBAL(cdkymv,CDKYMV) #define F77_dsbmv F77_GLOBAL(cdsbmv,CDSBMV) #define F77_dspmv F77_GLOBAL(cdspmv,CDSPMV) #define F77_dger F77_GLOBAL(cdger,CDGER) #define F77_dsyr F77_GLOBAL(cdsyr,CDSYR) #define F77_dspr F77_GLOBAL(cdspr,CDSPR) #define F77_dsyr2 F77_GLOBAL(cdsyr2,CDSYR2) +#define F77_dkyr2 F77_GLOBAL(cdkyr2,CDKYR2) #define F77_dspr2 F77_GLOBAL(cdspr2,CDSPR2) #define F77_chemv F77_GLOBAL(cchemv,CCHEMV) #define F77_chbmv F77_GLOBAL(cchbmv,CCHBMV) @@ -169,15 +173,19 @@ typedef struct { double real; double imag; } CBLAS_TEST_ZOMPLEX; #define F77_sgemm F77_GLOBAL(csgemm,CSGEMM) #define F77_sgemmtr F77_GLOBAL(csgemmtr,CSGEMMTR) #define F77_ssymm F77_GLOBAL(cssymm,CSSYMM) +#define F77_skymm F77_GLOBAL(cskymm,CSKYMM) #define F77_ssyrk F77_GLOBAL(cssyrk,CSSYRK) #define F77_ssyr2k F77_GLOBAL(cssyr2k,CSSYR2K) +#define F77_skyr2k F77_GLOBAL(cskyr2k,CSKYR2K) #define F77_strmm F77_GLOBAL(cstrmm,CSTRMM) #define F77_strsm F77_GLOBAL(cstrsm,CSTRSM) #define F77_dgemm F77_GLOBAL(cdgemm,CDGEMM) #define F77_dgemmtr F77_GLOBAL(cdgemmtr,CDGEMMTR) #define F77_dsymm F77_GLOBAL(cdsymm,CDSYMM) +#define F77_dkymm F77_GLOBAL(cdkymm,CDKYMM) #define F77_dsyrk F77_GLOBAL(cdsyrk,CDSYRK) #define F77_dsyr2k F77_GLOBAL(cdsyr2k,CDSYR2K) +#define F77_dkyr2k F77_GLOBAL(cdkyr2k,CDKYR2K) #define F77_dtrmm F77_GLOBAL(cdtrmm,CDTRMM) #define F77_dtrsm F77_GLOBAL(cdtrsm,CDTRSM) #define F77_cgemm F77_GLOBAL(ccgemm,CCGEMM) diff --git a/CBLAS/src/CMakeLists.txt b/CBLAS/src/CMakeLists.txt index 8dcb2f293..e92d92dbf 100644 --- a/CBLAS/src/CMakeLists.txt +++ b/CBLAS/src/CMakeLists.txt @@ -55,13 +55,13 @@ set(SCLEV1 cblas_scasum.c scasumsub.f cblas_scnrm2.c scnrm2sub.f) set(SLEV2 cblas_sgemv.c cblas_sgbmv.c cblas_sger.c cblas_ssbmv.c cblas_sspmv.c cblas_sspr.c cblas_sspr2.c cblas_ssymv.c cblas_ssyr.c cblas_ssyr2.c cblas_stbmv.c cblas_stbsv.c cblas_stpmv.c cblas_stpsv.c cblas_strmv.c - cblas_strsv.c) + cblas_strsv.c cblas_skymv.c cblas_skyr2.c) # Files for level 2 double precision real set(DLEV2 cblas_dgemv.c cblas_dgbmv.c cblas_dger.c cblas_dsbmv.c cblas_dspmv.c cblas_dspr.c cblas_dspr2.c cblas_dsymv.c cblas_dsyr.c cblas_dsyr2.c cblas_dtbmv.c cblas_dtbsv.c cblas_dtpmv.c cblas_dtpsv.c cblas_dtrmv.c - cblas_dtrsv.c) + cblas_dtrsv.c cblas_dkymv.c cblas_dkyr2.c) # Files for level 2 single precision complex set(CLEV2 cblas_cgemv.c cblas_cgbmv.c cblas_chemv.c cblas_chbmv.c cblas_chpmv.c @@ -85,11 +85,11 @@ set(ZLEV2 cblas_zgemv.c cblas_zgbmv.c cblas_zhemv.c cblas_zhbmv.c cblas_zhpmv.c # Files for level 3 single precision real set(SLEV3 cblas_sgemm.c cblas_ssymm.c cblas_ssyrk.c cblas_ssyr2k.c cblas_strmm.c - cblas_strsm.c cblas_sgemmtr.c) + cblas_strsm.c cblas_sgemmtr.c cblas_skymm.c cblas_skyr2k.c) # Files for level 3 double precision real set(DLEV3 cblas_dgemm.c cblas_dsymm.c cblas_dsyrk.c cblas_dsyr2k.c cblas_dtrmm.c - cblas_dtrsm.c cblas_dgemmtr.c) + cblas_dtrsm.c cblas_dgemmtr.c cblas_dkymm.c cblas_dkyr2k.c) # Files for level 3 single precision complex set(CLEV3 cblas_cgemm.c cblas_csymm.c cblas_chemm.c cblas_cherk.c diff --git a/CBLAS/src/Makefile b/CBLAS/src/Makefile index abc3192c6..011dc958e 100644 --- a/CBLAS/src/Makefile +++ b/CBLAS/src/Makefile @@ -86,13 +86,13 @@ zlib1: $(zlev1) slev2 = cblas_sgemv.o cblas_sgbmv.o cblas_sger.o cblas_ssbmv.o cblas_sspmv.o \ cblas_sspr.o cblas_sspr2.o cblas_ssymv.o cblas_ssyr.o cblas_ssyr2.o \ cblas_stbmv.o cblas_stbsv.o cblas_stpmv.o cblas_stpsv.o cblas_strmv.o \ - cblas_strsv.o + cblas_strsv.o cblas_skymv.o cblas_skyr2.o # Files for level 2 double precision real dlev2 = cblas_dgemv.o cblas_dgbmv.o cblas_dger.o cblas_dsbmv.o cblas_dspmv.o \ cblas_dspr.o cblas_dspr2.o cblas_dsymv.o cblas_dsyr.o cblas_dsyr2.o \ cblas_dtbmv.o cblas_dtbsv.o cblas_dtpmv.o cblas_dtpsv.o cblas_dtrmv.o \ - cblas_dtrsv.o + cblas_dtrsv.o cblas_dkymv.o cblas_dkyr2.o # Files for level 2 single precision complex clev2 = cblas_cgemv.o cblas_cgbmv.o cblas_chemv.o cblas_chbmv.o cblas_chpmv.o \ @@ -137,11 +137,11 @@ zlib2: $(zlev2) $(errhand) # Files for level 3 single precision real slev3 = cblas_sgemm.o cblas_ssymm.o cblas_ssyrk.o cblas_ssyr2k.o cblas_strmm.o \ - cblas_strsm.o cblas_sgemmtr.o + cblas_strsm.o cblas_sgemmtr.o cblas_skymm.o cblas_skyr2k.o # Files for level 3 double precision real dlev3 = cblas_dgemm.o cblas_dsymm.o cblas_dsyrk.o cblas_dsyr2k.o cblas_dtrmm.o \ - cblas_dtrsm.o cblas_dgemmtr.o + cblas_dtrsm.o cblas_dgemmtr.o cblas_dkymm.o cblas_dkyr2k.o # Files for level 3 single precision complex clev3 = cblas_cgemm.o cblas_csymm.o cblas_chemm.o cblas_cherk.o \ diff --git a/CBLAS/src/cblas_dkymm.c b/CBLAS/src/cblas_dkymm.c new file mode 100644 index 000000000..6818c5b07 --- /dev/null +++ b/CBLAS/src/cblas_dkymm.c @@ -0,0 +1,106 @@ +/* + * + * cblas_dkymm.c + * This program is a C interface to dkymm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void API_SUFFIX(cblas_dkymm)(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const CBLAS_INT M, const CBLAS_INT N, + const double alpha, const double *A, const CBLAS_INT lda, + const double *B, const CBLAS_INT ldb, const double beta, + double *C, const CBLAS_INT ldc) +{ + char SD, UL; +#ifdef F77_CHAR + F77_CHAR F77_SD, F77_UL; +#else + #define F77_SD &SD + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + API_SUFFIX(cblas_xerbla)(2, "cblas_dkymm","Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_dkymm","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_dkymm(F77_SD, F77_UL, &F77_M, &F77_N, &alpha, A, &F77_lda, + B, &F77_ldb, &beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + API_SUFFIX(cblas_xerbla)(2, "cblas_dkymm","Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_dkymm","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_dkymm(F77_SD, F77_UL, &F77_N, &F77_M, &alpha, A, &F77_lda, B, + &F77_ldb, &beta, C, &F77_ldc); + } + else API_SUFFIX(cblas_xerbla)(1, "cblas_dkymm","Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/CBLAS/src/cblas_dkymv.c b/CBLAS/src/cblas_dkymv.c new file mode 100644 index 000000000..849999a6c --- /dev/null +++ b/CBLAS/src/cblas_dkymv.c @@ -0,0 +1,78 @@ +/* + * + * cblas_dkymv.c + * This program is a C interface to dkymv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void API_SUFFIX(cblas_dkymv)(const CBLAS_LAYOUT layout, + const CBLAS_UPLO Uplo, const CBLAS_INT N, + const double alpha, const double *A, const CBLAS_INT lda, + const double *X, const CBLAS_INT incX, const double beta, + double *Y, const CBLAS_INT incY) +{ + char UL; + double minus_alpha; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incX + #define F77_incY incY +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + API_SUFFIX(cblas_xerbla)(2, "cblas_dkymv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_dkymv(F77_UL, &F77_N, &alpha, A, &F77_lda, X, + &F77_incX, &beta, Y, &F77_incY); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + API_SUFFIX(cblas_xerbla)(2, "cblas_dkymv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + minus_alpha = -alpha; + F77_dkymv(F77_UL, &F77_N, &minus_alpha, + A ,&F77_lda, X,&F77_incX, &beta, Y, &F77_incY); + } + else API_SUFFIX(cblas_xerbla)(1, "cblas_dkymv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/CBLAS/src/cblas_dkyr2.c b/CBLAS/src/cblas_dkyr2.c new file mode 100644 index 000000000..00843ef4c --- /dev/null +++ b/CBLAS/src/cblas_dkyr2.c @@ -0,0 +1,78 @@ +/* + * + * cblas_dkyr2.c + * This program is a C interface to dkyr2. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void API_SUFFIX(cblas_dkyr2)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_INT N, const double alpha, const double *X, + const CBLAS_INT incX, const double *Y, const CBLAS_INT incY, double *A, + const CBLAS_INT lda) +{ + char UL; + double minus_alpha; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY, F77_lda=lda; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY + #define F77_lda lda +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + API_SUFFIX(cblas_xerbla)(2, "cblas_dkyr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_dkyr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasLower) UL = 'U'; + else if (Uplo == CblasUpper) UL = 'L'; + else + { + API_SUFFIX(cblas_xerbla)(2, "cblas_dkyr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + minus_alpha = -alpha; + F77_dkyr2(F77_UL, &F77_N, &minus_alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + } else API_SUFFIX(cblas_xerbla)(1, "cblas_dkyr2", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/CBLAS/src/cblas_dkyr2k.c b/CBLAS/src/cblas_dkyr2k.c new file mode 100644 index 000000000..c90174281 --- /dev/null +++ b/CBLAS/src/cblas_dkyr2k.c @@ -0,0 +1,111 @@ +/* + * + * cblas_dkyr2k.c + * This program is a C interface to dkyr2k. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void API_SUFFIX(cblas_dkyr2k)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const CBLAS_INT N, const CBLAS_INT K, + const double alpha, const double *A, const CBLAS_INT lda, + const double *B, const CBLAS_INT ldb, const double beta, + double *C, const CBLAS_INT ldc) +{ + char UL, TR; + double minus_alpha; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + API_SUFFIX(cblas_xerbla)(2, "cblas_dkyr2k","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_dkyr2k","Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_dkyr2k(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, + B, &F77_ldb, &beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_dkyr2k","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='T'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_dkyr2k","Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + minus_alpha = -alpha; + F77_dkyr2k(F77_UL, F77_TR, &F77_N, &F77_K, &minus_alpha, A, &F77_lda, B, + &F77_ldb, &beta, C, &F77_ldc); + } + else API_SUFFIX(cblas_xerbla)(1, "cblas_dkyr2k","Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/CBLAS/src/cblas_skymm.c b/CBLAS/src/cblas_skymm.c new file mode 100644 index 000000000..9a99827f2 --- /dev/null +++ b/CBLAS/src/cblas_skymm.c @@ -0,0 +1,108 @@ +/* + * + * cblas_skymm.c + * This program is a C interface to skymm. + * Written by Keita Teranishi + * 4/8/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void API_SUFFIX(cblas_skymm)(const CBLAS_LAYOUT layout, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const CBLAS_INT M, const CBLAS_INT N, + const float alpha, const float *A, const CBLAS_INT lda, + const float *B, const CBLAS_INT ldb, const float beta, + float *C, const CBLAS_INT ldc) +{ + char SD, UL; +#ifdef F77_CHAR + F77_CHAR F77_SD, F77_UL; +#else + #define F77_SD &SD + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_M=M, F77_N=N, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_M M + #define F77_N N + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + if( Side == CblasRight) SD='R'; + else if ( Side == CblasLeft ) SD='L'; + else + { + API_SUFFIX(cblas_xerbla)(2, "cblas_skymm", + "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_skymm", + "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_skymm(F77_SD, F77_UL, &F77_M, &F77_N, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Side == CblasRight) SD='L'; + else if ( Side == CblasLeft ) SD='R'; + else + { + API_SUFFIX(cblas_xerbla)(2, "cblas_skymm", + "Illegal Side setting, %d\n", Side); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_skymm", + "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_SD = C2F_CHAR(&SD); + #endif + + F77_skymm(F77_SD, F77_UL, &F77_N, &F77_M, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else API_SUFFIX(cblas_xerbla)(1, "cblas_skymm", + "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/CBLAS/src/cblas_skymv.c b/CBLAS/src/cblas_skymv.c new file mode 100644 index 000000000..233d47725 --- /dev/null +++ b/CBLAS/src/cblas_skymv.c @@ -0,0 +1,78 @@ +/* + * + * cblas_skymv.c + * This program is a C interface to skymv. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void API_SUFFIX(cblas_skymv)(const CBLAS_LAYOUT layout, + const CBLAS_UPLO Uplo, const CBLAS_INT N, + const float alpha, const float *A, const CBLAS_INT lda, + const float *X, const CBLAS_INT incX, const float beta, + float *Y, const CBLAS_INT incY) +{ + char UL; + float minus_alpha; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif +#ifdef F77_INT + F77_INT F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY; +#else + #define F77_N N + #define F77_lda lda + #define F77_incX incX + #define F77_incY incY +#endif + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasUpper) UL = 'U'; + else if (Uplo == CblasLower) UL = 'L'; + else + { + API_SUFFIX(cblas_xerbla)(2, "cblas_skymv","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + F77_skymv(F77_UL, &F77_N, &alpha, A, &F77_lda, X, + &F77_incX, &beta, Y, &F77_incY); + } + else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasUpper) UL = 'L'; + else if (Uplo == CblasLower) UL = 'U'; + else + { + API_SUFFIX(cblas_xerbla)(2, "cblas_skymv","Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + minus_alpha = -alpha; + F77_skymv(F77_UL, &F77_N, &minus_alpha, + A ,&F77_lda, X,&F77_incX, &beta, Y, &F77_incY); + } + else API_SUFFIX(cblas_xerbla)(1, "cblas_skymv", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/CBLAS/src/cblas_skyr2.c b/CBLAS/src/cblas_skyr2.c new file mode 100644 index 000000000..ed62e059b --- /dev/null +++ b/CBLAS/src/cblas_skyr2.c @@ -0,0 +1,78 @@ +/* + * + * cblas_skyr2.c + * This program is a C interface to skyr2. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void API_SUFFIX(cblas_skyr2)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_INT N, const float alpha, const float *X, + const CBLAS_INT incX, const float *Y, const CBLAS_INT incY, float *A, + const CBLAS_INT lda) +{ + char UL; + float minus_alpha; +#ifdef F77_CHAR + F77_CHAR F77_UL; +#else + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_incX=incX, F77_incY=incY, F77_lda=lda; +#else + #define F77_N N + #define F77_incX incX + #define F77_incY incY + #define F77_lda lda +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + if (layout == CblasColMajor) + { + if (Uplo == CblasLower) UL = 'L'; + else if (Uplo == CblasUpper) UL = 'U'; + else + { + API_SUFFIX(cblas_xerbla)(2, "cblas_skyr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + + F77_skyr2(F77_UL, &F77_N, &alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if (Uplo == CblasLower) UL = 'U'; + else if (Uplo == CblasUpper) UL = 'L'; + else + { + API_SUFFIX(cblas_xerbla)(2, "cblas_skyr2","Illegal Uplo setting, %d\n",Uplo ); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + #endif + minus_alpha = -alpha; + F77_skyr2(F77_UL, &F77_N, &minus_alpha, X, &F77_incX, Y, &F77_incY, A, + &F77_lda); + } else API_SUFFIX(cblas_xerbla)(1, "cblas_skyr2", "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/CBLAS/src/cblas_skyr2k.c b/CBLAS/src/cblas_skyr2k.c new file mode 100644 index 000000000..5d9ba34ba --- /dev/null +++ b/CBLAS/src/cblas_skyr2k.c @@ -0,0 +1,113 @@ +/* + * + * cblas_skyr2k.c + * This program is a C interface to skyr2k. + * Written by Keita Teranishi + * 4/6/1998 + * + */ + +#include "cblas.h" +#include "cblas_f77.h" +void API_SUFFIX(cblas_skyr2k)(const CBLAS_LAYOUT layout, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const CBLAS_INT N, const CBLAS_INT K, + const float alpha, const float *A, const CBLAS_INT lda, + const float *B, const CBLAS_INT ldb, const float beta, + float *C, const CBLAS_INT ldc) +{ + char UL, TR; + float minus_alpha; +#ifdef F77_CHAR + F77_CHAR F77_TA, F77_UL; +#else + #define F77_TR &TR + #define F77_UL &UL +#endif + +#ifdef F77_INT + F77_INT F77_N=N, F77_K=K, F77_lda=lda, F77_ldb=ldb; + F77_INT F77_ldc=ldc; +#else + #define F77_N N + #define F77_K K + #define F77_lda lda + #define F77_ldb ldb + #define F77_ldc ldc +#endif + + extern int CBLAS_CallFromC; + extern int RowMajorStrg; + RowMajorStrg = 0; + CBLAS_CallFromC = 1; + + if( layout == CblasColMajor ) + { + + if( Uplo == CblasUpper) UL='U'; + else if ( Uplo == CblasLower ) UL='L'; + else + { + API_SUFFIX(cblas_xerbla)(2, "cblas_skyr2k", + "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + if( Trans == CblasTrans) TR ='T'; + else if ( Trans == CblasConjTrans ) TR='C'; + else if ( Trans == CblasNoTrans ) TR='N'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_skyr2k", + "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + F77_skyr2k(F77_UL, F77_TR, &F77_N, &F77_K, &alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else if (layout == CblasRowMajor) + { + RowMajorStrg = 1; + if( Uplo == CblasUpper) UL='L'; + else if ( Uplo == CblasLower ) UL='U'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_skyr2k", + "Illegal Uplo setting, %d\n", Uplo); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + if( Trans == CblasTrans) TR ='N'; + else if ( Trans == CblasConjTrans ) TR='N'; + else if ( Trans == CblasNoTrans ) TR='T'; + else + { + API_SUFFIX(cblas_xerbla)(3, "cblas_skyr2k", + "Illegal Trans setting, %d\n", Trans); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; + } + + #ifdef F77_CHAR + F77_UL = C2F_CHAR(&UL); + F77_TR = C2F_CHAR(&TR); + #endif + + minus_alpha = -alpha; + F77_skyr2k(F77_UL, F77_TR, &F77_N, &F77_K, &minus_alpha, A, &F77_lda, B, &F77_ldb, &beta, C, &F77_ldc); + } else API_SUFFIX(cblas_xerbla)(1, "cblas_skyr2k", + "Illegal layout setting, %d\n", layout); + CBLAS_CallFromC = 0; + RowMajorStrg = 0; + return; +} diff --git a/CBLAS/testing/c_d2chke.c b/CBLAS/testing/c_d2chke.c index f02a55dc8..df4fb2989 100644 --- a/CBLAS/testing/c_d2chke.c +++ b/CBLAS/testing/c_d2chke.c @@ -224,6 +224,52 @@ void F77_d2chke(char *rout cblas_dsymv(CblasRowMajor, CblasUpper, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); + } else if (strncmp( sf,"cblas_dkymv",11)==0) { + cblas_rout = "cblas_dkymv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_dkymv(INVALID, CblasUpper, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dkymv(CblasColMajor, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dkymv(CblasColMajor, CblasUpper, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dkymv(CblasColMajor, CblasUpper, 2, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dkymv(CblasColMajor, CblasUpper, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_dkymv(CblasColMajor, CblasUpper, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_dkymv(CblasRowMajor, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_dkymv(CblasRowMajor, CblasUpper, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dkymv(CblasRowMajor, CblasUpper, 2, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dkymv(CblasRowMajor, CblasUpper, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_dkymv(CblasRowMajor, CblasUpper, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); } else if (strncmp( sf,"cblas_dsbmv",11)==0) { cblas_rout = "cblas_dsbmv"; cblas_info = 1; RowMajorStrg = FALSE; @@ -710,6 +756,41 @@ void F77_d2chke(char *rout cblas_info = 10; RowMajorStrg = TRUE; cblas_dsyr2(CblasRowMajor, CblasUpper, 2, ALPHA, X, 1, Y, 1, A, 1 ); chkxer(); + } else if (strncmp( sf,"cblas_dkyr2",11)==0) { + cblas_rout = "cblas_dkyr2"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_dkyr2(INVALID, CblasUpper, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dkyr2(CblasColMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dkyr2(CblasColMajor, CblasUpper, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_dkyr2(CblasColMajor, CblasUpper, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dkyr2(CblasColMajor, CblasUpper, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dkyr2(CblasColMajor, CblasUpper, 2, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_dkyr2(CblasRowMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_dkyr2(CblasRowMajor, CblasUpper, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_dkyr2(CblasRowMajor, CblasUpper, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dkyr2(CblasRowMajor, CblasUpper, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dkyr2(CblasRowMajor, CblasUpper, 2, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); } else if (strncmp( sf,"cblas_dspr2",11)==0) { cblas_rout = "cblas_dspr2"; cblas_info = 1; RowMajorStrg = FALSE; diff --git a/CBLAS/testing/c_d3chke.c b/CBLAS/testing/c_d3chke.c index 6d27bc6cf..216d238b4 100644 --- a/CBLAS/testing/c_d3chke.c +++ b/CBLAS/testing/c_d3chke.c @@ -687,6 +687,182 @@ void F77_d3chke(char *rout ALPHA, A, 2, B, 2, BETA, C, 1 ); chkxer(); + } else if (strncmp( sf,"cblas_dkymm" ,11)==0) { + cblas_rout = "cblas_dkymm" ; + + cblas_info = 1; + cblas_dkymm( INVALID, CblasRight, CblasLower, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dkymm( CblasColMajor, INVALID, CblasUpper, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dkymm( CblasColMajor, CblasLeft, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dkymm( CblasColMajor, CblasLeft, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dkymm( CblasColMajor, CblasRight, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dkymm( CblasColMajor, CblasLeft, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dkymm( CblasColMajor, CblasRight, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dkymm( CblasColMajor, CblasLeft, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dkymm( CblasColMajor, CblasRight, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dkymm( CblasColMajor, CblasLeft, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dkymm( CblasColMajor, CblasRight, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dkymm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dkymm( CblasColMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dkymm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dkymm( CblasColMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dkymm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dkymm( CblasColMajor, CblasRight, CblasUpper, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dkymm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dkymm( CblasColMajor, CblasRight, CblasLower, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_dkymm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_dkymm( CblasColMajor, CblasRight, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_dkymm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_dkymm( CblasColMajor, CblasRight, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_dkymm( CblasRowMajor, CblasLeft, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_dkymm( CblasRowMajor, CblasRight, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_dkymm( CblasRowMajor, CblasLeft, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_dkymm( CblasRowMajor, CblasRight, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dkymm( CblasRowMajor, CblasLeft, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dkymm( CblasRowMajor, CblasRight, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dkymm( CblasRowMajor, CblasLeft, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_dkymm( CblasRowMajor, CblasRight, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dkymm( CblasRowMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dkymm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dkymm( CblasRowMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dkymm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dkymm( CblasRowMajor, CblasLeft, CblasUpper, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dkymm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dkymm( CblasRowMajor, CblasLeft, CblasLower, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dkymm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_dkymm( CblasRowMajor, CblasLeft, CblasUpper, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_dkymm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_dkymm( CblasRowMajor, CblasLeft, CblasLower, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_dkymm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + } else if (strncmp( sf,"cblas_dtrmm" ,11)==0) { cblas_rout = "cblas_dtrmm" ; @@ -1503,6 +1679,149 @@ void F77_d3chke(char *rout cblas_dsyr2k( CblasColMajor, CblasLower, CblasTrans, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); + } else if (strncmp( sf,"cblas_dkyr2k" ,12)==0) { + cblas_rout = "cblas_dkyr2k" ; + + cblas_info = 1; + cblas_dkyr2k( INVALID, CblasUpper, CblasNoTrans, + 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_dkyr2k( CblasColMajor, INVALID, CblasNoTrans, + 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_dkyr2k( CblasColMajor, CblasUpper, INVALID, + 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dkyr2k( CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dkyr2k( CblasColMajor, CblasUpper, CblasTrans, + INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dkyr2k( CblasColMajor, CblasLower, CblasNoTrans, + INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_dkyr2k( CblasColMajor, CblasLower, CblasTrans, + INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dkyr2k( CblasColMajor, CblasUpper, CblasNoTrans, + 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dkyr2k( CblasColMajor, CblasUpper, CblasTrans, + 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dkyr2k( CblasColMajor, CblasLower, CblasNoTrans, + 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_dkyr2k( CblasColMajor, CblasLower, CblasTrans, + 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dkyr2k( CblasRowMajor, CblasUpper, CblasNoTrans, + 0, 2, ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dkyr2k( CblasRowMajor, CblasUpper, CblasTrans, + 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dkyr2k( CblasRowMajor, CblasLower, CblasNoTrans, + 0, 2, ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_dkyr2k( CblasRowMajor, CblasLower, CblasTrans, + 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dkyr2k( CblasColMajor, CblasUpper, CblasNoTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dkyr2k( CblasColMajor, CblasUpper, CblasTrans, + 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dkyr2k( CblasColMajor, CblasLower, CblasNoTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_dkyr2k( CblasColMajor, CblasLower, CblasTrans, + 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dkyr2k( CblasRowMajor, CblasUpper, CblasNoTrans, + 0, 2, ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dkyr2k( CblasRowMajor, CblasUpper, CblasTrans, + 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dkyr2k( CblasRowMajor, CblasLower, CblasNoTrans, + 0, 2, ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_dkyr2k( CblasRowMajor, CblasLower, CblasTrans, + 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dkyr2k( CblasColMajor, CblasUpper, CblasNoTrans, + 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dkyr2k( CblasColMajor, CblasUpper, CblasTrans, + 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dkyr2k( CblasColMajor, CblasLower, CblasNoTrans, + 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_dkyr2k( CblasColMajor, CblasLower, CblasTrans, + 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_dkyr2k( CblasRowMajor, CblasUpper, CblasNoTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_dkyr2k( CblasRowMajor, CblasUpper, CblasTrans, + 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_dkyr2k( CblasRowMajor, CblasLower, CblasNoTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_dkyr2k( CblasRowMajor, CblasLower, CblasTrans, + 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_dkyr2k( CblasColMajor, CblasUpper, CblasNoTrans, + 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_dkyr2k( CblasColMajor, CblasUpper, CblasTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_dkyr2k( CblasColMajor, CblasLower, CblasNoTrans, + 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_dkyr2k( CblasColMajor, CblasLower, CblasTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); } if (cblas_ok == TRUE ) printf(" %-13s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout); diff --git a/CBLAS/testing/c_dblas2.c b/CBLAS/testing/c_dblas2.c index e8cc2bd23..2224c2e1e 100644 --- a/CBLAS/testing/c_dblas2.c +++ b/CBLAS/testing/c_dblas2.c @@ -152,6 +152,34 @@ void F77_dsymv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, double *alpha, doub *beta, y, *incy ); } +void F77_dkymv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, double *alpha, double *a, + CBLAS_INT *lda, double *x, CBLAS_INT *incx, double *beta, double *y, + CBLAS_INT *incy +#ifdef BLAS_FORTRAN_STRLEN_END + , FORTRAN_STRLEN uplow_len +#endif +) { + double *A; + CBLAS_INT i,j,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A = ( double* )malloc( (*n)*LDA*sizeof( double ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[ LDA*i+j ]=a[ (*lda)*j+i ]; + cblas_dkymv(CblasRowMajor, uplo, *n, *alpha, A, LDA, x, *incx, + *beta, y, *incy ); + free(A); + } + else + cblas_dkymv(CblasColMajor, uplo, *n, *alpha, a, *lda, x, *incx, + *beta, y, *incy ); +} + void F77_dsyr(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, double *alpha, double *x, CBLAS_INT *incx, double *a, CBLAS_INT *lda #ifdef BLAS_FORTRAN_STRLEN_END @@ -208,6 +236,34 @@ void F77_dsyr2(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, double *alpha, doub cblas_dsyr2(CblasColMajor, uplo, *n, *alpha, x, *incx, y, *incy, a, *lda); } +void F77_dkyr2(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, double *alpha, double *x, + CBLAS_INT *incx, double *y, CBLAS_INT *incy, double *a, CBLAS_INT *lda +#ifdef BLAS_FORTRAN_STRLEN_END + , FORTRAN_STRLEN uplow_len +#endif +) { + double *A; + CBLAS_INT i,j,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A = ( double* )malloc( (*n)*LDA*sizeof( double ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[ LDA*i+j ]=a[ (*lda)*j+i ]; + cblas_dkyr2(CblasRowMajor, uplo, *n, *alpha, x, *incx, y, *incy, A, LDA); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + a[ (*lda)*j+i ]=A[ LDA*i+j ]; + free(A); + } + else + cblas_dkyr2(CblasColMajor, uplo, *n, *alpha, x, *incx, y, *incy, a, *lda); +} + void F77_dgbmv(CBLAS_INT *layout, char *transp, CBLAS_INT *m, CBLAS_INT *n, CBLAS_INT *kl, CBLAS_INT *ku, double *alpha, double *a, CBLAS_INT *lda, double *x, CBLAS_INT *incx, double *beta, double *y, CBLAS_INT *incy diff --git a/CBLAS/testing/c_dblas3.c b/CBLAS/testing/c_dblas3.c index 675f0ebfc..eab809085 100644 --- a/CBLAS/testing/c_dblas3.c +++ b/CBLAS/testing/c_dblas3.c @@ -214,6 +214,64 @@ void F77_dsymm(CBLAS_INT *layout, char *rtlf, char *uplow, CBLAS_INT *m, CBLAS_I *beta, c, *ldc ); } +void F77_dkymm(CBLAS_INT *layout, char *rtlf, char *uplow, CBLAS_INT *m, CBLAS_INT *n, + double *alpha, double *a, CBLAS_INT *lda, double *b, CBLAS_INT *ldb, + double *beta, double *c, CBLAS_INT *ldc +#ifdef BLAS_FORTRAN_STRLEN_END + , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len +#endif +) { + + double *A, *B, *C; + CBLAS_INT i,j,LDA, LDB, LDC; + CBLAS_UPLO uplo; + CBLAS_SIDE side; + + get_uplo_type(uplow,&uplo); + get_side_type(rtlf,&side); + + if (*layout == TEST_ROW_MJR) { + if (side == CblasLeft) { + LDA = *m+1; + A = ( double* )malloc( (*m)*LDA*sizeof( double ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*m; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + else{ + LDA = *n+1; + A = ( double* )malloc( (*n)*LDA*sizeof( double ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + LDB = *n+1; + B = ( double* )malloc( (*m)*LDB*sizeof( double ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ) + B[i*LDB+j]=b[j*(*ldb)+i]; + LDC = *n+1; + C = ( double* )malloc( (*m)*LDC*sizeof( double ) ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) + C[i*LDC+j]=c[j*(*ldc)+i]; + cblas_dkymm( CblasRowMajor, side, uplo, *m, *n, *alpha, A, LDA, B, LDB, + *beta, C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) + c[j*(*ldc)+i]=C[i*LDC+j]; + free(A); + free(B); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_dkymm( CblasColMajor, side, uplo, *m, *n, *alpha, a, *lda, b, *ldb, + *beta, c, *ldc ); + else + cblas_dkymm( UNDEFINED, side, uplo, *m, *n, *alpha, a, *lda, b, *ldb, + *beta, c, *ldc ); +} + void F77_dsyrk(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS_INT *k, double *alpha, double *a, CBLAS_INT *lda, double *beta, double *c, CBLAS_INT *ldc @@ -325,6 +383,65 @@ void F77_dsyr2k(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLA cblas_dsyr2k(UNDEFINED, uplo, trans, *n, *k, *alpha, a, *lda, b, *ldb, *beta, c, *ldc ); } +void F77_dkyr2k(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS_INT *k, + double *alpha, double *a, CBLAS_INT *lda, double *b, CBLAS_INT *ldb, + double *beta, double *c, CBLAS_INT *ldc +#ifdef BLAS_FORTRAN_STRLEN_END + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len +#endif +) { + CBLAS_INT i,j,LDA,LDB,LDC; + double *A, *B, *C; + CBLAS_UPLO uplo; + CBLAS_TRANSPOSE trans; + + get_uplo_type(uplow,&uplo); + get_transpose_type(transp,&trans); + + if (*layout == TEST_ROW_MJR) { + if (trans == CblasNoTrans) { + LDA = *k+1; + LDB = *k+1; + A = ( double* )malloc( (*n)*LDA*sizeof( double ) ); + B = ( double* )malloc( (*n)*LDB*sizeof( double ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*k; j++ ) { + A[i*LDA+j]=a[j*(*lda)+i]; + B[i*LDB+j]=b[j*(*ldb)+i]; + } + } + else { + LDA = *n+1; + LDB = *n+1; + A = ( double* )malloc( LDA*(*k)*sizeof( double ) ); + B = ( double* )malloc( LDB*(*k)*sizeof( double ) ); + for( i=0; i<*k; i++ ) + for( j=0; j<*n; j++ ){ + A[i*LDA+j]=a[j*(*lda)+i]; + B[i*LDB+j]=b[j*(*ldb)+i]; + } + } + LDC = *n+1; + C = ( double* )malloc( (*n)*LDC*sizeof( double ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + C[i*LDC+j]=c[j*(*ldc)+i]; + cblas_dkyr2k(CblasRowMajor, uplo, trans, *n, *k, *alpha, A, LDA, + B, LDB, *beta, C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*n; i++ ) + c[j*(*ldc)+i]=C[i*LDC+j]; + free(A); + free(B); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_dkyr2k(CblasColMajor, uplo, trans, *n, *k, *alpha, a, *lda, + b, *ldb, *beta, c, *ldc ); + else + cblas_dkyr2k(UNDEFINED, uplo, trans, *n, *k, *alpha, a, *lda, + b, *ldb, *beta, c, *ldc ); +} void F77_dtrmm(CBLAS_INT *layout, char *rtlf, char *uplow, char *transp, char *diagn, CBLAS_INT *m, CBLAS_INT *n, double *alpha, double *a, CBLAS_INT *lda, double *b, CBLAS_INT *ldb diff --git a/CBLAS/testing/c_dblat2.f b/CBLAS/testing/c_dblat2.f index 27ceda622..e63977fe3 100644 --- a/CBLAS/testing/c_dblat2.f +++ b/CBLAS/testing/c_dblat2.f @@ -3,7 +3,7 @@ PROGRAM DBLAT2 * Test program for the DOUBLE PRECISION Level 2 Blas. * * The program must be driven by a short data file. The first 17 records -* of the file are read using list-directed input, the last 16 records +* of the file are read using list-directed input, the last 18 records * are read using the format ( A12, L2 ). An annotated example of a data * file can be obtained by deleting the first 3 characters from the * following 33 lines: @@ -27,6 +27,7 @@ PROGRAM DBLAT2 * cblas_dgemv T PUT F FOR NO TEST. SAME COLUMNS. * cblas_dgbmv T PUT F FOR NO TEST. SAME COLUMNS. * cblas_dsymv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_dkymv T PUT F FOR NO TEST. SAME COLUMNS. * cblas_dsbmv T PUT F FOR NO TEST. SAME COLUMNS. * cblas_dspmv T PUT F FOR NO TEST. SAME COLUMNS. * cblas_dtrmv T PUT F FOR NO TEST. SAME COLUMNS. @@ -40,6 +41,7 @@ PROGRAM DBLAT2 * cblas_dspr T PUT F FOR NO TEST. SAME COLUMNS. * cblas_dsyr2 T PUT F FOR NO TEST. SAME COLUMNS. * cblas_dspr2 T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_dkyr2 T PUT F FOR NO TEST. SAME COLUMNS. * * See: * @@ -66,7 +68,7 @@ PROGRAM DBLAT2 INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NSUBS - PARAMETER ( NSUBS = 16 ) + PARAMETER ( NSUBS = 18 ) DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) INTEGER NMAX, INCMAX @@ -115,7 +117,8 @@ PROGRAM DBLAT2 $ 'cblas_dtrmv ','cblas_dtbmv ','cblas_dtpmv ', $ 'cblas_dtrsv ','cblas_dtbsv ','cblas_dtpsv ', $ 'cblas_dger ','cblas_dsyr ','cblas_dspr ', - $ 'cblas_dsyr2 ','cblas_dspr2 '/ + $ 'cblas_dsyr2 ','cblas_dspr2 ','cblas_dkymv ', + $ 'cblas_dkyr2 '/ * .. Executable Statements .. * NOUTC = NOUT @@ -310,7 +313,7 @@ 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 IF (CORDER) THEN CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, @@ -325,7 +328,7 @@ PROGRAM DBLAT2 $ X, XX, XS, Y, YY, YS, YT, G, 1 ) END IF GO TO 200 -* Test DSYMV, 03, DSBMV, 04, and DSPMV, 05. +* Test DSYMV, 03, DSBMV, 04, and DSPMV, 05, and DKYMV, 17. 150 IF (CORDER) THEN CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, @@ -382,7 +385,7 @@ PROGRAM DBLAT2 $ YT, G, Z, 1 ) END IF GO TO 200 -* Test DSYR2, 15, and DSPR2, 16. +* Test DSYR2, 15, and DSPR2, 16, and DKYR2, 18. 190 IF (CORDER) THEN CALL DCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, @@ -818,7 +821,7 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, $ XS, Y, YY, YS, YT, G, IORDER ) * -* Tests DSYMV, DSBMV and DSPMV. +* Tests DSYMV, DKYMV, DSBMV and DSPMV. * * Auxiliary routine for test program for Level 2 Blas. * @@ -848,7 +851,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, + $ KYFULL CHARACTER*1 UPLO, UPLOS CHARACTER*14 CUPLO CHARACTER*2 ICH @@ -858,7 +862,7 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, LOGICAL LDE, LDERES EXTERNAL LDE, LDERES * .. External Subroutines .. - EXTERNAL DMAKE, DMVCH, CDSBMV, CDSPMV, CDSYMV + EXTERNAL DMAKE, DMVCH, CDSBMV, CDSPMV, CDSYMV, CDKYMV * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. Scalars in Common .. @@ -869,11 +873,12 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * .. Data statements .. DATA ICH/'UL'/ * .. Executable Statements .. - FULL = SNAME( 9: 9 ).EQ.'y' + FULL = SNAME( 8: 8 ).NE.'k'.AND.SNAME( 9: 9 ).EQ.'y' BANDED = SNAME( 9: 9 ).EQ.'b' PACKED = SNAME( 9: 9 ).EQ.'p' + KYFULL = SNAME( 8: 8 ).EQ.'k' * Define the number of arguments. - IF( FULL )THEN + IF( FULL.OR.KYFULL )THEN NARGS = 10 ELSE IF( BANDED )THEN NARGS = 11 @@ -994,6 +999,14 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, IF( REWI ) $ REWIND NTRA CALL CDSYMV( IORDER, UPLO, N, ALPHA, AA, + $ LDA, XX, INCX, BETA, YY, INCY ) + ELSE IF( KYFULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, + $ CUPLO, N, ALPHA, LDA, INCX, BETA, INCY + IF( REWI ) + $ REWIND NTRA + CALL CDKYMV( IORDER, UPLO, N, ALPHA, AA, $ LDA, XX, INCX, BETA, YY, INCY ) ELSE IF( BANDED )THEN IF( TRACE ) @@ -1027,7 +1040,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.KYFULL )THEN ISAME( 3 ) = ALS.EQ.ALPHA ISAME( 4 ) = LDE( AS, AA, LAA ) ISAME( 5 ) = LDAS.EQ.LDA @@ -2133,7 +2146,7 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, $ Z, IORDER ) * -* Tests DSYR2 and DSPR2. +* Tests DSYR2, DKYR2 and DSPR2. * * Auxiliary routine for test program for Level 2 Blas. * @@ -2162,7 +2175,7 @@ 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, KYFULL CHARACTER*1 UPLO, UPLOS CHARACTER*14 CUPLO CHARACTER*2 ICH @@ -2173,7 +2186,7 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, LOGICAL LDE, LDERES EXTERNAL LDE, LDERES * .. External Subroutines .. - EXTERNAL DMAKE, DMVCH, CDSPR2, CDSYR2 + EXTERNAL DMAKE, DMVCH, CDSPR2, CDSYR2, CDKYR2 * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. Scalars in Common .. @@ -2184,8 +2197,9 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * .. Data statements .. DATA ICH/'UL'/ * .. Executable Statements .. - FULL = SNAME( 9: 9 ).EQ.'y' + FULL = SNAME( 8: 8 ).NE.'k'.AND.SNAME( 9: 9 ).EQ.'y' PACKED = SNAME( 9: 9 ).EQ.'p' + KYFULL = SNAME( 8: 8 ).EQ.'k' * Define the number of arguments. IF( FULL )THEN NARGS = 9 @@ -2289,6 +2303,14 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, IF( REWI ) $ REWIND NTRA CALL CDSYR2( IORDER, UPLO, N, ALPHA, XX, INCX, + $ YY, INCY, AA, LDA ) + ELSE IF( KYFULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, CUPLO, N, + $ ALPHA, INCX, INCY, LDA + IF( REWI ) + $ REWIND NTRA + CALL CDKYR2( IORDER, UPLO, N, ALPHA, XX, INCX, $ YY, INCY, AA, LDA ) ELSE IF( PACKED )THEN IF( TRACE ) @@ -2362,22 +2384,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.KYFULL.OR.UPPER )THEN + JA = 1 + ELSE + JA = 2 + END IF DO 90 J = 1, N - W( 1 ) = Z( J, 2 ) + IF( .NOT.KYFULL )THEN + W( 1 ) = Z( J, 2 ) + ELSE + W( 1 ) = -Z( J, 2 ) + END IF W( 2 ) = Z( J, 1 ) - IF( UPPER )THEN + IF( .NOT.KYFULL.AND.UPPER )THEN JJ = 1 LJ = J - ELSE + ELSE IF( .NOT.KYFULL.AND..NOT.UPPER )THEN JJ = J LJ = N - J + 1 + ELSE IF( KYFULL.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.KYFULL )THEN IF( UPPER )THEN JA = JA + LDA ELSE @@ -2423,7 +2459,7 @@ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * 160 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN + IF( FULL.OR.KYFULL )THEN WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, ALPHA, INCX, $ INCY, LDA ELSE IF( PACKED )THEN @@ -2468,7 +2504,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', 'ky', 'sb', 'sp', 'tr', 'tb' OR 'tp'. * * Auxiliary routine for test program for Level 2 Blas. * @@ -2491,7 +2527,7 @@ 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, SKY * .. External Functions .. DOUBLE PRECISION DBEG EXTERNAL DBEG @@ -2500,9 +2536,10 @@ SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, * .. Executable Statements .. GEN = TYPE( 1: 1 ).EQ.'g' SYM = TYPE( 1: 1 ).EQ.'s' + SKY = TYPE( 1: 1 ).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.SKY.OR.TRI ).AND.UPLO.EQ.'U' + LOWER = ( SYM.OR.SKY.OR.TRI ).AND.UPLO.EQ.'L' UNIT = TRI.AND.DIAG.EQ.'U' * * Generate data in array A. @@ -2520,6 +2557,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( SKY )THEN + A( J, I ) = -A( I, J ) ELSE IF( TRI )THEN A( J, I ) = ZERO END IF @@ -2530,6 +2569,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( SKY ) + $ A( J, J ) = ZERO 20 CONTINUE * * Store elements in array AS in data structure required by routine. @@ -2555,17 +2596,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.'ky'.OR.TYPE.EQ.'tr' )THEN DO 130 J = 1, N IF( UPPER )THEN IBEG = 1 - IF( UNIT )THEN + IF( UNIT.OR.SKY )THEN IEND = J - 1 ELSE IEND = J END IF ELSE - IF( UNIT )THEN + IF( UNIT.OR.SKY )THEN IBEG = J + 1 ELSE IBEG = J @@ -2813,14 +2854,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.'ky' )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.'ky' )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 ) ) diff --git a/CBLAS/testing/c_dblat3.f b/CBLAS/testing/c_dblat3.f index e88a77dc7..908ef8479 100644 --- a/CBLAS/testing/c_dblat3.f +++ b/CBLAS/testing/c_dblat3.f @@ -3,7 +3,7 @@ PROGRAM DBLAT3 * Test program for the DOUBLE PRECISION Level 3 Blas. * * The program must be driven by a short data file. The first 13 records -* of the file are read using list-directed input, the last 6 records +* of the file are read using list-directed input, the last 8 records * are read using the format ( A13, L2 ). An annotated example of a data * file can be obtained by deleting the first 3 characters from the * following 19 lines: @@ -22,10 +22,12 @@ PROGRAM DBLAT3 * 0.0 1.0 1.3 VALUES OF BETA * cblas_dgemm T PUT F FOR NO TEST. SAME COLUMNS. * cblas_dsymm T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_dkymm T PUT F FOR NO TEST. SAME COLUMNS. * cblas_dtrmm T PUT F FOR NO TEST. SAME COLUMNS. * cblas_dtrsm T PUT F FOR NO TEST. SAME COLUMNS. * cblas_dsyrk T PUT F FOR NO TEST. SAME COLUMNS. * cblas_dsyr2k T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_dkyr2k T PUT F FOR NO TEST. SAME COLUMNS. * cblas_dgemmtr T PUT F FOR NO TEST. SAME COLUMNS. * * See: @@ -47,7 +49,7 @@ PROGRAM DBLAT3 INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NSUBS - PARAMETER ( NSUBS = 7 ) + PARAMETER ( NSUBS = 9 ) DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) INTEGER NMAX @@ -92,7 +94,8 @@ PROGRAM DBLAT3 * .. Data statements .. DATA SNAMES/'cblas_dgemm ', 'cblas_dsymm ', $ 'cblas_dtrmm ', 'cblas_dtrsm ','cblas_dsyrk ', - $ 'cblas_dsyr2k', 'cblas_dgemmtr'/ + $ 'cblas_dsyr2k', 'cblas_dgemmtr', + $ 'cblas_dkymm ', 'cblas_dkyr2k'/ * .. Executable Statements .. * * Read name and unit number for summary output file and open file. @@ -290,7 +293,7 @@ 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 IF (CORDER) THEN CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, @@ -305,7 +308,7 @@ PROGRAM DBLAT3 $ CC, CS, CT, G, 1 ) END IF GO TO 190 -* Test DSYMM, 02. +* Test DSYMM, 02 and DKYMM, 08. 150 IF (CORDER) THEN CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, @@ -347,7 +350,7 @@ PROGRAM DBLAT3 $ CC, CS, CT, G, 1 ) END IF GO TO 190 -* Test DSYR2K, 06. +* Test DSYR2K, 06 and DKYR2K, 09. 180 IF (CORDER) THEN CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, @@ -788,7 +791,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, KYFULL CHARACTER*1 SIDE, SIDES, UPLO, UPLOS CHARACTER*2 ICHS, ICHU * .. Local Arrays .. @@ -797,7 +800,7 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, LOGICAL LDE, LDERES EXTERNAL LDE, LDERES * .. External Subroutines .. - EXTERNAL DMAKE, DMMCH, CDSYMM + EXTERNAL DMAKE, DMMCH, CDSYMM, CDKYMM * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. @@ -809,6 +812,7 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DATA ICHS/'LR'/, ICHU/'UL'/ * .. Executable Statements .. * + KYFULL = SNAME( 8: 8 ).EQ.'k' NARGS = 12 NC = 0 RESET = .TRUE. @@ -866,8 +870,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.KYFULL) THEN + CALL DMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, + $ LDA, RESET, ZERO ) + ELSE + CALL DMAKE( 'KY', UPLO, ' ', NA, NA, A, NMAX, AA, + $ LDA, RESET, ZERO ) + END IF * DO 60 IA = 1, NALF ALPHA = ALF( IA ) @@ -912,8 +921,13 @@ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ BETA, LDC) IF( REWI ) $ REWIND NTRA - CALL CDSYMM( IORDER, SIDE, UPLO, M, N, ALPHA, - $ AA, LDA, BB, LDB, BETA, CC, LDC ) + IF(.NOT.KYFULL) THEN + CALL CDSYMM( IORDER, SIDE, UPLO, M, N, + $ ALPHA, AA, LDA, BB, LDB, BETA, CC, LDC ) + ELSE + CALL CDKYMM( IORDER, SIDE, UPLO, M, N, + $ ALPHA, AA, LDA, BB, LDB, BETA, CC, LDC ) + END IF * * Check if error-exit was taken incorrectly. * @@ -1774,7 +1788,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, KYFULL CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS CHARACTER*2 ICHU CHARACTER*3 ICHT @@ -1784,7 +1798,7 @@ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, LOGICAL LDE, LDERES EXTERNAL LDE, LDERES * .. External Subroutines .. - EXTERNAL DMAKE, DMMCH, CDSYR2K + EXTERNAL DMAKE, DMMCH, CDSYR2K, CDKYR2K * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. @@ -1796,6 +1810,7 @@ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DATA ICHT/'NTC'/, ICHU/'UL'/ * .. Executable Statements .. * + KYFULL = SNAME( 8: 8 ).EQ.'k' NARGS = 12 NC = 0 RESET = .TRUE. @@ -1869,8 +1884,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.KYFULL) THEN + CALL DMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, + $ CC, LDC, RESET, ZERO ) + ELSE + CALL DMAKE( 'KY', UPLO, ' ', N, N, C, NMAX, + $ CC, LDC, RESET, ZERO ) + END IF * NC = NC + 1 * @@ -1902,9 +1922,13 @@ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC) IF( REWI ) $ REWIND NTRA - CALL CDSYR2K( IORDER, UPLO, TRANS, N, K, - $ ALPHA, AA, LDA, BB, LDB, BETA, - $ CC, LDC ) + IF(.NOT.KYFULL) THEN + CALL CDSYR2K( IORDER, UPLO, TRANS, N, K, + $ ALPHA, AA, LDA, BB, LDB, BETA, CC, LDC ) + ELSE + CALL CDKYR2K( IORDER, UPLO, TRANS, N, K, + $ ALPHA, AA, LDA, BB, LDB, BETA, CC, LDC ) + END IF * * Check if error-exit was taken incorrectly. * @@ -1929,8 +1953,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.KYFULL) THEN + ISAME( 11 ) = LDERES( 'SY', UPLO, N, N, + $ CS, CC, LDC ) + ELSE + ISAME( 11 ) = LDERES( 'KY', UPLO, N, N, + $ CS, CC, LDC ) + END IF END IF ISAME( 12 ) = LDCS.EQ.LDC * @@ -1952,20 +1981,36 @@ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * * Check the result column by column. * - JJAB = 1 - JC = 1 + IF( .NOT.KYFULL.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.KYFULL.AND.UPPER )THEN JJ = 1 LJ = J - ELSE + ELSE IF( .NOT.KYFULL.AND..NOT.UPPER )THEN JJ = J LJ = N - J + 1 + ELSE IF( KYFULL.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.KYFULL) 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 @@ -1977,8 +2022,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.KYFULL) 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 @@ -2103,7 +2153,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', 'KY' or 'TR'. * * Auxiliary routine for test program for Level 3 Blas. * @@ -2128,7 +2178,7 @@ 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, SKY * .. External Functions .. DOUBLE PRECISION DBEG EXTERNAL DBEG @@ -2136,8 +2186,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' + SKY = TYPE.EQ.'KY' + UPPER = ( SYM.OR.SKY.OR.TRI ).AND.UPLO.EQ.'U' + LOWER = ( SYM.OR.SKY.OR.TRI ).AND.UPLO.EQ.'L' UNIT = TRI.AND.DIAG.EQ.'U' * * Generate data in array A. @@ -2153,6 +2204,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( SKY )THEN + A( J, I ) = -A( I, J ) ELSE IF( TRI )THEN A( J, I ) = ZERO END IF @@ -2163,6 +2216,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( SKY ) + $ A( J, J ) = ZERO 20 CONTINUE * * Store elements in array AS in data structure required by routine. @@ -2176,17 +2231,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.'KY'.OR.TYPE.EQ.'TR' )THEN DO 90 J = 1, N IF( UPPER )THEN IBEG = 1 - IF( UNIT )THEN + IF( UNIT.OR.SKY )THEN IEND = J - 1 ELSE IEND = J END IF ELSE - IF( UNIT )THEN + IF( UNIT.OR.SKY )THEN IBEG = J + 1 ELSE IBEG = J @@ -2367,7 +2422,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 'KY'. * * Auxiliary routine for test program for Level 3 Blas. * @@ -2395,14 +2450,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.'KY' )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.'KY' )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 ) ) diff --git a/CBLAS/testing/c_s2chke.c b/CBLAS/testing/c_s2chke.c index fb3bd16c2..fc5ed1c8b 100644 --- a/CBLAS/testing/c_s2chke.c +++ b/CBLAS/testing/c_s2chke.c @@ -224,6 +224,52 @@ void F77_s2chke(char *rout cblas_ssymv(CblasRowMajor, CblasUpper, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ); chkxer(); + } else if (strncmp( sf,"cblas_skymv",11)==0) { + cblas_rout = "cblas_skymv"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_skymv(INVALID, CblasUpper, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_skymv(CblasColMajor, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_skymv(CblasColMajor, CblasUpper, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_skymv(CblasColMajor, CblasUpper, 2, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_skymv(CblasColMajor, CblasUpper, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = FALSE; + cblas_skymv(CblasColMajor, CblasUpper, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_skymv(CblasRowMajor, INVALID, 0, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_skymv(CblasRowMajor, CblasUpper, INVALID, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_skymv(CblasRowMajor, CblasUpper, 2, + ALPHA, A, 1, X, 1, BETA, Y, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_skymv(CblasRowMajor, CblasUpper, 0, + ALPHA, A, 1, X, 0, BETA, Y, 1 ); + chkxer(); + cblas_info = 11; RowMajorStrg = TRUE; + cblas_skymv(CblasRowMajor, CblasUpper, 0, + ALPHA, A, 1, X, 1, BETA, Y, 0 ); + chkxer(); } else if (strncmp( sf,"cblas_ssbmv",11)==0) { cblas_rout = "cblas_ssbmv"; cblas_info = 1; RowMajorStrg = FALSE; @@ -710,6 +756,41 @@ void F77_s2chke(char *rout cblas_info = 10; RowMajorStrg = TRUE; cblas_ssyr2(CblasRowMajor, CblasUpper, 2, ALPHA, X, 1, Y, 1, A, 1 ); chkxer(); + } else if (strncmp( sf,"cblas_skyr2",11)==0) { + cblas_rout = "cblas_skyr2"; + cblas_info = 1; RowMajorStrg = FALSE; + cblas_skyr2(INVALID, CblasUpper, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_skyr2(CblasColMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_skyr2(CblasColMajor, CblasUpper, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = FALSE; + cblas_skyr2(CblasColMajor, CblasUpper, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_skyr2(CblasColMajor, CblasUpper, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_skyr2(CblasColMajor, CblasUpper, 2, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = TRUE; + cblas_skyr2(CblasRowMajor, INVALID, 0, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = TRUE; + cblas_skyr2(CblasRowMajor, CblasUpper, INVALID, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); + cblas_info = 6; RowMajorStrg = TRUE; + cblas_skyr2(CblasRowMajor, CblasUpper, 0, ALPHA, X, 0, Y, 1, A, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_skyr2(CblasRowMajor, CblasUpper, 0, ALPHA, X, 1, Y, 0, A, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_skyr2(CblasRowMajor, CblasUpper, 2, ALPHA, X, 1, Y, 1, A, 1 ); + chkxer(); } else if (strncmp( sf,"cblas_sspr2",11)==0) { cblas_rout = "cblas_sspr2"; cblas_info = 1; RowMajorStrg = FALSE; diff --git a/CBLAS/testing/c_s3chke.c b/CBLAS/testing/c_s3chke.c index 2009e388a..89696be49 100644 --- a/CBLAS/testing/c_s3chke.c +++ b/CBLAS/testing/c_s3chke.c @@ -688,6 +688,183 @@ void F77_s3chke(char *rout ALPHA, A, 2, B, 2, BETA, C, 1 ); chkxer(); + } else if (strncmp( sf,"cblas_skymm" ,11)==0) { + cblas_rout = "cblas_skymm" ; + + cblas_info = 1; + cblas_skymm( INVALID, CblasRight, CblasLower, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_skymm( CblasColMajor, INVALID, CblasUpper, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_skymm( CblasColMajor, CblasLeft, INVALID, 0, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_skymm( CblasColMajor, CblasLeft, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_skymm( CblasColMajor, CblasRight, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_skymm( CblasColMajor, CblasLeft, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_skymm( CblasColMajor, CblasRight, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_skymm( CblasColMajor, CblasLeft, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_skymm( CblasColMajor, CblasRight, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_skymm( CblasColMajor, CblasLeft, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_skymm( CblasColMajor, CblasRight, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_skymm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_skymm( CblasColMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_skymm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_skymm( CblasColMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_skymm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_skymm( CblasColMajor, CblasRight, CblasUpper, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_skymm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_skymm( CblasColMajor, CblasRight, CblasLower, 2, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_skymm( CblasColMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_skymm( CblasColMajor, CblasRight, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_skymm( CblasColMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_skymm( CblasColMajor, CblasRight, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + + cblas_info = 4; RowMajorStrg = TRUE; + cblas_skymm( CblasRowMajor, CblasLeft, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_skymm( CblasRowMajor, CblasRight, CblasUpper, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_skymm( CblasRowMajor, CblasLeft, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = TRUE; + cblas_skymm( CblasRowMajor, CblasRight, CblasLower, INVALID, 0, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_skymm( CblasRowMajor, CblasLeft, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_skymm( CblasRowMajor, CblasRight, CblasUpper, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_skymm( CblasRowMajor, CblasLeft, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = TRUE; + cblas_skymm( CblasRowMajor, CblasRight, CblasLower, 0, INVALID, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_skymm( CblasRowMajor, CblasLeft, CblasUpper, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_skymm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_skymm( CblasRowMajor, CblasLeft, CblasLower, 2, 0, + ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_skymm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_skymm( CblasRowMajor, CblasLeft, CblasUpper, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_skymm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_skymm( CblasRowMajor, CblasLeft, CblasLower, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_skymm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_skymm( CblasRowMajor, CblasLeft, CblasUpper, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_skymm( CblasRowMajor, CblasRight, CblasUpper, 0, 2, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_skymm( CblasRowMajor, CblasLeft, CblasLower, 0, 2, + ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_skymm( CblasRowMajor, CblasRight, CblasLower, 0, 2, + ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + } else if (strncmp( sf,"cblas_strmm" ,11)==0) { cblas_rout = "cblas_strmm" ; @@ -1505,6 +1682,149 @@ void F77_s3chke(char *rout cblas_ssyr2k( CblasColMajor, CblasLower, CblasTrans, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); chkxer(); + } else if (strncmp( sf,"cblas_skyr2k" ,12)==0) { + cblas_rout = "cblas_skyr2k" ; + + cblas_info = 1; + cblas_skyr2k( INVALID, CblasUpper, CblasNoTrans, + 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 2; RowMajorStrg = FALSE; + cblas_skyr2k( CblasColMajor, INVALID, CblasNoTrans, + 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 3; RowMajorStrg = FALSE; + cblas_skyr2k( CblasColMajor, CblasUpper, INVALID, + 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_skyr2k( CblasColMajor, CblasUpper, CblasNoTrans, + INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_skyr2k( CblasColMajor, CblasUpper, CblasTrans, + INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_skyr2k( CblasColMajor, CblasLower, CblasNoTrans, + INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 4; RowMajorStrg = FALSE; + cblas_skyr2k( CblasColMajor, CblasLower, CblasTrans, + INVALID, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_skyr2k( CblasColMajor, CblasUpper, CblasNoTrans, + 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_skyr2k( CblasColMajor, CblasUpper, CblasTrans, + 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_skyr2k( CblasColMajor, CblasLower, CblasNoTrans, + 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 5; RowMajorStrg = FALSE; + cblas_skyr2k( CblasColMajor, CblasLower, CblasTrans, + 0, INVALID, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_skyr2k( CblasRowMajor, CblasUpper, CblasNoTrans, + 0, 2, ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_skyr2k( CblasRowMajor, CblasUpper, CblasTrans, + 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_skyr2k( CblasRowMajor, CblasLower, CblasNoTrans, + 0, 2, ALPHA, A, 1, B, 2, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = TRUE; + cblas_skyr2k( CblasRowMajor, CblasLower, CblasTrans, + 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_skyr2k( CblasColMajor, CblasUpper, CblasNoTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_skyr2k( CblasColMajor, CblasUpper, CblasTrans, + 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_skyr2k( CblasColMajor, CblasLower, CblasNoTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 8; RowMajorStrg = FALSE; + cblas_skyr2k( CblasColMajor, CblasLower, CblasTrans, + 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_skyr2k( CblasRowMajor, CblasUpper, CblasNoTrans, + 0, 2, ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_skyr2k( CblasRowMajor, CblasUpper, CblasTrans, + 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_skyr2k( CblasRowMajor, CblasLower, CblasNoTrans, + 0, 2, ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = TRUE; + cblas_skyr2k( CblasRowMajor, CblasLower, CblasTrans, + 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_skyr2k( CblasColMajor, CblasUpper, CblasNoTrans, + 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_skyr2k( CblasColMajor, CblasUpper, CblasTrans, + 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_skyr2k( CblasColMajor, CblasLower, CblasNoTrans, + 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ); + chkxer(); + cblas_info = 10; RowMajorStrg = FALSE; + cblas_skyr2k( CblasColMajor, CblasLower, CblasTrans, + 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_skyr2k( CblasRowMajor, CblasUpper, CblasNoTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_skyr2k( CblasRowMajor, CblasUpper, CblasTrans, + 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_skyr2k( CblasRowMajor, CblasLower, CblasNoTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = TRUE; + cblas_skyr2k( CblasRowMajor, CblasLower, CblasTrans, + 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_skyr2k( CblasColMajor, CblasUpper, CblasNoTrans, + 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_skyr2k( CblasColMajor, CblasUpper, CblasTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_skyr2k( CblasColMajor, CblasLower, CblasNoTrans, + 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ); + chkxer(); + cblas_info = 13; RowMajorStrg = FALSE; + cblas_skyr2k( CblasColMajor, CblasLower, CblasTrans, + 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ); + chkxer(); } if (cblas_ok == TRUE ) printf(" %-13s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout); diff --git a/CBLAS/testing/c_sblas2.c b/CBLAS/testing/c_sblas2.c index dd1a949ef..31dd04b39 100644 --- a/CBLAS/testing/c_sblas2.c +++ b/CBLAS/testing/c_sblas2.c @@ -152,6 +152,34 @@ void F77_ssymv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, float *alpha, float *beta, y, *incy ); } +void F77_skymv(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, float *alpha, float *a, + CBLAS_INT *lda, float *x, CBLAS_INT *incx, float *beta, float *y, + CBLAS_INT *incy +#ifdef BLAS_FORTRAN_STRLEN_END + , FORTRAN_STRLEN uplow_len +#endif +) { + float *A; + CBLAS_INT i,j,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A = ( float* )malloc( (*n)*LDA*sizeof( float ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[ LDA*i+j ]=a[ (*lda)*j+i ]; + cblas_skymv(CblasRowMajor, uplo, *n, *alpha, A, LDA, x, *incx, + *beta, y, *incy ); + free(A); + } + else + cblas_skymv(CblasColMajor, uplo, *n, *alpha, a, *lda, x, *incx, + *beta, y, *incy ); +} + void F77_ssyr(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, float *alpha, float *x, CBLAS_INT *incx, float *a, CBLAS_INT *lda #ifdef BLAS_FORTRAN_STRLEN_END @@ -208,6 +236,34 @@ void F77_ssyr2(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, float *alpha, float cblas_ssyr2(CblasColMajor, uplo, *n, *alpha, x, *incx, y, *incy, a, *lda); } +void F77_skyr2(CBLAS_INT *layout, char *uplow, CBLAS_INT *n, float *alpha, float *x, + CBLAS_INT *incx, float *y, CBLAS_INT *incy, float *a, CBLAS_INT *lda +#ifdef BLAS_FORTRAN_STRLEN_END + , FORTRAN_STRLEN uplow_len +#endif +) { + float *A; + CBLAS_INT i,j,LDA; + CBLAS_UPLO uplo; + + get_uplo_type(uplow,&uplo); + + if (*layout == TEST_ROW_MJR) { + LDA = *n+1; + A = ( float* )malloc( (*n)*LDA*sizeof( float ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[ LDA*i+j ]=a[ (*lda)*j+i ]; + cblas_skyr2(CblasRowMajor, uplo, *n, *alpha, x, *incx, y, *incy, A, LDA); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + a[ (*lda)*j+i ]=A[ LDA*i+j ]; + free(A); + } + else + cblas_skyr2(CblasColMajor, uplo, *n, *alpha, x, *incx, y, *incy, a, *lda); +} + void F77_sgbmv(CBLAS_INT *layout, char *transp, CBLAS_INT *m, CBLAS_INT *n, CBLAS_INT *kl, CBLAS_INT *ku, float *alpha, float *a, CBLAS_INT *lda, float *x, CBLAS_INT *incx, float *beta, float *y, CBLAS_INT *incy diff --git a/CBLAS/testing/c_sblas3.c b/CBLAS/testing/c_sblas3.c index 0aaa57d2d..0f9cc0c0e 100644 --- a/CBLAS/testing/c_sblas3.c +++ b/CBLAS/testing/c_sblas3.c @@ -208,6 +208,64 @@ void F77_ssymm(CBLAS_INT *layout, char *rtlf, char *uplow, CBLAS_INT *m, CBLAS_I *beta, c, *ldc ); } +void F77_skymm(CBLAS_INT *layout, char *rtlf, char *uplow, CBLAS_INT *m, CBLAS_INT *n, + float *alpha, float *a, CBLAS_INT *lda, float *b, CBLAS_INT *ldb, + float *beta, float *c, CBLAS_INT *ldc +#ifdef BLAS_FORTRAN_STRLEN_END + , FORTRAN_STRLEN rtlf_len, FORTRAN_STRLEN uplow_len +#endif +) { + + float *A, *B, *C; + CBLAS_INT i,j,LDA, LDB, LDC; + CBLAS_UPLO uplo; + CBLAS_SIDE side; + + get_uplo_type(uplow,&uplo); + get_side_type(rtlf,&side); + + if (*layout == TEST_ROW_MJR) { + if (side == CblasLeft) { + LDA = *m+1; + A = ( float* )malloc( (*m)*LDA*sizeof( float ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*m; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + else{ + LDA = *n+1; + A = ( float* )malloc( (*n)*LDA*sizeof( float ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + A[i*LDA+j]=a[j*(*lda)+i]; + } + LDB = *n+1; + B = ( float* )malloc( (*m)*LDB*sizeof( float ) ); + for( i=0; i<*m; i++ ) + for( j=0; j<*n; j++ ) + B[i*LDB+j]=b[j*(*ldb)+i]; + LDC = *n+1; + C = ( float* )malloc( (*m)*LDC*sizeof( float ) ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) + C[i*LDC+j]=c[j*(*ldc)+i]; + cblas_skymm( CblasRowMajor, side, uplo, *m, *n, *alpha, A, LDA, B, LDB, + *beta, C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*m; i++ ) + c[j*(*ldc)+i]=C[i*LDC+j]; + free(A); + free(B); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_skymm( CblasColMajor, side, uplo, *m, *n, *alpha, a, *lda, b, *ldb, + *beta, c, *ldc ); + else + cblas_skymm( UNDEFINED, side, uplo, *m, *n, *alpha, a, *lda, b, *ldb, + *beta, c, *ldc ); +} + void F77_ssyrk(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS_INT *k, float *alpha, float *a, CBLAS_INT *lda, float *beta, float *c, CBLAS_INT *ldc @@ -319,6 +377,65 @@ void F77_ssyr2k(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLA cblas_ssyr2k(UNDEFINED, uplo, trans, *n, *k, *alpha, a, *lda, b, *ldb, *beta, c, *ldc ); } +void F77_skyr2k(CBLAS_INT *layout, char *uplow, char *transp, CBLAS_INT *n, CBLAS_INT *k, + float *alpha, float *a, CBLAS_INT *lda, float *b, CBLAS_INT *ldb, + float *beta, float *c, CBLAS_INT *ldc +#ifdef BLAS_FORTRAN_STRLEN_END + , FORTRAN_STRLEN uplow_len, FORTRAN_STRLEN transp_len +#endif +) { + CBLAS_INT i,j,LDA,LDB,LDC; + float *A, *B, *C; + CBLAS_UPLO uplo; + CBLAS_TRANSPOSE trans; + + get_uplo_type(uplow,&uplo); + get_transpose_type(transp,&trans); + + if (*layout == TEST_ROW_MJR) { + if (trans == CblasNoTrans) { + LDA = *k+1; + LDB = *k+1; + A = ( float* )malloc( (*n)*LDA*sizeof( float ) ); + B = ( float* )malloc( (*n)*LDB*sizeof( float ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*k; j++ ) { + A[i*LDA+j]=a[j*(*lda)+i]; + B[i*LDB+j]=b[j*(*ldb)+i]; + } + } + else { + LDA = *n+1; + LDB = *n+1; + A = ( float* )malloc( LDA*(*k)*sizeof( float ) ); + B = ( float* )malloc( LDB*(*k)*sizeof( float ) ); + for( i=0; i<*k; i++ ) + for( j=0; j<*n; j++ ){ + A[i*LDA+j]=a[j*(*lda)+i]; + B[i*LDB+j]=b[j*(*ldb)+i]; + } + } + LDC = *n+1; + C = ( float* )malloc( (*n)*LDC*sizeof( float ) ); + for( i=0; i<*n; i++ ) + for( j=0; j<*n; j++ ) + C[i*LDC+j]=c[j*(*ldc)+i]; + cblas_skyr2k(CblasRowMajor, uplo, trans, *n, *k, *alpha, A, LDA, + B, LDB, *beta, C, LDC ); + for( j=0; j<*n; j++ ) + for( i=0; i<*n; i++ ) + c[j*(*ldc)+i]=C[i*LDC+j]; + free(A); + free(B); + free(C); + } + else if (*layout == TEST_COL_MJR) + cblas_skyr2k(CblasColMajor, uplo, trans, *n, *k, *alpha, a, *lda, + b, *ldb, *beta, c, *ldc ); + else + cblas_skyr2k(UNDEFINED, uplo, trans, *n, *k, *alpha, a, *lda, + b, *ldb, *beta, c, *ldc ); +} void F77_strmm(CBLAS_INT *layout, char *rtlf, char *uplow, char *transp, char *diagn, CBLAS_INT *m, CBLAS_INT *n, float *alpha, float *a, CBLAS_INT *lda, float *b, CBLAS_INT *ldb diff --git a/CBLAS/testing/c_sblat2.f b/CBLAS/testing/c_sblat2.f index 8bd23c3e9..662125f5c 100644 --- a/CBLAS/testing/c_sblat2.f +++ b/CBLAS/testing/c_sblat2.f @@ -3,7 +3,7 @@ PROGRAM SBLAT2 * Test program for the REAL Level 2 Blas. * * The program must be driven by a short data file. The first 17 records -* of the file are read using list-directed input, the last 16 records +* of the file are read using list-directed input, the last 18 records * are read using the format ( A12, L2 ). An annotated example of a data * file can be obtained by deleting the first 3 characters from the * following 33 lines: @@ -27,6 +27,7 @@ PROGRAM SBLAT2 * cblas_sgemv T PUT F FOR NO TEST. SAME COLUMNS. * cblas_sgbmv T PUT F FOR NO TEST. SAME COLUMNS. * cblas_ssymv T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_skymv T PUT F FOR NO TEST. SAME COLUMNS. * cblas_ssbmv T PUT F FOR NO TEST. SAME COLUMNS. * cblas_sspmv T PUT F FOR NO TEST. SAME COLUMNS. * cblas_strmv T PUT F FOR NO TEST. SAME COLUMNS. @@ -40,6 +41,7 @@ PROGRAM SBLAT2 * cblas_sspr T PUT F FOR NO TEST. SAME COLUMNS. * cblas_ssyr2 T PUT F FOR NO TEST. SAME COLUMNS. * cblas_sspr2 T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_skyr2 T PUT F FOR NO TEST. SAME COLUMNS. * * See: * @@ -66,7 +68,7 @@ PROGRAM SBLAT2 INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NSUBS - PARAMETER ( NSUBS = 16 ) + PARAMETER ( NSUBS = 18 ) REAL ZERO, HALF, ONE PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) INTEGER NMAX, INCMAX @@ -115,7 +117,8 @@ PROGRAM SBLAT2 $ 'cblas_strmv ','cblas_stbmv ','cblas_stpmv ', $ 'cblas_strsv ','cblas_stbsv ','cblas_stpsv ', $ 'cblas_sger ','cblas_ssyr ','cblas_sspr ', - $ 'cblas_ssyr2 ','cblas_sspr2 '/ + $ 'cblas_ssyr2 ','cblas_sspr2 ','cblas_skymv ', + $ 'cblas_skyr2 '/ * .. Executable Statements .. * NOUTC = NOUT @@ -310,7 +313,7 @@ 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 IF (CORDER) THEN CALL SCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, @@ -325,7 +328,7 @@ PROGRAM SBLAT2 $ X, XX, XS, Y, YY, YS, YT, G, 1 ) END IF GO TO 200 -* Test SSYMV, 03, SSBMV, 04, and SSPMV, 05. +* Test SSYMV, 03, SSBMV, 04, and SSPMV, 05, and SKYMV, 17. 150 IF (CORDER) THEN CALL SCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, @@ -382,7 +385,7 @@ PROGRAM SBLAT2 $ YT, G, Z, 1 ) END IF GO TO 200 -* Test SSYR2, 15, and SSPR2, 16. +* Test SSYR2, 15, and SSPR2, 16, and SKYR2, 18. 190 IF (CORDER) THEN CALL SCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, @@ -818,7 +821,7 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, $ XS, Y, YY, YS, YT, G, IORDER ) * -* Tests SSYMV, SSBMV and SSPMV. +* Tests SSYMV, SKYMV, SSBMV and SSPMV. * * Auxiliary routine for test program for Level 2 Blas. * @@ -848,7 +851,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, + $ KYFULL CHARACTER*1 UPLO, UPLOS CHARACTER*14 CUPLO CHARACTER*2 ICH @@ -858,7 +862,7 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, LOGICAL LSE, LSERES EXTERNAL LSE, LSERES * .. External Subroutines .. - EXTERNAL SMAKE, SMVCH, CSSBMV, CSSPMV, CSSYMV + EXTERNAL SMAKE, SMVCH, CSSBMV, CSSPMV, CSSYMV, CSKYMV * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. Scalars in Common .. @@ -869,11 +873,12 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * .. Data statements .. DATA ICH/'UL'/ * .. Executable Statements .. - FULL = SNAME( 9: 9 ).EQ.'y' + FULL = SNAME( 8: 8 ).NE.'k'.AND.SNAME( 9: 9 ).EQ.'y' BANDED = SNAME( 9: 9 ).EQ.'b' PACKED = SNAME( 9: 9 ).EQ.'p' + KYFULL = SNAME( 8: 8 ).EQ.'k' * Define the number of arguments. - IF( FULL )THEN + IF( FULL.OR.KYFULL )THEN NARGS = 10 ELSE IF( BANDED )THEN NARGS = 11 @@ -994,6 +999,14 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, IF( REWI ) $ REWIND NTRA CALL CSSYMV( IORDER, UPLO, N, ALPHA, AA, + $ LDA, XX, INCX, BETA, YY, INCY ) + ELSE IF( KYFULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, + $ CUPLO, N, ALPHA, LDA, INCX, BETA, INCY + IF( REWI ) + $ REWIND NTRA + CALL CSKYMV( IORDER, UPLO, N, ALPHA, AA, $ LDA, XX, INCX, BETA, YY, INCY ) ELSE IF( BANDED )THEN IF( TRACE ) @@ -1027,7 +1040,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.KYFULL )THEN ISAME( 3 ) = ALS.EQ.ALPHA ISAME( 4 ) = LSE( AS, AA, LAA ) ISAME( 5 ) = LDAS.EQ.LDA @@ -2133,7 +2146,7 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, $ Z, IORDER ) * -* Tests SSYR2 and SSPR2. +* Tests SSYR2, SKYR2 and SSPR2. * * Auxiliary routine for test program for Level 2 Blas. * @@ -2162,7 +2175,7 @@ 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, KYFULL CHARACTER*1 UPLO, UPLOS CHARACTER*14 CUPLO CHARACTER*2 ICH @@ -2173,7 +2186,7 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, LOGICAL LSE, LSERES EXTERNAL LSE, LSERES * .. External Subroutines .. - EXTERNAL SMAKE, SMVCH, CSSPR2, CSSYR2 + EXTERNAL SMAKE, SMVCH, CSSPR2, CSSYR2, CSKYR2 * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. Scalars in Common .. @@ -2184,8 +2197,9 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * .. Data statements .. DATA ICH/'UL'/ * .. Executable Statements .. - FULL = SNAME( 9: 9 ).EQ.'y' + FULL = SNAME( 8: 8 ).NE.'k'.AND.SNAME( 9: 9 ).EQ.'y' PACKED = SNAME( 9: 9 ).EQ.'p' + KYFULL = SNAME( 8: 8 ).EQ.'k' * Define the number of arguments. IF( FULL )THEN NARGS = 9 @@ -2289,6 +2303,14 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, IF( REWI ) $ REWIND NTRA CALL CSSYR2( IORDER, UPLO, N, ALPHA, XX, INCX, + $ YY, INCY, AA, LDA ) + ELSE IF( KYFULL )THEN + IF( TRACE ) + $ WRITE( NTRA, FMT = 9993 )NC, SNAME, CUPLO, N, + $ ALPHA, INCX, INCY, LDA + IF( REWI ) + $ REWIND NTRA + CALL CSKYR2( IORDER, UPLO, N, ALPHA, XX, INCX, $ YY, INCY, AA, LDA ) ELSE IF( PACKED )THEN IF( TRACE ) @@ -2362,22 +2384,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.KYFULL.OR.UPPER )THEN + JA = 1 + ELSE + JA = 2 + END IF DO 90 J = 1, N - W( 1 ) = Z( J, 2 ) + IF( .NOT.KYFULL )THEN + W( 1 ) = Z( J, 2 ) + ELSE + W( 1 ) = -Z( J, 2 ) + END IF W( 2 ) = Z( J, 1 ) - IF( UPPER )THEN + IF( .NOT.KYFULL.AND.UPPER )THEN JJ = 1 LJ = J - ELSE + ELSE IF( .NOT.KYFULL.AND..NOT.UPPER )THEN JJ = J LJ = N - J + 1 + ELSE IF( KYFULL.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.KYFULL )THEN IF( UPPER )THEN JA = JA + LDA ELSE @@ -2423,7 +2459,7 @@ SUBROUTINE SCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * 160 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME - IF( FULL )THEN + IF( FULL.OR.KYFULL )THEN WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, ALPHA, INCX, $ INCY, LDA ELSE IF( PACKED )THEN @@ -2468,7 +2504,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', 'ky','sb', 'sp', 'tr', 'tb' OR 'tp'. * * Auxiliary routine for test program for Level 2 Blas. * @@ -2491,7 +2527,7 @@ 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, SKY * .. External Functions .. REAL SBEG EXTERNAL SBEG @@ -2500,9 +2536,10 @@ SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, * .. Executable Statements .. GEN = TYPE( 1: 1 ).EQ.'g' SYM = TYPE( 1: 1 ).EQ.'s' + SKY = TYPE( 1: 1 ).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.SKY.OR.TRI ).AND.UPLO.EQ.'U' + LOWER = ( SYM.OR.SKY.OR.TRI ).AND.UPLO.EQ.'L' UNIT = TRI.AND.DIAG.EQ.'U' * * Generate data in array A. @@ -2520,6 +2557,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( SKY )THEN + A( J, I ) = -A( I, J ) ELSE IF( TRI )THEN A( J, I ) = ZERO END IF @@ -2530,6 +2569,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( SKY ) + $ A( J, J ) = ZERO 20 CONTINUE * * Store elements in array AS in data structure required by routine. @@ -2555,17 +2596,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.'ky'.OR.TYPE.EQ.'tr' )THEN DO 130 J = 1, N IF( UPPER )THEN IBEG = 1 - IF( UNIT )THEN + IF( UNIT.OR.SKY )THEN IEND = J - 1 ELSE IEND = J END IF ELSE - IF( UNIT )THEN + IF( UNIT.OR.SKY )THEN IBEG = J + 1 ELSE IBEG = J @@ -2813,14 +2854,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.'ky' )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.'ky' )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 ) ) diff --git a/CBLAS/testing/c_sblat3.f b/CBLAS/testing/c_sblat3.f index c6f696190..7c76eca68 100644 --- a/CBLAS/testing/c_sblat3.f +++ b/CBLAS/testing/c_sblat3.f @@ -3,7 +3,7 @@ PROGRAM SBLAT3 * Test program for the REAL Level 3 Blas. * * The program must be driven by a short data file. The first 13 records -* of the file are read using list-directed input, the last 6 records +* of the file are read using list-directed input, the last 8 records * are read using the format ( A13, L2 ). An annotated example of a data * file can be obtained by deleting the first 3 characters from the * following 19 lines: @@ -22,10 +22,12 @@ PROGRAM SBLAT3 * 0.0 1.0 1.3 VALUES OF BETA * cblas_sgemm T PUT F FOR NO TEST. SAME COLUMNS. * cblas_ssymm T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_skymm T PUT F FOR NO TEST. SAME COLUMNS. * cblas_strmm T PUT F FOR NO TEST. SAME COLUMNS. * cblas_strsm T PUT F FOR NO TEST. SAME COLUMNS. * cblas_ssyrk T PUT F FOR NO TEST. SAME COLUMNS. * cblas_ssyr2k T PUT F FOR NO TEST. SAME COLUMNS. +* cblas_skyr2k T PUT F FOR NO TEST. SAME COLUMNS. * cblas_sgemmtr T PUT F FOR NO TEST. SAME COLUMNS. * @@ -48,7 +50,7 @@ PROGRAM SBLAT3 INTEGER NIN, NOUT PARAMETER ( NIN = 5, NOUT = 6 ) INTEGER NSUBS - PARAMETER ( NSUBS = 7 ) + PARAMETER ( NSUBS = 9 ) REAL ZERO, HALF, ONE PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) INTEGER NMAX @@ -93,7 +95,8 @@ PROGRAM SBLAT3 * .. Data statements .. DATA SNAMES/'cblas_sgemm ', 'cblas_ssymm ', $ 'cblas_strmm ', 'cblas_strsm ','cblas_ssyrk ', - $ 'cblas_ssyr2k', 'cblas_sgemmtr'/ + $ 'cblas_ssyr2k', 'cblas_sgemmtr', + $ 'cblas_skymm ', 'cblas_skyr2k'/ * .. Executable Statements .. * NOUTC = NOUT @@ -290,7 +293,7 @@ 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 IF (CORDER) THEN CALL SCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, @@ -305,7 +308,7 @@ PROGRAM SBLAT3 $ CC, CS, CT, G, 1 ) END IF GO TO 190 -* Test SSYMM, 02. +* Test SSYMM, 02 and SKYMM, 08. 150 IF (CORDER) THEN CALL SCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, @@ -347,7 +350,7 @@ PROGRAM SBLAT3 $ CC, CS, CT, G, 1 ) END IF GO TO 190 -* Test SSYR2K, 06. +* Test SSYR2K, 06 and SKYR2K, 09. 180 IF (CORDER) THEN CALL SCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, @@ -794,7 +797,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, KYFULL CHARACTER*1 SIDE, SIDES, UPLO, UPLOS CHARACTER*2 ICHS, ICHU * .. Local Arrays .. @@ -803,7 +806,7 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, LOGICAL LSE, LSERES EXTERNAL LSE, LSERES * .. External Subroutines .. - EXTERNAL SMAKE, SMMCH, CSSYMM + EXTERNAL SMAKE, SMMCH, CSSYMM, CSKYMM * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. @@ -815,6 +818,7 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DATA ICHS/'LR'/, ICHU/'UL'/ * .. Executable Statements .. * + KYFULL = SNAME( 8: 8 ).EQ.'k' NARGS = 12 NC = 0 RESET = .TRUE. @@ -872,8 +876,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.KYFULL) THEN + CALL SMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, + $ LDA, RESET, ZERO ) + ELSE + CALL SMAKE( 'KY', UPLO, ' ', NA, NA, A, NMAX, AA, + $ LDA, RESET, ZERO ) + END IF * DO 60 IA = 1, NALF ALPHA = ALF( IA ) @@ -918,8 +927,13 @@ SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ BETA, LDC) IF( REWI ) $ REWIND NTRA - CALL CSSYMM( IORDER, SIDE, UPLO, M, N, ALPHA, - $ AA, LDA, BB, LDB, BETA, CC, LDC ) + IF(.NOT.KYFULL) THEN + CALL CSSYMM( IORDER, SIDE, UPLO, M, N, + $ ALPHA, AA, LDA, BB, LDB, BETA, CC, LDC ) + ELSE + CALL CSKYMM( IORDER, SIDE, UPLO, M, N, + $ ALPHA, AA, LDA, BB, LDB, BETA, CC, LDC ) + END IF * * Check if error-exit was taken incorrectly. * @@ -1781,7 +1795,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, KYFULL CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS CHARACTER*2 ICHU CHARACTER*3 ICHT @@ -1791,7 +1805,7 @@ SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, LOGICAL LSE, LSERES EXTERNAL LSE, LSERES * .. External Subroutines .. - EXTERNAL SMAKE, SMMCH, CSSYR2K + EXTERNAL SMAKE, SMMCH, CSSYR2K, CSKYR2K * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. @@ -1803,6 +1817,7 @@ SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, DATA ICHT/'NTC'/, ICHU/'UL'/ * .. Executable Statements .. * + KYFULL = SNAME( 8: 8 ).EQ.'k' NARGS = 12 NC = 0 RESET = .TRUE. @@ -1876,8 +1891,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.KYFULL) THEN + CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, + $ CC, LDC, RESET, ZERO ) + ELSE + CALL SMAKE( 'KY', UPLO, ' ', N, N, C, NMAX, + $ CC, LDC, RESET, ZERO ) + END IF * NC = NC + 1 * @@ -1909,8 +1929,13 @@ SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC) IF( REWI ) $ REWIND NTRA - CALL CSSYR2K( IORDER, UPLO, TRANS, N, K, ALPHA, - $ AA, LDA, BB, LDB, BETA, CC, LDC ) + IF(.NOT.KYFULL) THEN + CALL CSSYR2K( IORDER, UPLO, TRANS, N, K, + $ ALPHA, AA, LDA, BB, LDB, BETA, CC, LDC ) + ELSE + CALL CSKYR2K( IORDER, UPLO, TRANS, N, K, + $ ALPHA, AA, LDA, BB, LDB, BETA, CC, LDC ) + END IF * * Check if error-exit was taken incorrectly. * @@ -1935,8 +1960,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.KYFULL) THEN + ISAME( 11 ) = LSERES( 'SY', UPLO, N, N, + $ CS, CC, LDC ) + ELSE + ISAME( 11 ) = LSERES( 'KY', UPLO, N, N, + $ CS, CC, LDC ) + END IF END IF ISAME( 12 ) = LDCS.EQ.LDC * @@ -1958,20 +1988,36 @@ SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, * * Check the result column by column. * - JJAB = 1 - JC = 1 + IF( .NOT.KYFULL.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.KYFULL.AND.UPPER )THEN JJ = 1 LJ = J - ELSE + ELSE IF( .NOT.KYFULL.AND..NOT.UPPER )THEN JJ = J LJ = N - J + 1 + ELSE IF( KYFULL.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.KYFULL) 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 @@ -1983,8 +2029,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.KYFULL) 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 @@ -2109,7 +2160,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', 'KY' or 'TR'. * * Auxiliary routine for test program for Level 3 Blas. * @@ -2134,7 +2185,7 @@ 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, SKY * .. External Functions .. REAL SBEG EXTERNAL SBEG @@ -2142,8 +2193,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' + SKY = TYPE.EQ.'KY' + UPPER = ( SYM.OR.SKY.OR.TRI ).AND.UPLO.EQ.'U' + LOWER = ( SYM.OR.SKY.OR.TRI ).AND.UPLO.EQ.'L' UNIT = TRI.AND.DIAG.EQ.'U' * * Generate data in array A. @@ -2159,6 +2211,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( SKY )THEN + A( J, I ) = -A( I, J ) ELSE IF( TRI )THEN A( J, I ) = ZERO END IF @@ -2169,6 +2223,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( SKY ) + $ A( J, J ) = ZERO 20 CONTINUE * * Store elements in array AS in data structure required by routine. @@ -2182,17 +2238,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.'KY'.OR.TYPE.EQ.'TR' )THEN DO 90 J = 1, N IF( UPPER )THEN IBEG = 1 - IF( UNIT )THEN + IF( UNIT.OR.SKY )THEN IEND = J - 1 ELSE IEND = J END IF ELSE - IF( UNIT )THEN + IF( UNIT.OR.SKY )THEN IBEG = J + 1 ELSE IBEG = J @@ -2373,7 +2429,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 'KY'. * * Auxiliary routine for test program for Level 3 Blas. * @@ -2401,14 +2457,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.'KY' )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.'KY' )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 ) ) diff --git a/CBLAS/testing/c_xerbla.c b/CBLAS/testing/c_xerbla.c index 2af45f4a4..5cbf635a0 100644 --- a/CBLAS/testing/c_xerbla.c +++ b/CBLAS/testing/c_xerbla.c @@ -45,7 +45,7 @@ void cblas_xerbla(CBLAS_INT info, const char *rout, const char *form, ...) else if (info == 9 ) info = 11; } - else if (strstr(rout,"symm") != 0 || strstr(rout,"hemm") != 0) + else if (strstr(rout,"symm") != 0 || strstr(rout,"kymm") != 0 || strstr(rout,"hemm") != 0) { if (info == 5 ) info = 4; else if (info == 4 ) info = 5; diff --git a/CBLAS/testing/din2 b/CBLAS/testing/din2 index 000351c77..8969869a2 100644 --- a/CBLAS/testing/din2 +++ b/CBLAS/testing/din2 @@ -18,6 +18,7 @@ T LOGICAL FLAG, T TO TEST ERROR EXITS. cblas_dgemv T PUT F FOR NO TEST. SAME COLUMNS. cblas_dgbmv T PUT F FOR NO TEST. SAME COLUMNS. cblas_dsymv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_dkymv T PUT F FOR NO TEST. SAME COLUMNS. cblas_dsbmv T PUT F FOR NO TEST. SAME COLUMNS. cblas_dspmv T PUT F FOR NO TEST. SAME COLUMNS. cblas_dtrmv T PUT F FOR NO TEST. SAME COLUMNS. @@ -30,4 +31,5 @@ cblas_dger T PUT F FOR NO TEST. SAME COLUMNS. cblas_dsyr T PUT F FOR NO TEST. SAME COLUMNS. cblas_dspr T PUT F FOR NO TEST. SAME COLUMNS. cblas_dsyr2 T PUT F FOR NO TEST. SAME COLUMNS. +cblas_dkyr2 T PUT F FOR NO TEST. SAME COLUMNS. cblas_dspr2 T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/CBLAS/testing/din3 b/CBLAS/testing/din3 index 350544d66..2fe219e60 100644 --- a/CBLAS/testing/din3 +++ b/CBLAS/testing/din3 @@ -13,8 +13,10 @@ T LOGICAL FLAG, T TO TEST ERROR EXITS. 0.0 1.0 1.3 VALUES OF BETA cblas_dgemm T PUT F FOR NO TEST. SAME COLUMNS. cblas_dsymm T PUT F FOR NO TEST. SAME COLUMNS. +cblas_dkymm T PUT F FOR NO TEST. SAME COLUMNS. cblas_dtrmm T PUT F FOR NO TEST. SAME COLUMNS. cblas_dtrsm T PUT F FOR NO TEST. SAME COLUMNS. cblas_dsyrk T PUT F FOR NO TEST. SAME COLUMNS. cblas_dsyr2k T PUT F FOR NO TEST. SAME COLUMNS. +cblas_dkyr2k T PUT F FOR NO TEST. SAME COLUMNS. cblas_dgemmtr T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/CBLAS/testing/sin2 b/CBLAS/testing/sin2 index b5bb12d0e..94eada536 100644 --- a/CBLAS/testing/sin2 +++ b/CBLAS/testing/sin2 @@ -18,6 +18,7 @@ T LOGICAL FLAG, T TO TEST ERROR EXITS. cblas_sgemv T PUT F FOR NO TEST. SAME COLUMNS. cblas_sgbmv T PUT F FOR NO TEST. SAME COLUMNS. cblas_ssymv T PUT F FOR NO TEST. SAME COLUMNS. +cblas_skymv T PUT F FOR NO TEST. SAME COLUMNS. cblas_ssbmv T PUT F FOR NO TEST. SAME COLUMNS. cblas_sspmv T PUT F FOR NO TEST. SAME COLUMNS. cblas_strmv T PUT F FOR NO TEST. SAME COLUMNS. @@ -30,4 +31,5 @@ cblas_sger T PUT F FOR NO TEST. SAME COLUMNS. cblas_ssyr T PUT F FOR NO TEST. SAME COLUMNS. cblas_sspr T PUT F FOR NO TEST. SAME COLUMNS. cblas_ssyr2 T PUT F FOR NO TEST. SAME COLUMNS. +cblas_skyr2 T PUT F FOR NO TEST. SAME COLUMNS. cblas_sspr2 T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/CBLAS/testing/sin3 b/CBLAS/testing/sin3 index f332c8a9e..863912c66 100644 --- a/CBLAS/testing/sin3 +++ b/CBLAS/testing/sin3 @@ -13,8 +13,10 @@ T LOGICAL FLAG, T TO TEST ERROR EXITS. 0.0 1.0 1.3 VALUES OF BETA cblas_sgemm T PUT F FOR NO TEST. SAME COLUMNS. cblas_ssymm T PUT F FOR NO TEST. SAME COLUMNS. +cblas_skymm T PUT F FOR NO TEST. SAME COLUMNS. cblas_strmm T PUT F FOR NO TEST. SAME COLUMNS. cblas_strsm T PUT F FOR NO TEST. SAME COLUMNS. cblas_ssyrk T PUT F FOR NO TEST. SAME COLUMNS. cblas_ssyr2k T PUT F FOR NO TEST. SAME COLUMNS. +cblas_skyr2k T PUT F FOR NO TEST. SAME COLUMNS. cblas_sgemmtr T PUT F FOR NO TEST. SAME COLUMNS. diff --git a/LAPACKE/include/lapack.h b/LAPACKE/include/lapack.h index f9a254512..3d7a22c94 100644 --- a/LAPACKE/include/lapack.h +++ b/LAPACKE/include/lapack.h @@ -10270,6 +10270,36 @@ lapack_float_return LAPACK_slanst_base( #define LAPACK_slanst(...) LAPACK_slanst_base(__VA_ARGS__) #endif +#define LAPACK_dlankt_base LAPACK_GLOBAL_SUFFIX(dlankt,DLANKT) +double LAPACK_dlankt_base( + char const* norm, + lapack_int const* n, + double const* E +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_dlankt(...) LAPACK_dlankt_base(__VA_ARGS__, 1) +#else + #define LAPACK_dlankt(...) LAPACK_dlankt_base(__VA_ARGS__) +#endif + +#define LAPACK_slankt_base LAPACK_GLOBAL_SUFFIX(slankt,SLANKT) +lapack_float_return LAPACK_slankt_base( + char const* norm, + lapack_int const* n, + float const* E +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_slankt(...) LAPACK_slankt_base(__VA_ARGS__, 1) +#else + #define LAPACK_slankt(...) LAPACK_slankt_base(__VA_ARGS__) +#endif + #define LAPACK_clansy_base LAPACK_GLOBAL_SUFFIX(clansy,CLANSY) lapack_float_return LAPACK_clansy_base( char const* norm, char const* uplo, @@ -10334,6 +10364,38 @@ double LAPACK_zlansy_base( #define LAPACK_zlansy(...) LAPACK_zlansy_base(__VA_ARGS__) #endif +#define LAPACK_dlanky_base LAPACK_GLOBAL_SUFFIX(dlanky,DLANKY) +double LAPACK_dlanky_base( + char const* norm, char const* uplo, + lapack_int const* n, + double const* A, lapack_int const* lda, + double* work +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN, FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_dlanky(...) LAPACK_dlanky_base(__VA_ARGS__, 1, 1) +#else + #define LAPACK_dlanky(...) LAPACK_dlanky_base(__VA_ARGS__) +#endif + +#define LAPACK_slanky_base LAPACK_GLOBAL_SUFFIX(slanky,SLANKY) +lapack_float_return LAPACK_slanky_base( + char const* norm, char const* uplo, + lapack_int const* n, + float const* A, lapack_int const* lda, + float* work +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN, FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_slanky(...) LAPACK_slanky_base(__VA_ARGS__, 1, 1) +#else + #define LAPACK_slanky(...) LAPACK_slanky_base(__VA_ARGS__) +#endif + #define LAPACK_clantb_base LAPACK_GLOBAL_SUFFIX(clantb,CLANTB) lapack_float_return LAPACK_clantb_base( char const* norm, char const* uplo, char const* diag, @@ -16767,6 +16829,42 @@ void LAPACK_zsteqr_base( #define LAPACK_zsteqr(...) LAPACK_zsteqr_base(__VA_ARGS__) #endif +#define LAPACK_dkteqr_base LAPACK_GLOBAL_SUFFIX(dkteqr,DKTEQR) +void LAPACK_dkteqr_base( + char const* compz, + lapack_int const* n, + double* E, + double* Z, lapack_int const* ldz, + double* work, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_dkteqr(...) LAPACK_dkteqr_base(__VA_ARGS__, 1) +#else + #define LAPACK_dkteqr(...) LAPACK_dkteqr_base(__VA_ARGS__) +#endif + +#define LAPACK_skteqr_base LAPACK_GLOBAL_SUFFIX(skteqr,SKTEQR) +void LAPACK_skteqr_base( + char const* compz, + lapack_int const* n, + float* E, + float* Z, lapack_int const* ldz, + float* work, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_skteqr(...) LAPACK_skteqr_base(__VA_ARGS__, 1) +#else + #define LAPACK_skteqr(...) LAPACK_skteqr_base(__VA_ARGS__) +#endif + #define LAPACK_dsterf LAPACK_GLOBAL_SUFFIX(dsterf,DSTERF) void LAPACK_dsterf( lapack_int const* n, @@ -16819,6 +16917,44 @@ void LAPACK_sstev_base( #define LAPACK_sstev(...) LAPACK_sstev_base(__VA_ARGS__) #endif +#define LAPACK_dktev_base LAPACK_GLOBAL_SUFFIX(dktev,DKTEV) +void LAPACK_dktev_base( + char const* jobz, + lapack_int const* n, + double* D, + double* E, + double* Z, lapack_int const* ldz, + double* work, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_dktev(...) LAPACK_dktev_base(__VA_ARGS__, 1) +#else + #define LAPACK_dktev(...) LAPACK_dktev_base(__VA_ARGS__) +#endif + +#define LAPACK_sktev_base LAPACK_GLOBAL_SUFFIX(sktev,SKTEV) +void LAPACK_sktev_base( + char const* jobz, + lapack_int const* n, + float* D, + float* E, + float* Z, lapack_int const* ldz, + float* work, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_sktev(...) LAPACK_sktev_base(__VA_ARGS__, 1) +#else + #define LAPACK_sktev(...) LAPACK_sktev_base(__VA_ARGS__) +#endif + #define LAPACK_dstevd_base LAPACK_GLOBAL_SUFFIX(dstevd,DSTEVD) void LAPACK_dstevd_base( char const* jobz, @@ -17166,6 +17302,40 @@ void LAPACK_ssyconv_base( #define LAPACK_ssyconv(...) LAPACK_ssyconv_base(__VA_ARGS__) #endif +#define LAPACK_dkyconv_base LAPACK_GLOBAL_SUFFIX(dkyconv,DKYCONV) +void LAPACK_dkyconv_base( + char const* uplo, char const* way, + lapack_int const* n, + double* A, lapack_int const* lda, lapack_int const* ipiv, + double* E, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN, FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_dkyconv(...) LAPACK_dkyconv_base(__VA_ARGS__, 1, 1) +#else + #define LAPACK_dkyconv(...) LAPACK_dkyconv_base(__VA_ARGS__) +#endif + +#define LAPACK_skyconv_base LAPACK_GLOBAL_SUFFIX(skyconv,SKYCONV) +void LAPACK_skyconv_base( + char const* uplo, char const* way, + lapack_int const* n, + float* A, lapack_int const* lda, lapack_int const* ipiv, + float* E, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN, FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_skyconv(...) LAPACK_skyconv_base(__VA_ARGS__, 1, 1) +#else + #define LAPACK_skyconv(...) LAPACK_skyconv_base(__VA_ARGS__) +#endif + #define LAPACK_zsyconv_base LAPACK_GLOBAL_SUFFIX(zsyconv,ZSYCONV) void LAPACK_zsyconv_base( char const* uplo, char const* way, @@ -17299,6 +17469,42 @@ void LAPACK_ssyev_base( #define LAPACK_ssyev(...) LAPACK_ssyev_base(__VA_ARGS__) #endif +#define LAPACK_dkyev_base LAPACK_GLOBAL_SUFFIX(dkyev,DKYEV) +void LAPACK_dkyev_base( + char const* jobz, char const* uplo, + lapack_int const* n, + double* A, lapack_int const* lda, + double* W, + double* work, lapack_int const* lwork, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN, FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_dkyev(...) LAPACK_dkyev_base(__VA_ARGS__, 1, 1) +#else + #define LAPACK_dkyev(...) LAPACK_dkyev_base(__VA_ARGS__) +#endif + +#define LAPACK_skyev_base LAPACK_GLOBAL_SUFFIX(skyev,SKYEV) +void LAPACK_skyev_base( + char const* jobz, char const* uplo, + lapack_int const* n, + float* A, lapack_int const* lda, + float* W, + float* work, lapack_int const* lwork, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN, FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_skyev(...) LAPACK_skyev_base(__VA_ARGS__, 1, 1) +#else + #define LAPACK_skyev(...) LAPACK_skyev_base(__VA_ARGS__) +#endif + #define LAPACK_dsyev_2stage_base LAPACK_GLOBAL_SUFFIX(dsyev_2stage,DSYEV_2STAGE) void LAPACK_dsyev_2stage_base( char const* jobz, char const* uplo, @@ -17629,6 +17835,40 @@ void LAPACK_ssygst_base( #define LAPACK_ssygst(...) LAPACK_ssygst_base(__VA_ARGS__) #endif +#define LAPACK_dkygst_base LAPACK_GLOBAL_SUFFIX(dkygst,DKYGST) +void LAPACK_dkygst_base( + lapack_int const* itype, char const* uplo, + lapack_int const* n, + double* A, lapack_int const* lda, + double const* B, lapack_int const* ldb, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_dkygst(...) LAPACK_dkygst_base(__VA_ARGS__, 1) +#else + #define LAPACK_dkygst(...) LAPACK_dkygst_base(__VA_ARGS__) +#endif + +#define LAPACK_skygst_base LAPACK_GLOBAL_SUFFIX(skygst,SKYGST) +void LAPACK_skygst_base( + lapack_int const* itype, char const* uplo, + lapack_int const* n, + float* A, lapack_int const* lda, + float const* B, lapack_int const* ldb, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_skygst(...) LAPACK_skygst_base(__VA_ARGS__, 1) +#else + #define LAPACK_skygst(...) LAPACK_skygst_base(__VA_ARGS__) +#endif + #define LAPACK_dsygv_base LAPACK_GLOBAL_SUFFIX(dsygv,DSYGV) void LAPACK_dsygv_base( lapack_int const* itype, char const* jobz, char const* uplo, @@ -17667,6 +17907,44 @@ void LAPACK_ssygv_base( #define LAPACK_ssygv(...) LAPACK_ssygv_base(__VA_ARGS__) #endif +#define LAPACK_dkygv_base LAPACK_GLOBAL_SUFFIX(dkygv,DKYGV) +void LAPACK_dkygv_base( + lapack_int const* itype, char const* jobz, char const* uplo, + lapack_int const* n, + double* A, lapack_int const* lda, + double* B, lapack_int const* ldb, + double* W, + double* work, lapack_int const* lwork, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN, FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_dkygv(...) LAPACK_dkygv_base(__VA_ARGS__, 1, 1) +#else + #define LAPACK_dkygv(...) LAPACK_dkygv_base(__VA_ARGS__) +#endif + +#define LAPACK_skygv_base LAPACK_GLOBAL_SUFFIX(skygv,SKYGV) +void LAPACK_skygv_base( + lapack_int const* itype, char const* jobz, char const* uplo, + lapack_int const* n, + float* A, lapack_int const* lda, + float* B, lapack_int const* ldb, + float* W, + float* work, lapack_int const* lwork, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN, FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_skygv(...) LAPACK_skygv_base(__VA_ARGS__, 1, 1) +#else + #define LAPACK_skygv(...) LAPACK_skygv_base(__VA_ARGS__) +#endif + #define LAPACK_dsygv_2stage_base LAPACK_GLOBAL_SUFFIX(dsygv_2stage,DSYGV_2STAGE) void LAPACK_dsygv_2stage_base( lapack_int const* itype, char const* jobz, char const* uplo, @@ -18099,6 +18377,42 @@ void LAPACK_zsysv_base( #define LAPACK_zsysv(...) LAPACK_zsysv_base(__VA_ARGS__) #endif +#define LAPACK_dkysv_base LAPACK_GLOBAL_SUFFIX(dkysv,DKYSV) +void LAPACK_dkysv_base( + char const* uplo, + lapack_int const* n, lapack_int const* nrhs, + double* A, lapack_int const* lda, lapack_int* ipiv, + double* B, lapack_int const* ldb, + double* work, lapack_int const* lwork, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_dkysv(...) LAPACK_dkysv_base(__VA_ARGS__, 1) +#else + #define LAPACK_dkysv(...) LAPACK_dkysv_base(__VA_ARGS__) +#endif + +#define LAPACK_skysv_base LAPACK_GLOBAL_SUFFIX(skysv,SKYSV) +void LAPACK_skysv_base( + char const* uplo, + lapack_int const* n, lapack_int const* nrhs, + float* A, lapack_int const* lda, lapack_int* ipiv, + float* B, lapack_int const* ldb, + float* work, lapack_int const* lwork, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_skysv(...) LAPACK_skysv_base(__VA_ARGS__, 1) +#else + #define LAPACK_skysv(...) LAPACK_skysv_base(__VA_ARGS__) +#endif + #define LAPACK_csysv_aa_base LAPACK_GLOBAL_SUFFIX(csysv_aa,CSYSV_AA) void LAPACK_csysv_aa_base( char const* uplo, @@ -18667,6 +18981,36 @@ void LAPACK_zsyswapr_base( #define LAPACK_zsyswapr(...) LAPACK_zsyswapr_base(__VA_ARGS__) #endif +#define LAPACK_dkyswapr_base LAPACK_GLOBAL_SUFFIX(dkyswapr,DKYSWAPR) +void LAPACK_dkyswapr_base( + char const* uplo, + lapack_int const* n, + double* A, lapack_int const* lda, lapack_int const* i1, lapack_int const* i2 +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_dkyswapr(...) LAPACK_dkyswapr_base(__VA_ARGS__, 1) +#else + #define LAPACK_dkyswapr(...) LAPACK_dkyswapr_base(__VA_ARGS__) +#endif + +#define LAPACK_skyswapr_base LAPACK_GLOBAL_SUFFIX(skyswapr,SKYSWAPR) +void LAPACK_skyswapr_base( + char const* uplo, + lapack_int const* n, + float* A, lapack_int const* lda, lapack_int const* i1, lapack_int const* i2 +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_skyswapr(...) LAPACK_skyswapr_base(__VA_ARGS__, 1) +#else + #define LAPACK_skyswapr(...) LAPACK_skyswapr_base(__VA_ARGS__) +#endif + #define LAPACK_dsytrd_base LAPACK_GLOBAL_SUFFIX(dsytrd,DSYTRD) void LAPACK_dsytrd_base( char const* uplo, @@ -18707,6 +19051,44 @@ void LAPACK_ssytrd_base( #define LAPACK_ssytrd(...) LAPACK_ssytrd_base(__VA_ARGS__) #endif +#define LAPACK_dkytrd_base LAPACK_GLOBAL_SUFFIX(dkytrd,DKYTRD) +void LAPACK_dkytrd_base( + char const* uplo, + lapack_int const* n, + double* A, lapack_int const* lda, + double* E, + double* tau, + double* work, lapack_int const* lwork, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_dkytrd(...) LAPACK_dkytrd_base(__VA_ARGS__, 1) +#else + #define LAPACK_dkytrd(...) LAPACK_dkytrd_base(__VA_ARGS__) +#endif + +#define LAPACK_skytrd_base LAPACK_GLOBAL_SUFFIX(skytrd,SKYTRD) +void LAPACK_skytrd_base( + char const* uplo, + lapack_int const* n, + float* A, lapack_int const* lda, + float* E, + float* tau, + float* work, lapack_int const* lwork, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_skytrd(...) LAPACK_skytrd_base(__VA_ARGS__, 1) +#else + #define LAPACK_skytrd(...) LAPACK_skytrd_base(__VA_ARGS__) +#endif + #define LAPACK_dsytrd_2stage_base LAPACK_GLOBAL_SUFFIX(dsytrd_2stage,DSYTRD_2STAGE) void LAPACK_dsytrd_2stage_base( char const* vect, char const* uplo, @@ -18817,6 +19199,40 @@ void LAPACK_zsytrf_base( #define LAPACK_zsytrf(...) LAPACK_zsytrf_base(__VA_ARGS__) #endif +#define LAPACK_dkytrf_base LAPACK_GLOBAL_SUFFIX(dkytrf,DKYTRF) +void LAPACK_dkytrf_base( + char const* uplo, + lapack_int const* n, + double* A, lapack_int const* lda, lapack_int* ipiv, + double* work, lapack_int const* lwork, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_dkytrf(...) LAPACK_dkytrf_base(__VA_ARGS__, 1) +#else + #define LAPACK_dkytrf(...) LAPACK_dkytrf_base(__VA_ARGS__) +#endif + +#define LAPACK_skytrf_base LAPACK_GLOBAL_SUFFIX(skytrf,SKYTRF) +void LAPACK_skytrf_base( + char const* uplo, + lapack_int const* n, + float* A, lapack_int const* lda, lapack_int* ipiv, + float* work, lapack_int const* lwork, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_skytrf(...) LAPACK_skytrf_base(__VA_ARGS__, 1) +#else + #define LAPACK_skytrf(...) LAPACK_skytrf_base(__VA_ARGS__) +#endif + #define LAPACK_csytrf_aa_base LAPACK_GLOBAL_SUFFIX(csytrf_aa,CSYTRF_AA) void LAPACK_csytrf_aa_base( char const* uplo, @@ -19165,6 +19581,40 @@ void LAPACK_zsytri_base( #define LAPACK_zsytri(...) LAPACK_zsytri_base(__VA_ARGS__) #endif +#define LAPACK_dkytri_base LAPACK_GLOBAL_SUFFIX(dkytri,DKYTRI) +void LAPACK_dkytri_base( + char const* uplo, + lapack_int const* n, + double* A, lapack_int const* lda, lapack_int const* ipiv, + double* work, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_dkytri(...) LAPACK_dkytri_base(__VA_ARGS__, 1) +#else + #define LAPACK_dkytri(...) LAPACK_dkytri_base(__VA_ARGS__) +#endif + +#define LAPACK_skytri_base LAPACK_GLOBAL_SUFFIX(skytri,SKYTRI) +void LAPACK_skytri_base( + char const* uplo, + lapack_int const* n, + float* A, lapack_int const* lda, lapack_int const* ipiv, + float* work, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_skytri(...) LAPACK_skytri_base(__VA_ARGS__, 1) +#else + #define LAPACK_skytri(...) LAPACK_skytri_base(__VA_ARGS__) +#endif + #define LAPACK_csytri2_base LAPACK_GLOBAL_SUFFIX(csytri2,CSYTRI2) void LAPACK_csytri2_base( char const* uplo, @@ -19233,6 +19683,40 @@ void LAPACK_zsytri2_base( #define LAPACK_zsytri2(...) LAPACK_zsytri2_base(__VA_ARGS__) #endif +#define LAPACK_dkytri2_base LAPACK_GLOBAL_SUFFIX(dkytri2,DKYTRI2) +void LAPACK_dkytri2_base( + char const* uplo, + lapack_int const* n, + double* A, lapack_int const* lda, lapack_int const* ipiv, + double* work, lapack_int const* lwork, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_dkytri2(...) LAPACK_dkytri2_base(__VA_ARGS__, 1) +#else + #define LAPACK_dkytri2(...) LAPACK_dkytri2_base(__VA_ARGS__) +#endif + +#define LAPACK_skytri2_base LAPACK_GLOBAL_SUFFIX(skytri2,SKYTRI2) +void LAPACK_skytri2_base( + char const* uplo, + lapack_int const* n, + float* A, lapack_int const* lda, lapack_int const* ipiv, + float* work, lapack_int const* lwork, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_skytri2(...) LAPACK_skytri2_base(__VA_ARGS__, 1) +#else + #define LAPACK_skytri2(...) LAPACK_skytri2_base(__VA_ARGS__) +#endif + #define LAPACK_csytri2x_base LAPACK_GLOBAL_SUFFIX(csytri2x,CSYTRI2X) void LAPACK_csytri2x_base( char const* uplo, @@ -19284,6 +19768,40 @@ void LAPACK_ssytri2x_base( #define LAPACK_ssytri2x(...) LAPACK_ssytri2x_base(__VA_ARGS__) #endif +#define LAPACK_dkytri2x_base LAPACK_GLOBAL_SUFFIX(dkytri2x,DKYTRI2X) +void LAPACK_dkytri2x_base( + char const* uplo, + lapack_int const* n, + double* A, lapack_int const* lda, lapack_int const* ipiv, + double* work, lapack_int const* nb, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_dkytri2x(...) LAPACK_dkytri2x_base(__VA_ARGS__, 1) +#else + #define LAPACK_dkytri2x(...) LAPACK_dkytri2x_base(__VA_ARGS__) +#endif + +#define LAPACK_skytri2x_base LAPACK_GLOBAL_SUFFIX(skytri2x,SKYTRI2X) +void LAPACK_skytri2x_base( + char const* uplo, + lapack_int const* n, + float* A, lapack_int const* lda, lapack_int const* ipiv, + float* work, lapack_int const* nb, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_skytri2x(...) LAPACK_skytri2x_base(__VA_ARGS__, 1) +#else + #define LAPACK_skytri2x(...) LAPACK_skytri2x_base(__VA_ARGS__) +#endif + #define LAPACK_zsytri2x_base LAPACK_GLOBAL_SUFFIX(zsytri2x,ZSYTRI2X) void LAPACK_zsytri2x_base( char const* uplo, @@ -19441,6 +19959,40 @@ void LAPACK_zsytrs_base( #define LAPACK_zsytrs(...) LAPACK_zsytrs_base(__VA_ARGS__) #endif +#define LAPACK_dkytrs_base LAPACK_GLOBAL_SUFFIX(dkytrs,DKYTRS) +void LAPACK_dkytrs_base( + char const* uplo, + lapack_int const* n, lapack_int const* nrhs, + double const* A, lapack_int const* lda, lapack_int const* ipiv, + double* B, lapack_int const* ldb, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_dkytrs(...) LAPACK_dkytrs_base(__VA_ARGS__, 1) +#else + #define LAPACK_dkytrs(...) LAPACK_dkytrs_base(__VA_ARGS__) +#endif + +#define LAPACK_skytrs_base LAPACK_GLOBAL_SUFFIX(skytrs,SKYTRS) +void LAPACK_skytrs_base( + char const* uplo, + lapack_int const* n, lapack_int const* nrhs, + float const* A, lapack_int const* lda, lapack_int const* ipiv, + float* B, lapack_int const* ldb, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_skytrs(...) LAPACK_skytrs_base(__VA_ARGS__, 1) +#else + #define LAPACK_skytrs(...) LAPACK_skytrs_base(__VA_ARGS__) +#endif + #define LAPACK_csytrs2_base LAPACK_GLOBAL_SUFFIX(csytrs2,CSYTRS2) void LAPACK_csytrs2_base( char const* uplo, @@ -19513,6 +20065,42 @@ void LAPACK_zsytrs2_base( #define LAPACK_zsytrs2(...) LAPACK_zsytrs2_base(__VA_ARGS__) #endif +#define LAPACK_dkytrs2_base LAPACK_GLOBAL_SUFFIX(dkytrs2,DKYTRS2) +void LAPACK_dkytrs2_base( + char const* uplo, + lapack_int const* n, lapack_int const* nrhs, + const double* A, lapack_int const* lda, lapack_int const* ipiv, + double* B, lapack_int const* ldb, + double* work, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_dkytrs2(...) LAPACK_dkytrs2_base(__VA_ARGS__, 1) +#else + #define LAPACK_dkytrs2(...) LAPACK_dkytrs2_base(__VA_ARGS__) +#endif + +#define LAPACK_skytrs2_base LAPACK_GLOBAL_SUFFIX(skytrs2,SKYTRS2) +void LAPACK_skytrs2_base( + char const* uplo, + lapack_int const* n, lapack_int const* nrhs, + const float* A, lapack_int const* lda, lapack_int const* ipiv, + float* B, lapack_int const* ldb, + float* work, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_skytrs2(...) LAPACK_skytrs2_base(__VA_ARGS__, 1) +#else + #define LAPACK_skytrs2(...) LAPACK_skytrs2_base(__VA_ARGS__) +#endif + #define LAPACK_csytrs_3_base LAPACK_GLOBAL_SUFFIX(csytrs_3,CSYTRS_3) void LAPACK_csytrs_3_base( char const* uplo, diff --git a/LAPACKE/include/lapacke.h b/LAPACKE/include/lapacke.h index 82cc4e6c1..963972b74 100644 --- a/LAPACKE/include/lapacke.h +++ b/LAPACKE/include/lapacke.h @@ -2388,6 +2388,11 @@ float LAPACKE_clansy( int matrix_layout, char norm, char uplo, lapack_int n, double LAPACKE_zlansy( int matrix_layout, char norm, char uplo, lapack_int n, const lapack_complex_double* a, lapack_int lda ); +float LAPACKE_slanky( int matrix_layout, char norm, char uplo, lapack_int n, + const float* a, lapack_int lda ); +double LAPACKE_dlanky( int matrix_layout, char norm, char uplo, lapack_int n, + const double* a, lapack_int lda ); + float LAPACKE_slantr( int matrix_layout, char norm, char uplo, char diag, lapack_int m, lapack_int n, const float* a, lapack_int lda ); @@ -3674,6 +3679,11 @@ lapack_int LAPACKE_zsteqr( int matrix_layout, char compz, lapack_int n, double* d, double* e, lapack_complex_double* z, lapack_int ldz ); +lapack_int LAPACKE_skteqr( int matrix_layout, char compz, lapack_int n, + float* e, float* z, lapack_int ldz ); +lapack_int LAPACKE_dkteqr( int matrix_layout, char compz, lapack_int n, + double* e, double* z, lapack_int ldz ); + lapack_int LAPACKE_ssterf( lapack_int n, float* d, float* e ); lapack_int LAPACKE_dsterf( lapack_int n, double* d, double* e ); @@ -3682,6 +3692,11 @@ lapack_int LAPACKE_sstev( int matrix_layout, char jobz, lapack_int n, float* d, lapack_int LAPACKE_dstev( int matrix_layout, char jobz, lapack_int n, double* d, double* e, double* z, lapack_int ldz ); +lapack_int LAPACKE_sktev( int matrix_layout, char jobz, lapack_int n, float* d, + float* e, float* z, lapack_int ldz ); +lapack_int LAPACKE_dktev( int matrix_layout, char jobz, lapack_int n, double* d, + double* e, double* z, lapack_int ldz ); + lapack_int LAPACKE_sstevd( int matrix_layout, char jobz, lapack_int n, float* d, float* e, float* z, lapack_int ldz ); lapack_int LAPACKE_dstevd( int matrix_layout, char jobz, lapack_int n, double* d, @@ -3742,6 +3757,11 @@ lapack_int LAPACKE_ssyev( int matrix_layout, char jobz, char uplo, lapack_int n, lapack_int LAPACKE_dsyev( int matrix_layout, char jobz, char uplo, lapack_int n, double* a, lapack_int lda, double* w ); +lapack_int LAPACKE_skyev( int matrix_layout, char jobz, char uplo, lapack_int n, + float* a, lapack_int lda, float* w ); +lapack_int LAPACKE_dkyev( int matrix_layout, char jobz, char uplo, lapack_int n, + double* a, lapack_int lda, double* w ); + lapack_int LAPACKE_ssyevd( int matrix_layout, char jobz, char uplo, lapack_int n, float* a, lapack_int lda, float* w ); lapack_int LAPACKE_dsyevd( int matrix_layout, char jobz, char uplo, lapack_int n, @@ -3776,6 +3796,13 @@ lapack_int LAPACKE_dsygst( int matrix_layout, lapack_int itype, char uplo, lapack_int n, double* a, lapack_int lda, const double* b, lapack_int ldb ); +lapack_int LAPACKE_skygst( int matrix_layout, lapack_int itype, char uplo, + lapack_int n, float* a, lapack_int lda, + const float* b, lapack_int ldb ); +lapack_int LAPACKE_dkygst( int matrix_layout, lapack_int itype, char uplo, + lapack_int n, double* a, lapack_int lda, + const double* b, lapack_int ldb ); + lapack_int LAPACKE_ssygv( int matrix_layout, lapack_int itype, char jobz, char uplo, lapack_int n, float* a, lapack_int lda, float* b, lapack_int ldb, float* w ); @@ -3783,6 +3810,13 @@ lapack_int LAPACKE_dsygv( int matrix_layout, lapack_int itype, char jobz, char uplo, lapack_int n, double* a, lapack_int lda, double* b, lapack_int ldb, double* w ); +lapack_int LAPACKE_skygv( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, float* a, lapack_int lda, + float* b, lapack_int ldb, float* w ); +lapack_int LAPACKE_dkygv( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, double* a, lapack_int lda, + double* b, lapack_int ldb, double* w ); + lapack_int LAPACKE_ssygvd( int matrix_layout, lapack_int itype, char jobz, char uplo, lapack_int n, float* a, lapack_int lda, float* b, lapack_int ldb, float* w ); @@ -3884,6 +3918,13 @@ lapack_int LAPACKE_zsysv( int matrix_layout, char uplo, lapack_int n, lapack_int lda, lapack_int* ipiv, lapack_complex_double* b, lapack_int ldb ); +lapack_int LAPACKE_skysv( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, float* a, lapack_int lda, + lapack_int* ipiv, float* b, lapack_int ldb ); +lapack_int LAPACKE_dkysv( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, double* a, lapack_int lda, + lapack_int* ipiv, double* b, lapack_int ldb ); + lapack_int LAPACKE_ssysvx( int matrix_layout, char fact, char uplo, lapack_int n, lapack_int nrhs, const float* a, lapack_int lda, float* af, lapack_int ldaf, lapack_int* ipiv, @@ -3957,6 +3998,11 @@ lapack_int LAPACKE_ssytrd( int matrix_layout, char uplo, lapack_int n, float* a, lapack_int LAPACKE_dsytrd( int matrix_layout, char uplo, lapack_int n, double* a, lapack_int lda, double* d, double* e, double* tau ); +lapack_int LAPACKE_skytrd( int matrix_layout, char uplo, lapack_int n, float* a, + lapack_int lda, float* e, float* tau ); +lapack_int LAPACKE_dkytrd( int matrix_layout, char uplo, lapack_int n, double* a, + lapack_int lda, double* e, double* tau ); + lapack_int LAPACKE_ssytrf( int matrix_layout, char uplo, lapack_int n, float* a, lapack_int lda, lapack_int* ipiv ); lapack_int LAPACKE_dsytrf( int matrix_layout, char uplo, lapack_int n, double* a, @@ -3968,6 +4014,11 @@ lapack_int LAPACKE_zsytrf( int matrix_layout, char uplo, lapack_int n, lapack_complex_double* a, lapack_int lda, lapack_int* ipiv ); +lapack_int LAPACKE_skytrf( int matrix_layout, char uplo, lapack_int n, float* a, + lapack_int lda, lapack_int* ipiv ); +lapack_int LAPACKE_dkytrf( int matrix_layout, char uplo, lapack_int n, double* a, + lapack_int lda, lapack_int* ipiv ); + lapack_int LAPACKE_ssytri( int matrix_layout, char uplo, lapack_int n, float* a, lapack_int lda, const lapack_int* ipiv ); lapack_int LAPACKE_dsytri( int matrix_layout, char uplo, lapack_int n, double* a, @@ -3979,6 +4030,11 @@ lapack_int LAPACKE_zsytri( int matrix_layout, char uplo, lapack_int n, lapack_complex_double* a, lapack_int lda, const lapack_int* ipiv ); +lapack_int LAPACKE_skytri( int matrix_layout, char uplo, lapack_int n, float* a, + lapack_int lda, const lapack_int* ipiv ); +lapack_int LAPACKE_dkytri( int matrix_layout, char uplo, lapack_int n, double* a, + lapack_int lda, const lapack_int* ipiv ); + lapack_int LAPACKE_ssytrs( int matrix_layout, char uplo, lapack_int n, lapack_int nrhs, const float* a, lapack_int lda, const lapack_int* ipiv, float* b, lapack_int ldb ); @@ -3994,6 +4050,13 @@ lapack_int LAPACKE_zsytrs( int matrix_layout, char uplo, lapack_int n, lapack_int lda, const lapack_int* ipiv, lapack_complex_double* b, lapack_int ldb ); +lapack_int LAPACKE_skytrs( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const float* a, lapack_int lda, + const lapack_int* ipiv, float* b, lapack_int ldb ); +lapack_int LAPACKE_dkytrs( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const double* a, lapack_int lda, + const lapack_int* ipiv, double* b, lapack_int ldb ); + lapack_int LAPACKE_stbcon( int matrix_layout, char norm, char uplo, char diag, lapack_int n, lapack_int kd, const float* ab, lapack_int ldab, float* rcond ); @@ -7807,6 +7870,13 @@ double LAPACKE_zlansy_work( int matrix_layout, char norm, char uplo, lapack_int n, const lapack_complex_double* a, lapack_int lda, double* work ); +float LAPACKE_slanky_work( int matrix_layout, char norm, char uplo, + lapack_int n, const float* a, lapack_int lda, + float* work ); +double LAPACKE_dlanky_work( int matrix_layout, char norm, char uplo, + lapack_int n, const double* a, lapack_int lda, + double* work ); + float LAPACKE_slantr_work( int matrix_layout, char norm, char uplo, char diag, lapack_int m, lapack_int n, const float* a, lapack_int lda, float* work ); @@ -9339,6 +9409,13 @@ lapack_int LAPACKE_zsteqr_work( int matrix_layout, char compz, lapack_int n, double* d, double* e, lapack_complex_double* z, lapack_int ldz, double* work ); +lapack_int LAPACKE_skteqr_work( int matrix_layout, char compz, lapack_int n, + float* e, float* z, lapack_int ldz, + float* work ); +lapack_int LAPACKE_dkteqr_work( int matrix_layout, char compz, lapack_int n, + double* e, double* z, lapack_int ldz, + double* work ); + lapack_int LAPACKE_ssterf_work( lapack_int n, float* d, float* e ); lapack_int LAPACKE_dsterf_work( lapack_int n, double* d, double* e ); @@ -9349,6 +9426,13 @@ lapack_int LAPACKE_dstev_work( int matrix_layout, char jobz, lapack_int n, double* d, double* e, double* z, lapack_int ldz, double* work ); +lapack_int LAPACKE_sktev_work( int matrix_layout, char jobz, lapack_int n, + float* d, float* e, float* z, lapack_int ldz, + float* work ); +lapack_int LAPACKE_dktev_work( int matrix_layout, char jobz, lapack_int n, + double* d, double* e, double* z, lapack_int ldz, + double* work ); + lapack_int LAPACKE_sstevd_work( int matrix_layout, char jobz, lapack_int n, float* d, float* e, float* z, lapack_int ldz, float* work, lapack_int lwork, @@ -9426,6 +9510,13 @@ lapack_int LAPACKE_dsyev_work( int matrix_layout, char jobz, char uplo, lapack_int n, double* a, lapack_int lda, double* w, double* work, lapack_int lwork ); +lapack_int LAPACKE_skyev_work( int matrix_layout, char jobz, char uplo, + lapack_int n, float* a, lapack_int lda, float* w, + float* work, lapack_int lwork ); +lapack_int LAPACKE_dkyev_work( int matrix_layout, char jobz, char uplo, + lapack_int n, double* a, lapack_int lda, + double* w, double* work, lapack_int lwork ); + lapack_int LAPACKE_ssyevd_work( int matrix_layout, char jobz, char uplo, lapack_int n, float* a, lapack_int lda, float* w, float* work, lapack_int lwork, @@ -9474,6 +9565,13 @@ lapack_int LAPACKE_dsygst_work( int matrix_layout, lapack_int itype, char uplo, lapack_int n, double* a, lapack_int lda, const double* b, lapack_int ldb ); +lapack_int LAPACKE_skygst_work( int matrix_layout, lapack_int itype, char uplo, + lapack_int n, float* a, lapack_int lda, + const float* b, lapack_int ldb ); +lapack_int LAPACKE_dkygst_work( int matrix_layout, lapack_int itype, char uplo, + lapack_int n, double* a, lapack_int lda, + const double* b, lapack_int ldb ); + lapack_int LAPACKE_ssygv_work( int matrix_layout, lapack_int itype, char jobz, char uplo, lapack_int n, float* a, lapack_int lda, float* b, lapack_int ldb, @@ -9483,6 +9581,15 @@ lapack_int LAPACKE_dsygv_work( int matrix_layout, lapack_int itype, char jobz, lapack_int lda, double* b, lapack_int ldb, double* w, double* work, lapack_int lwork ); +lapack_int LAPACKE_skygv_work( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, float* a, + lapack_int lda, float* b, lapack_int ldb, + float* w, float* work, lapack_int lwork ); +lapack_int LAPACKE_dkygv_work( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, double* a, + lapack_int lda, double* b, lapack_int ldb, + double* w, double* work, lapack_int lwork ); + lapack_int LAPACKE_ssygvd_work( int matrix_layout, lapack_int itype, char jobz, char uplo, lapack_int n, float* a, lapack_int lda, float* b, lapack_int ldb, @@ -9608,6 +9715,15 @@ lapack_int LAPACKE_zsysv_work( int matrix_layout, char uplo, lapack_int n, lapack_complex_double* b, lapack_int ldb, lapack_complex_double* work, lapack_int lwork ); +lapack_int LAPACKE_skysv_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, float* a, lapack_int lda, + lapack_int* ipiv, float* b, lapack_int ldb, + float* work, lapack_int lwork ); +lapack_int LAPACKE_dkysv_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, double* a, lapack_int lda, + lapack_int* ipiv, double* b, lapack_int ldb, + double* work, lapack_int lwork ); + lapack_int LAPACKE_ssysvx_work( int matrix_layout, char fact, char uplo, lapack_int n, lapack_int nrhs, const float* a, lapack_int lda, float* af, lapack_int ldaf, @@ -9696,6 +9812,13 @@ lapack_int LAPACKE_dsytrd_work( int matrix_layout, char uplo, lapack_int n, double* a, lapack_int lda, double* d, double* e, double* tau, double* work, lapack_int lwork ); +lapack_int LAPACKE_skytrd_work( int matrix_layout, char uplo, lapack_int n, + float* a, lapack_int lda, float* e, + float* tau, float* work, lapack_int lwork ); +lapack_int LAPACKE_dkytrd_work( int matrix_layout, char uplo, lapack_int n, + double* a, lapack_int lda, double* e, + double* tau, double* work, lapack_int lwork ); + lapack_int LAPACKE_ssytrf_work( int matrix_layout, char uplo, lapack_int n, float* a, lapack_int lda, lapack_int* ipiv, float* work, lapack_int lwork ); @@ -9711,6 +9834,13 @@ lapack_int LAPACKE_zsytrf_work( int matrix_layout, char uplo, lapack_int n, lapack_int* ipiv, lapack_complex_double* work, lapack_int lwork ); +lapack_int LAPACKE_skytrf_work( int matrix_layout, char uplo, lapack_int n, + float* a, lapack_int lda, lapack_int* ipiv, + float* work, lapack_int lwork ); +lapack_int LAPACKE_dkytrf_work( int matrix_layout, char uplo, lapack_int n, + double* a, lapack_int lda, lapack_int* ipiv, + double* work, lapack_int lwork ); + lapack_int LAPACKE_ssytri_work( int matrix_layout, char uplo, lapack_int n, float* a, lapack_int lda, const lapack_int* ipiv, float* work ); @@ -9726,6 +9856,13 @@ lapack_int LAPACKE_zsytri_work( int matrix_layout, char uplo, lapack_int n, const lapack_int* ipiv, lapack_complex_double* work ); +lapack_int LAPACKE_skytri_work( int matrix_layout, char uplo, lapack_int n, + float* a, lapack_int lda, + const lapack_int* ipiv, float* work ); +lapack_int LAPACKE_dkytri_work( int matrix_layout, char uplo, lapack_int n, + double* a, lapack_int lda, + const lapack_int* ipiv, double* work ); + lapack_int LAPACKE_ssytrs_work( int matrix_layout, char uplo, lapack_int n, lapack_int nrhs, const float* a, lapack_int lda, const lapack_int* ipiv, float* b, @@ -9743,6 +9880,15 @@ lapack_int LAPACKE_zsytrs_work( int matrix_layout, char uplo, lapack_int n, lapack_int lda, const lapack_int* ipiv, lapack_complex_double* b, lapack_int ldb ); +lapack_int LAPACKE_skytrs_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const float* a, lapack_int lda, + const lapack_int* ipiv, float* b, + lapack_int ldb ); +lapack_int LAPACKE_dkytrs_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const double* a, + lapack_int lda, const lapack_int* ipiv, + double* b, lapack_int ldb ); + lapack_int LAPACKE_stbcon_work( int matrix_layout, char norm, char uplo, char diag, lapack_int n, lapack_int kd, const float* ab, lapack_int ldab, float* rcond, @@ -10946,18 +11092,35 @@ lapack_int LAPACKE_dsyconv( int matrix_layout, char uplo, char way, lapack_int n lapack_int LAPACKE_dsyconv_work( int matrix_layout, char uplo, char way, lapack_int n, double* a, lapack_int lda, const lapack_int* ipiv, double* e ); +lapack_int LAPACKE_dkyconv( int matrix_layout, char uplo, char way, lapack_int n, + double* a, lapack_int lda, const lapack_int* ipiv, double* e); +lapack_int LAPACKE_dkyconv_work( int matrix_layout, char uplo, char way, + lapack_int n, double* a, lapack_int lda, + const lapack_int* ipiv, double* e ); lapack_int LAPACKE_dsyswapr( int matrix_layout, char uplo, lapack_int n, double* a, lapack_int lda, lapack_int i1, lapack_int i2 ); lapack_int LAPACKE_dsyswapr_work( int matrix_layout, char uplo, lapack_int n, double* a, lapack_int lda, lapack_int i1, lapack_int i2 ); +lapack_int LAPACKE_dkyswapr( int matrix_layout, char uplo, lapack_int n, + double* a, lapack_int lda, lapack_int i1, + lapack_int i2 ); +lapack_int LAPACKE_dkyswapr_work( int matrix_layout, char uplo, lapack_int n, + double* a, lapack_int lda, lapack_int i1, + lapack_int i2 ); lapack_int LAPACKE_dsytri2( int matrix_layout, char uplo, lapack_int n, double* a, lapack_int lda, const lapack_int* ipiv ); lapack_int LAPACKE_dsytri2_work( int matrix_layout, char uplo, lapack_int n, double* a, lapack_int lda, const lapack_int* ipiv, double* work, lapack_int lwork ); +lapack_int LAPACKE_dkytri2( int matrix_layout, char uplo, lapack_int n, + double* a, lapack_int lda, const lapack_int* ipiv ); +lapack_int LAPACKE_dkytri2_work( int matrix_layout, char uplo, lapack_int n, + double* a, lapack_int lda, + const lapack_int* ipiv, + double* work, lapack_int lwork ); lapack_int LAPACKE_dsytri2x( int matrix_layout, char uplo, lapack_int n, double* a, lapack_int lda, const lapack_int* ipiv, lapack_int nb ); @@ -10965,6 +11128,13 @@ lapack_int LAPACKE_dsytri2x_work( int matrix_layout, char uplo, lapack_int n, double* a, lapack_int lda, const lapack_int* ipiv, double* work, lapack_int nb ); +lapack_int LAPACKE_dkytri2x( int matrix_layout, char uplo, lapack_int n, + double* a, lapack_int lda, const lapack_int* ipiv, + lapack_int nb ); +lapack_int LAPACKE_dkytri2x_work( int matrix_layout, char uplo, lapack_int n, + double* a, lapack_int lda, + const lapack_int* ipiv, double* work, + lapack_int nb ); lapack_int LAPACKE_dsytrs2( int matrix_layout, char uplo, lapack_int n, lapack_int nrhs, const double* a, lapack_int lda, const lapack_int* ipiv, double* b, lapack_int ldb ); @@ -10972,6 +11142,13 @@ lapack_int LAPACKE_dsytrs2_work( int matrix_layout, char uplo, lapack_int n, lapack_int nrhs, const double* a, lapack_int lda, const lapack_int* ipiv, double* b, lapack_int ldb, double* work ); +lapack_int LAPACKE_dkytrs2( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const double* a, lapack_int lda, + const lapack_int* ipiv, double* b, lapack_int ldb ); +lapack_int LAPACKE_dkytrs2_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const double* a, + lapack_int lda, const lapack_int* ipiv, + double* b, lapack_int ldb, double* work ); lapack_int LAPACKE_sbbcsd( int matrix_layout, char jobu1, char jobu2, char jobv1t, char jobv2t, char trans, lapack_int m, lapack_int p, lapack_int q, float* theta, float* phi, @@ -11041,18 +11218,35 @@ lapack_int LAPACKE_ssyconv( int matrix_layout, char uplo, char way, lapack_int n lapack_int LAPACKE_ssyconv_work( int matrix_layout, char uplo, char way, lapack_int n, float* a, lapack_int lda, const lapack_int* ipiv, float* e ); +lapack_int LAPACKE_skyconv( int matrix_layout, char uplo, char way, lapack_int n, + float* a, lapack_int lda, const lapack_int* ipiv, float* e ); +lapack_int LAPACKE_skyconv_work( int matrix_layout, char uplo, char way, + lapack_int n, float* a, lapack_int lda, + const lapack_int* ipiv, float* e ); lapack_int LAPACKE_ssyswapr( int matrix_layout, char uplo, lapack_int n, float* a, lapack_int lda, lapack_int i1, lapack_int i2 ); lapack_int LAPACKE_ssyswapr_work( int matrix_layout, char uplo, lapack_int n, float* a, lapack_int lda, lapack_int i1, lapack_int i2 ); +lapack_int LAPACKE_skyswapr( int matrix_layout, char uplo, lapack_int n, + float* a, lapack_int lda, lapack_int i1, + lapack_int i2 ); +lapack_int LAPACKE_skyswapr_work( int matrix_layout, char uplo, lapack_int n, + float* a, lapack_int lda, lapack_int i1, + lapack_int i2 ); lapack_int LAPACKE_ssytri2( int matrix_layout, char uplo, lapack_int n, float* a, lapack_int lda, const lapack_int* ipiv ); lapack_int LAPACKE_ssytri2_work( int matrix_layout, char uplo, lapack_int n, float* a, lapack_int lda, const lapack_int* ipiv, float* work, lapack_int lwork ); +lapack_int LAPACKE_skytri2( int matrix_layout, char uplo, lapack_int n, float* a, + lapack_int lda, const lapack_int* ipiv ); +lapack_int LAPACKE_skytri2_work( int matrix_layout, char uplo, lapack_int n, + float* a, lapack_int lda, + const lapack_int* ipiv, + float* work, lapack_int lwork ); lapack_int LAPACKE_ssytri2x( int matrix_layout, char uplo, lapack_int n, float* a, lapack_int lda, const lapack_int* ipiv, lapack_int nb ); @@ -11060,6 +11254,13 @@ lapack_int LAPACKE_ssytri2x_work( int matrix_layout, char uplo, lapack_int n, float* a, lapack_int lda, const lapack_int* ipiv, float* work, lapack_int nb ); +lapack_int LAPACKE_skytri2x( int matrix_layout, char uplo, lapack_int n, + float* a, lapack_int lda, const lapack_int* ipiv, + lapack_int nb ); +lapack_int LAPACKE_skytri2x_work( int matrix_layout, char uplo, lapack_int n, + float* a, lapack_int lda, + const lapack_int* ipiv, float* work, + lapack_int nb ); lapack_int LAPACKE_ssytrs2( int matrix_layout, char uplo, lapack_int n, lapack_int nrhs, const float* a, lapack_int lda, const lapack_int* ipiv, float* b, lapack_int ldb ); @@ -11067,6 +11268,13 @@ lapack_int LAPACKE_ssytrs2_work( int matrix_layout, char uplo, lapack_int n, lapack_int nrhs, const float* a, lapack_int lda, const lapack_int* ipiv, float* b, lapack_int ldb, float* work ); +lapack_int LAPACKE_skytrs2( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const float* a, lapack_int lda, + const lapack_int* ipiv, float* b, lapack_int ldb ); +lapack_int LAPACKE_skytrs2_work( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const float* a, + lapack_int lda, const lapack_int* ipiv, + float* b, lapack_int ldb, float* work ); lapack_int LAPACKE_zbbcsd( int matrix_layout, char jobu1, char jobu2, char jobv1t, char jobv2t, char trans, lapack_int m, lapack_int p, lapack_int q, double* theta, diff --git a/LAPACKE/include/lapacke_64.h b/LAPACKE/include/lapacke_64.h index c8d3c552a..fe629470d 100644 --- a/LAPACKE/include/lapacke_64.h +++ b/LAPACKE/include/lapacke_64.h @@ -2354,6 +2354,11 @@ float LAPACKE_clansy_64( int matrix_layout, char norm, char uplo, int64_t n, double LAPACKE_zlansy_64( int matrix_layout, char norm, char uplo, int64_t n, const lapack_complex_double* a, int64_t lda ); +float LAPACKE_slanky_64( int matrix_layout, char norm, char uplo, int64_t n, + const float* a, int64_t lda ); +double LAPACKE_dlanky_64( int matrix_layout, char norm, char uplo, int64_t n, + const double* a, int64_t lda ); + float LAPACKE_slantr_64( int matrix_layout, char norm, char uplo, char diag, int64_t m, int64_t n, const float* a, int64_t lda ); @@ -3640,6 +3645,11 @@ int64_t LAPACKE_zsteqr_64( int matrix_layout, char compz, int64_t n, double* d, double* e, lapack_complex_double* z, int64_t ldz ); +int64_t LAPACKE_skteqr_64( int matrix_layout, char compz, int64_t n, + float* e, float* z, int64_t ldz ); +int64_t LAPACKE_dkteqr_64( int matrix_layout, char compz, int64_t n, + double* e, double* z, int64_t ldz ); + int64_t LAPACKE_ssterf_64( int64_t n, float* d, float* e ); int64_t LAPACKE_dsterf_64( int64_t n, double* d, double* e ); @@ -3648,6 +3658,11 @@ int64_t LAPACKE_sstev_64( int matrix_layout, char jobz, int64_t n, float* d, int64_t LAPACKE_dstev_64( int matrix_layout, char jobz, int64_t n, double* d, double* e, double* z, int64_t ldz ); +int64_t LAPACKE_sktev_64( int matrix_layout, char jobz, int64_t n, float* d, + float* e, float* z, int64_t ldz ); +int64_t LAPACKE_dktev_64( int matrix_layout, char jobz, int64_t n, double* d, + double* e, double* z, int64_t ldz ); + int64_t LAPACKE_sstevd_64( int matrix_layout, char jobz, int64_t n, float* d, float* e, float* z, int64_t ldz ); int64_t LAPACKE_dstevd_64( int matrix_layout, char jobz, int64_t n, double* d, @@ -3708,6 +3723,11 @@ int64_t LAPACKE_ssyev_64( int matrix_layout, char jobz, char uplo, int64_t n, int64_t LAPACKE_dsyev_64( int matrix_layout, char jobz, char uplo, int64_t n, double* a, int64_t lda, double* w ); +int64_t LAPACKE_skyev_64( int matrix_layout, char jobz, char uplo, int64_t n, + float* a, int64_t lda, float* w ); +int64_t LAPACKE_dkyev_64( int matrix_layout, char jobz, char uplo, int64_t n, + double* a, int64_t lda, double* w ); + int64_t LAPACKE_ssyevd_64( int matrix_layout, char jobz, char uplo, int64_t n, float* a, int64_t lda, float* w ); int64_t LAPACKE_dsyevd_64( int matrix_layout, char jobz, char uplo, int64_t n, @@ -3742,6 +3762,13 @@ int64_t LAPACKE_dsygst_64( int matrix_layout, int64_t itype, char uplo, int64_t n, double* a, int64_t lda, const double* b, int64_t ldb ); +int64_t LAPACKE_skygst_64( int matrix_layout, int64_t itype, char uplo, + int64_t n, float* a, int64_t lda, + const float* b, int64_t ldb ); +int64_t LAPACKE_dkygst_64( int matrix_layout, int64_t itype, char uplo, + int64_t n, double* a, int64_t lda, + const double* b, int64_t ldb ); + int64_t LAPACKE_ssygv_64( int matrix_layout, int64_t itype, char jobz, char uplo, int64_t n, float* a, int64_t lda, float* b, int64_t ldb, float* w ); @@ -3749,6 +3776,13 @@ int64_t LAPACKE_dsygv_64( int matrix_layout, int64_t itype, char jobz, char uplo, int64_t n, double* a, int64_t lda, double* b, int64_t ldb, double* w ); +int64_t LAPACKE_skygv_64( int matrix_layout, int64_t itype, char jobz, + char uplo, int64_t n, float* a, int64_t lda, + float* b, int64_t ldb, float* w ); +int64_t LAPACKE_dkygv_64( int matrix_layout, int64_t itype, char jobz, + char uplo, int64_t n, double* a, int64_t lda, + double* b, int64_t ldb, double* w ); + int64_t LAPACKE_ssygvd_64( int matrix_layout, int64_t itype, char jobz, char uplo, int64_t n, float* a, int64_t lda, float* b, int64_t ldb, float* w ); @@ -3850,6 +3884,13 @@ int64_t LAPACKE_zsysv_64( int matrix_layout, char uplo, int64_t n, int64_t lda, int64_t* ipiv, lapack_complex_double* b, int64_t ldb ); +int64_t LAPACKE_skysv_64( int matrix_layout, char uplo, int64_t n, + int64_t nrhs, float* a, int64_t lda, + int64_t* ipiv, float* b, int64_t ldb ); +int64_t LAPACKE_dkysv_64( int matrix_layout, char uplo, int64_t n, + int64_t nrhs, double* a, int64_t lda, + int64_t* ipiv, double* b, int64_t ldb ); + int64_t LAPACKE_ssysvx_64( int matrix_layout, char fact, char uplo, int64_t n, int64_t nrhs, const float* a, int64_t lda, float* af, int64_t ldaf, int64_t* ipiv, @@ -3923,6 +3964,11 @@ int64_t LAPACKE_ssytrd_64( int matrix_layout, char uplo, int64_t n, float* a, int64_t LAPACKE_dsytrd_64( int matrix_layout, char uplo, int64_t n, double* a, int64_t lda, double* d, double* e, double* tau ); +int64_t LAPACKE_skytrd_64( int matrix_layout, char uplo, int64_t n, float* a, + int64_t lda, float* e, float* tau ); +int64_t LAPACKE_dkytrd_64( int matrix_layout, char uplo, int64_t n, double* a, + int64_t lda, double* e, double* tau ); + int64_t LAPACKE_ssytrf_64( int matrix_layout, char uplo, int64_t n, float* a, int64_t lda, int64_t* ipiv ); int64_t LAPACKE_dsytrf_64( int matrix_layout, char uplo, int64_t n, double* a, @@ -3934,6 +3980,11 @@ int64_t LAPACKE_zsytrf_64( int matrix_layout, char uplo, int64_t n, lapack_complex_double* a, int64_t lda, int64_t* ipiv ); +int64_t LAPACKE_skytrf_64( int matrix_layout, char uplo, int64_t n, float* a, + int64_t lda, int64_t* ipiv ); +int64_t LAPACKE_dkytrf_64( int matrix_layout, char uplo, int64_t n, double* a, + int64_t lda, int64_t* ipiv ); + int64_t LAPACKE_ssytri_64( int matrix_layout, char uplo, int64_t n, float* a, int64_t lda, const int64_t* ipiv ); int64_t LAPACKE_dsytri_64( int matrix_layout, char uplo, int64_t n, double* a, @@ -3945,6 +3996,11 @@ int64_t LAPACKE_zsytri_64( int matrix_layout, char uplo, int64_t n, lapack_complex_double* a, int64_t lda, const int64_t* ipiv ); +int64_t LAPACKE_skytri_64( int matrix_layout, char uplo, int64_t n, float* a, + int64_t lda, const int64_t* ipiv ); +int64_t LAPACKE_dkytri_64( int matrix_layout, char uplo, int64_t n, double* a, + int64_t lda, const int64_t* ipiv ); + int64_t LAPACKE_ssytrs_64( int matrix_layout, char uplo, int64_t n, int64_t nrhs, const float* a, int64_t lda, const int64_t* ipiv, float* b, int64_t ldb ); @@ -3960,6 +4016,13 @@ int64_t LAPACKE_zsytrs_64( int matrix_layout, char uplo, int64_t n, int64_t lda, const int64_t* ipiv, lapack_complex_double* b, int64_t ldb ); +int64_t LAPACKE_skytrs_64( int matrix_layout, char uplo, int64_t n, + int64_t nrhs, const float* a, int64_t lda, + const int64_t* ipiv, float* b, int64_t ldb ); +int64_t LAPACKE_dkytrs_64( int matrix_layout, char uplo, int64_t n, + int64_t nrhs, const double* a, int64_t lda, + const int64_t* ipiv, double* b, int64_t ldb ); + int64_t LAPACKE_stbcon_64( int matrix_layout, char norm, char uplo, char diag, int64_t n, int64_t kd, const float* ab, int64_t ldab, float* rcond ); @@ -7774,6 +7837,13 @@ double LAPACKE_zlansy_work_64( int matrix_layout, char norm, char uplo, int64_t n, const lapack_complex_double* a, int64_t lda, double* work ); +float LAPACKE_slanky_work_64( int matrix_layout, char norm, char uplo, + int64_t n, const float* a, int64_t lda, + float* work ); +double LAPACKE_dlanky_work_64( int matrix_layout, char norm, char uplo, + int64_t n, const double* a, int64_t lda, + double* work ); + float LAPACKE_slantr_work_64( int matrix_layout, char norm, char uplo, char diag, int64_t m, int64_t n, const float* a, int64_t lda, float* work ); @@ -9306,6 +9376,13 @@ int64_t LAPACKE_zsteqr_work_64( int matrix_layout, char compz, int64_t n, double* d, double* e, lapack_complex_double* z, int64_t ldz, double* work ); +int64_t LAPACKE_skteqr_work_64( int matrix_layout, char compz, int64_t n, + float* e, float* z, int64_t ldz, + float* work ); +int64_t LAPACKE_dkteqr_work_64( int matrix_layout, char compz, int64_t n, + double* e, double* z, int64_t ldz, + double* work ); + int64_t LAPACKE_ssterf_work_64( int64_t n, float* d, float* e ); int64_t LAPACKE_dsterf_work_64( int64_t n, double* d, double* e ); @@ -9316,6 +9393,13 @@ int64_t LAPACKE_dstev_work_64( int matrix_layout, char jobz, int64_t n, double* d, double* e, double* z, int64_t ldz, double* work ); +int64_t LAPACKE_sktev_work_64( int matrix_layout, char jobz, int64_t n, + float* d, float* e, float* z, int64_t ldz, + float* work ); +int64_t LAPACKE_dktev_work_64( int matrix_layout, char jobz, int64_t n, + double* d, double* e, double* z, int64_t ldz, + double* work ); + int64_t LAPACKE_sstevd_work_64( int matrix_layout, char jobz, int64_t n, float* d, float* e, float* z, int64_t ldz, float* work, int64_t lwork, @@ -9393,6 +9477,13 @@ int64_t LAPACKE_dsyev_work_64( int matrix_layout, char jobz, char uplo, int64_t n, double* a, int64_t lda, double* w, double* work, int64_t lwork ); +int64_t LAPACKE_skyev_work_64( int matrix_layout, char jobz, char uplo, + int64_t n, float* a, int64_t lda, float* w, + float* work, int64_t lwork ); +int64_t LAPACKE_dkyev_work_64( int matrix_layout, char jobz, char uplo, + int64_t n, double* a, int64_t lda, + double* w, double* work, int64_t lwork ); + int64_t LAPACKE_ssyevd_work_64( int matrix_layout, char jobz, char uplo, int64_t n, float* a, int64_t lda, float* w, float* work, int64_t lwork, @@ -9441,6 +9532,13 @@ int64_t LAPACKE_dsygst_work_64( int matrix_layout, int64_t itype, char uplo, int64_t n, double* a, int64_t lda, const double* b, int64_t ldb ); +int64_t LAPACKE_skygst_work_64( int matrix_layout, int64_t itype, char uplo, + int64_t n, float* a, int64_t lda, + const float* b, int64_t ldb ); +int64_t LAPACKE_dkygst_work_64( int matrix_layout, int64_t itype, char uplo, + int64_t n, double* a, int64_t lda, + const double* b, int64_t ldb ); + int64_t LAPACKE_ssygv_work_64( int matrix_layout, int64_t itype, char jobz, char uplo, int64_t n, float* a, int64_t lda, float* b, int64_t ldb, @@ -9450,6 +9548,15 @@ int64_t LAPACKE_dsygv_work_64( int matrix_layout, int64_t itype, char jobz, int64_t lda, double* b, int64_t ldb, double* w, double* work, int64_t lwork ); +int64_t LAPACKE_skygv_work_64( int matrix_layout, int64_t itype, char jobz, + char uplo, int64_t n, float* a, + int64_t lda, float* b, int64_t ldb, + float* w, float* work, int64_t lwork ); +int64_t LAPACKE_dkygv_work_64( int matrix_layout, int64_t itype, char jobz, + char uplo, int64_t n, double* a, + int64_t lda, double* b, int64_t ldb, + double* w, double* work, int64_t lwork ); + int64_t LAPACKE_ssygvd_work_64( int matrix_layout, int64_t itype, char jobz, char uplo, int64_t n, float* a, int64_t lda, float* b, int64_t ldb, @@ -9575,6 +9682,15 @@ int64_t LAPACKE_zsysv_work_64( int matrix_layout, char uplo, int64_t n, lapack_complex_double* b, int64_t ldb, lapack_complex_double* work, int64_t lwork ); +int64_t LAPACKE_skysv_work_64( int matrix_layout, char uplo, int64_t n, + int64_t nrhs, float* a, int64_t lda, + int64_t* ipiv, float* b, int64_t ldb, + float* work, int64_t lwork ); +int64_t LAPACKE_dkysv_work_64( int matrix_layout, char uplo, int64_t n, + int64_t nrhs, double* a, int64_t lda, + int64_t* ipiv, double* b, int64_t ldb, + double* work, int64_t lwork ); + int64_t LAPACKE_ssysvx_work_64( int matrix_layout, char fact, char uplo, int64_t n, int64_t nrhs, const float* a, int64_t lda, float* af, int64_t ldaf, @@ -9663,6 +9779,13 @@ int64_t LAPACKE_dsytrd_work_64( int matrix_layout, char uplo, int64_t n, double* a, int64_t lda, double* d, double* e, double* tau, double* work, int64_t lwork ); +int64_t LAPACKE_skytrd_work_64( int matrix_layout, char uplo, int64_t n, + float* a, int64_t lda, float* e, + float* tau, float* work, int64_t lwork ); +int64_t LAPACKE_dkytrd_work_64( int matrix_layout, char uplo, int64_t n, + double* a, int64_t lda, double* e, + double* tau, double* work, int64_t lwork ); + int64_t LAPACKE_ssytrf_work_64( int matrix_layout, char uplo, int64_t n, float* a, int64_t lda, int64_t* ipiv, float* work, int64_t lwork ); @@ -9678,6 +9801,13 @@ int64_t LAPACKE_zsytrf_work_64( int matrix_layout, char uplo, int64_t n, int64_t* ipiv, lapack_complex_double* work, int64_t lwork ); +int64_t LAPACKE_skytrf_work_64( int matrix_layout, char uplo, int64_t n, + float* a, int64_t lda, int64_t* ipiv, + float* work, int64_t lwork ); +int64_t LAPACKE_dkytrf_work_64( int matrix_layout, char uplo, int64_t n, + double* a, int64_t lda, int64_t* ipiv, + double* work, int64_t lwork ); + int64_t LAPACKE_ssytri_work_64( int matrix_layout, char uplo, int64_t n, float* a, int64_t lda, const int64_t* ipiv, float* work ); @@ -9693,6 +9823,13 @@ int64_t LAPACKE_zsytri_work_64( int matrix_layout, char uplo, int64_t n, const int64_t* ipiv, lapack_complex_double* work ); +int64_t LAPACKE_skytri_work_64( int matrix_layout, char uplo, int64_t n, + float* a, int64_t lda, + const int64_t* ipiv, float* work ); +int64_t LAPACKE_dkytri_work_64( int matrix_layout, char uplo, int64_t n, + double* a, int64_t lda, + const int64_t* ipiv, double* work ); + int64_t LAPACKE_ssytrs_work_64( int matrix_layout, char uplo, int64_t n, int64_t nrhs, const float* a, int64_t lda, const int64_t* ipiv, float* b, @@ -9710,6 +9847,15 @@ int64_t LAPACKE_zsytrs_work_64( int matrix_layout, char uplo, int64_t n, int64_t lda, const int64_t* ipiv, lapack_complex_double* b, int64_t ldb ); +int64_t LAPACKE_skytrs_work_64( int matrix_layout, char uplo, int64_t n, + int64_t nrhs, const float* a, int64_t lda, + const int64_t* ipiv, float* b, + int64_t ldb ); +int64_t LAPACKE_dkytrs_work_64( int matrix_layout, char uplo, int64_t n, + int64_t nrhs, const double* a, + int64_t lda, const int64_t* ipiv, + double* b, int64_t ldb ); + int64_t LAPACKE_stbcon_work_64( int matrix_layout, char norm, char uplo, char diag, int64_t n, int64_t kd, const float* ab, int64_t ldab, float* rcond, @@ -10913,18 +11059,35 @@ int64_t LAPACKE_dsyconv_64( int matrix_layout, char uplo, char way, int64_t n, int64_t LAPACKE_dsyconv_work_64( int matrix_layout, char uplo, char way, int64_t n, double* a, int64_t lda, const int64_t* ipiv, double* e ); +int64_t LAPACKE_dkyconv_64( int matrix_layout, char uplo, char way, int64_t n, + double* a, int64_t lda, const int64_t* ipiv, double* e); +int64_t LAPACKE_dkyconv_work_64( int matrix_layout, char uplo, char way, + int64_t n, double* a, int64_t lda, + const int64_t* ipiv, double* e ); int64_t LAPACKE_dsyswapr_64( int matrix_layout, char uplo, int64_t n, double* a, int64_t lda, int64_t i1, int64_t i2 ); int64_t LAPACKE_dsyswapr_work_64( int matrix_layout, char uplo, int64_t n, double* a, int64_t lda, int64_t i1, int64_t i2 ); +int64_t LAPACKE_dkyswapr_64( int matrix_layout, char uplo, int64_t n, + double* a, int64_t lda, int64_t i1, + int64_t i2 ); +int64_t LAPACKE_dkyswapr_work_64( int matrix_layout, char uplo, int64_t n, + double* a, int64_t lda, int64_t i1, + int64_t i2 ); int64_t LAPACKE_dsytri2_64( int matrix_layout, char uplo, int64_t n, double* a, int64_t lda, const int64_t* ipiv ); int64_t LAPACKE_dsytri2_work_64( int matrix_layout, char uplo, int64_t n, double* a, int64_t lda, const int64_t* ipiv, double* work, int64_t lwork ); +int64_t LAPACKE_dkytri2_64( int matrix_layout, char uplo, int64_t n, + double* a, int64_t lda, const int64_t* ipiv ); +int64_t LAPACKE_dkytri2_work_64( int matrix_layout, char uplo, int64_t n, + double* a, int64_t lda, + const int64_t* ipiv, + double* work, int64_t lwork ); int64_t LAPACKE_dsytri2x_64( int matrix_layout, char uplo, int64_t n, double* a, int64_t lda, const int64_t* ipiv, int64_t nb ); @@ -10932,6 +11095,13 @@ int64_t LAPACKE_dsytri2x_work_64( int matrix_layout, char uplo, int64_t n, double* a, int64_t lda, const int64_t* ipiv, double* work, int64_t nb ); +int64_t LAPACKE_dkytri2x_64( int matrix_layout, char uplo, int64_t n, + double* a, int64_t lda, const int64_t* ipiv, + int64_t nb ); +int64_t LAPACKE_dkytri2x_work_64( int matrix_layout, char uplo, int64_t n, + double* a, int64_t lda, + const int64_t* ipiv, double* work, + int64_t nb ); int64_t LAPACKE_dsytrs2_64( int matrix_layout, char uplo, int64_t n, int64_t nrhs, const double* a, int64_t lda, const int64_t* ipiv, double* b, int64_t ldb ); @@ -10939,6 +11109,13 @@ int64_t LAPACKE_dsytrs2_work_64( int matrix_layout, char uplo, int64_t n, int64_t nrhs, const double* a, int64_t lda, const int64_t* ipiv, double* b, int64_t ldb, double* work ); +int64_t LAPACKE_dkytrs2_64( int matrix_layout, char uplo, int64_t n, + int64_t nrhs, const double* a, int64_t lda, + const int64_t* ipiv, double* b, int64_t ldb ); +int64_t LAPACKE_dkytrs2_work_64( int matrix_layout, char uplo, int64_t n, + int64_t nrhs, const double* a, + int64_t lda, const int64_t* ipiv, + double* b, int64_t ldb, double* work ); int64_t LAPACKE_sbbcsd_64( int matrix_layout, char jobu1, char jobu2, char jobv1t, char jobv2t, char trans, int64_t m, int64_t p, int64_t q, float* theta, float* phi, @@ -11008,18 +11185,35 @@ int64_t LAPACKE_ssyconv_64( int matrix_layout, char uplo, char way, int64_t n, int64_t LAPACKE_ssyconv_work_64( int matrix_layout, char uplo, char way, int64_t n, float* a, int64_t lda, const int64_t* ipiv, float* e ); +int64_t LAPACKE_skyconv_64( int matrix_layout, char uplo, char way, int64_t n, + float* a, int64_t lda, const int64_t* ipiv, float* e ); +int64_t LAPACKE_skyconv_work_64( int matrix_layout, char uplo, char way, + int64_t n, float* a, int64_t lda, + const int64_t* ipiv, float* e ); int64_t LAPACKE_ssyswapr_64( int matrix_layout, char uplo, int64_t n, float* a, int64_t lda, int64_t i1, int64_t i2 ); int64_t LAPACKE_ssyswapr_work_64( int matrix_layout, char uplo, int64_t n, float* a, int64_t lda, int64_t i1, int64_t i2 ); +int64_t LAPACKE_skyswapr_64( int matrix_layout, char uplo, int64_t n, + float* a, int64_t lda, int64_t i1, + int64_t i2 ); +int64_t LAPACKE_skyswapr_work_64( int matrix_layout, char uplo, int64_t n, + float* a, int64_t lda, int64_t i1, + int64_t i2 ); int64_t LAPACKE_ssytri2_64( int matrix_layout, char uplo, int64_t n, float* a, int64_t lda, const int64_t* ipiv ); int64_t LAPACKE_ssytri2_work_64( int matrix_layout, char uplo, int64_t n, float* a, int64_t lda, const int64_t* ipiv, float* work, int64_t lwork ); +int64_t LAPACKE_skytri2_64( int matrix_layout, char uplo, int64_t n, float* a, + int64_t lda, const int64_t* ipiv ); +int64_t LAPACKE_skytri2_work_64( int matrix_layout, char uplo, int64_t n, + float* a, int64_t lda, + const int64_t* ipiv, + float* work, int64_t lwork ); int64_t LAPACKE_ssytri2x_64( int matrix_layout, char uplo, int64_t n, float* a, int64_t lda, const int64_t* ipiv, int64_t nb ); @@ -11027,6 +11221,13 @@ int64_t LAPACKE_ssytri2x_work_64( int matrix_layout, char uplo, int64_t n, float* a, int64_t lda, const int64_t* ipiv, float* work, int64_t nb ); +int64_t LAPACKE_skytri2x_64( int matrix_layout, char uplo, int64_t n, + float* a, int64_t lda, const int64_t* ipiv, + int64_t nb ); +int64_t LAPACKE_skytri2x_work_64( int matrix_layout, char uplo, int64_t n, + float* a, int64_t lda, + const int64_t* ipiv, float* work, + int64_t nb ); int64_t LAPACKE_ssytrs2_64( int matrix_layout, char uplo, int64_t n, int64_t nrhs, const float* a, int64_t lda, const int64_t* ipiv, float* b, int64_t ldb ); @@ -11034,6 +11235,13 @@ int64_t LAPACKE_ssytrs2_work_64( int matrix_layout, char uplo, int64_t n, int64_t nrhs, const float* a, int64_t lda, const int64_t* ipiv, float* b, int64_t ldb, float* work ); +int64_t LAPACKE_skytrs2_64( int matrix_layout, char uplo, int64_t n, + int64_t nrhs, const float* a, int64_t lda, + const int64_t* ipiv, float* b, int64_t ldb ); +int64_t LAPACKE_skytrs2_work_64( int matrix_layout, char uplo, int64_t n, + int64_t nrhs, const float* a, + int64_t lda, const int64_t* ipiv, + float* b, int64_t ldb, float* work ); int64_t LAPACKE_zbbcsd_64( int matrix_layout, char jobu1, char jobu2, char jobv1t, char jobv2t, char trans, int64_t m, int64_t p, int64_t q, double* theta, diff --git a/LAPACKE/include/lapacke_utils.h b/LAPACKE/include/lapacke_utils.h index 0b9d9a1f4..7864adedf 100644 --- a/LAPACKE/include/lapacke_utils.h +++ b/LAPACKE/include/lapacke_utils.h @@ -169,6 +169,9 @@ void API_SUFFIX(LAPACKE_dsp_trans)( int matrix_layout, char uplo, lapack_int n, void API_SUFFIX(LAPACKE_dsy_trans)( int matrix_layout, char uplo, lapack_int n, const double *in, lapack_int ldin, double *out, lapack_int ldout ); +void API_SUFFIX(LAPACKE_dky_trans)( int matrix_layout, char uplo, lapack_int n, + const double *in, lapack_int ldin, + double *out, lapack_int ldout ); void API_SUFFIX(LAPACKE_dtb_trans)( int matrix_layout, char uplo, char diag, lapack_int n, lapack_int kd, const double *in, lapack_int ldin, @@ -223,6 +226,9 @@ void API_SUFFIX(LAPACKE_ssp_trans)( int matrix_layout, char uplo, lapack_int n, void API_SUFFIX(LAPACKE_ssy_trans)( int matrix_layout, char uplo, lapack_int n, const float *in, lapack_int ldin, float *out, lapack_int ldout ); +void API_SUFFIX(LAPACKE_sky_trans)( int matrix_layout, char uplo, lapack_int n, + const float *in, lapack_int ldin, + float *out, lapack_int ldout ); void API_SUFFIX(LAPACKE_stb_trans)( int matrix_layout, char uplo, char diag, lapack_int n, lapack_int kd, const float *in, lapack_int ldin, @@ -441,10 +447,17 @@ lapack_logical API_SUFFIX(LAPACKE_dsp_nancheck)( lapack_int n, lapack_logical API_SUFFIX(LAPACKE_dst_nancheck)( lapack_int n, const double *d, const double *e ); +lapack_logical API_SUFFIX(LAPACKE_dkt_nancheck)( lapack_int n, + const double *d, + const double *e ); lapack_logical API_SUFFIX(LAPACKE_dsy_nancheck)( int matrix_layout, char uplo, lapack_int n, const double *a, lapack_int lda ); +lapack_logical API_SUFFIX(LAPACKE_dky_nancheck)( int matrix_layout, char uplo, + lapack_int n, + const double *a, + lapack_int lda ); lapack_logical API_SUFFIX(LAPACKE_dtb_nancheck)( int matrix_layout, char uplo, char diag, lapack_int n, lapack_int kd, const double* ab, @@ -508,10 +521,17 @@ lapack_logical API_SUFFIX(LAPACKE_ssp_nancheck)( lapack_int n, lapack_logical API_SUFFIX(LAPACKE_sst_nancheck)( lapack_int n, const float *d, const float *e ); +lapack_logical API_SUFFIX(LAPACKE_skt_nancheck)( lapack_int n, + const float *d, + const float *e ); lapack_logical API_SUFFIX(LAPACKE_ssy_nancheck)( int matrix_layout, char uplo, lapack_int n, const float *a, lapack_int lda ); +lapack_logical API_SUFFIX(LAPACKE_sky_nancheck)( int matrix_layout, char uplo, + lapack_int n, + const float *a, + lapack_int lda ); lapack_logical API_SUFFIX(LAPACKE_stb_nancheck)( int matrix_layout, char uplo, char diag, lapack_int n, lapack_int kd, const float* ab, diff --git a/LAPACKE/src/CMakeLists.txt b/LAPACKE/src/CMakeLists.txt index eebc5f869..d585d8b2e 100644 --- a/LAPACKE/src/CMakeLists.txt +++ b/LAPACKE/src/CMakeLists.txt @@ -811,6 +811,8 @@ lapacke_dlange.c lapacke_dlange_work.c lapacke_dlansy.c lapacke_dlansy_work.c +lapacke_dlanky.c +lapacke_dlanky_work.c lapacke_dlantr.c lapacke_dlantr_work.c lapacke_dlapmr.c @@ -1035,10 +1037,14 @@ lapacke_dstemr.c lapacke_dstemr_work.c lapacke_dsteqr.c lapacke_dsteqr_work.c +lapacke_dkteqr.c +lapacke_dkteqr_work.c lapacke_dsterf.c lapacke_dsterf_work.c lapacke_dstev.c lapacke_dstev_work.c +lapacke_dktev.c +lapacke_dktev_work.c lapacke_dstevd.c lapacke_dstevd_work.c lapacke_dstevr.c @@ -1051,10 +1057,14 @@ lapacke_dsycon_3.c lapacke_dsycon_3_work.c lapacke_dsyconv.c lapacke_dsyconv_work.c +lapacke_dkyconv.c +lapacke_dkyconv_work.c lapacke_dsyequb.c lapacke_dsyequb_work.c lapacke_dsyev.c lapacke_dsyev_work.c +lapacke_dkyev.c +lapacke_dkyev_work.c lapacke_dsyev_2stage.c lapacke_dsyev_2stage_work.c lapacke_dsyevd.c @@ -1071,8 +1081,12 @@ lapacke_dsyevx_2stage.c lapacke_dsyevx_2stage_work.c lapacke_dsygst.c lapacke_dsygst_work.c +lapacke_dkygst.c +lapacke_dkygst_work.c lapacke_dsygv.c lapacke_dsygv_work.c +lapacke_dkygv.c +lapacke_dkygv_work.c lapacke_dsygv_2stage.c lapacke_dsygv_2stage_work.c lapacke_dsygvd.c @@ -1083,6 +1097,8 @@ lapacke_dsyrfs.c lapacke_dsyrfs_work.c lapacke_dsysv.c lapacke_dsysv_work.c +lapacke_dkysv.c +lapacke_dkysv_work.c lapacke_dsysv_aa.c lapacke_dsysv_aa_work.c lapacke_dsysv_aa_2stage.c @@ -1095,10 +1111,16 @@ lapacke_dsysvx.c lapacke_dsysvx_work.c lapacke_dsyswapr.c lapacke_dsyswapr_work.c +lapacke_dkyswapr.c +lapacke_dkyswapr_work.c lapacke_dsytrd.c lapacke_dsytrd_work.c +lapacke_dkytrd.c +lapacke_dkytrd_work.c lapacke_dsytrf.c lapacke_dsytrf_work.c +lapacke_dkytrf.c +lapacke_dkytrf_work.c lapacke_dsytrf_aa.c lapacke_dsytrf_aa_work.c lapacke_dsytrf_aa_2stage.c @@ -1109,16 +1131,26 @@ lapacke_dsytrf_rook.c lapacke_dsytrf_rook_work.c lapacke_dsytri.c lapacke_dsytri_work.c +lapacke_dkytri.c +lapacke_dkytri_work.c lapacke_dsytri2.c lapacke_dsytri2_work.c +lapacke_dkytri2.c +lapacke_dkytri2_work.c lapacke_dsytri2x.c lapacke_dsytri2x_work.c +lapacke_dkytri2x.c +lapacke_dkytri2x_work.c lapacke_dsytri_3.c lapacke_dsytri_3_work.c lapacke_dsytrs.c lapacke_dsytrs_work.c +lapacke_dkytrs.c +lapacke_dkytrs_work.c lapacke_dsytrs2.c lapacke_dsytrs2_work.c +lapacke_dkytrs2.c +lapacke_dkytrs2_work.c lapacke_dsytrs_3.c lapacke_dsytrs_3_work.c lapacke_dsytrs_aa.c @@ -1396,6 +1428,8 @@ lapacke_slange.c lapacke_slange_work.c lapacke_slansy.c lapacke_slansy_work.c +lapacke_slanky.c +lapacke_slanky_work.c lapacke_slantr.c lapacke_slantr_work.c lapacke_slapmr.c @@ -1616,10 +1650,14 @@ lapacke_sstemr.c lapacke_sstemr_work.c lapacke_ssteqr.c lapacke_ssteqr_work.c +lapacke_skteqr.c +lapacke_skteqr_work.c lapacke_ssterf.c lapacke_ssterf_work.c lapacke_sstev.c lapacke_sstev_work.c +lapacke_sktev.c +lapacke_sktev_work.c lapacke_sstevd.c lapacke_sstevd_work.c lapacke_sstevr.c @@ -1632,10 +1670,14 @@ lapacke_ssycon_3.c lapacke_ssycon_3_work.c lapacke_ssyconv.c lapacke_ssyconv_work.c +lapacke_skyconv.c +lapacke_skyconv_work.c lapacke_ssyequb.c lapacke_ssyequb_work.c lapacke_ssyev.c lapacke_ssyev_work.c +lapacke_skyev.c +lapacke_skyev_work.c lapacke_ssyev_2stage.c lapacke_ssyev_2stage_work.c lapacke_ssyevd.c @@ -1652,8 +1694,12 @@ lapacke_ssyevx_2stage.c lapacke_ssyevx_2stage_work.c lapacke_ssygst.c lapacke_ssygst_work.c +lapacke_skygst.c +lapacke_skygst_work.c lapacke_ssygv.c lapacke_ssygv_work.c +lapacke_skygv.c +lapacke_skygv_work.c lapacke_ssygv_2stage.c lapacke_ssygv_2stage_work.c lapacke_ssygvd.c @@ -1664,6 +1710,8 @@ lapacke_ssyrfs.c lapacke_ssyrfs_work.c lapacke_ssysv.c lapacke_ssysv_work.c +lapacke_skysv.c +lapacke_skysv_work.c lapacke_ssysv_aa.c lapacke_ssysv_aa_work.c lapacke_ssysv_aa_2stage.c @@ -1676,10 +1724,16 @@ lapacke_ssysvx.c lapacke_ssysvx_work.c lapacke_ssyswapr.c lapacke_ssyswapr_work.c +lapacke_skyswapr.c +lapacke_skyswapr_work.c lapacke_ssytrd.c lapacke_ssytrd_work.c +lapacke_skytrd.c +lapacke_skytrd_work.c lapacke_ssytrf.c lapacke_ssytrf_work.c +lapacke_skytrf.c +lapacke_skytrf_work.c lapacke_ssytrf_aa.c lapacke_ssytrf_aa_work.c lapacke_ssytrf_aa_2stage.c @@ -1690,16 +1744,26 @@ lapacke_ssytrf_rook.c lapacke_ssytrf_rook_work.c lapacke_ssytri.c lapacke_ssytri_work.c +lapacke_skytri.c +lapacke_skytri_work.c lapacke_ssytri2.c lapacke_ssytri2_work.c +lapacke_skytri2.c +lapacke_skytri2_work.c lapacke_ssytri2x.c lapacke_ssytri2x_work.c +lapacke_skytri2x.c +lapacke_skytri2x_work.c lapacke_ssytri_3.c lapacke_ssytri_3_work.c lapacke_ssytrs.c lapacke_ssytrs_work.c +lapacke_skytrs.c +lapacke_skytrs_work.c lapacke_ssytrs2.c lapacke_ssytrs2_work.c +lapacke_skytrs2.c +lapacke_skytrs2_work.c lapacke_ssytrs_3.c lapacke_ssytrs_3_work.c lapacke_ssytrs_aa.c diff --git a/LAPACKE/src/Makefile b/LAPACKE/src/Makefile index fece21af4..f2839f12c 100644 --- a/LAPACKE/src/Makefile +++ b/LAPACKE/src/Makefile @@ -858,6 +858,8 @@ lapacke_dlange.o \ lapacke_dlange_work.o \ lapacke_dlansy.o \ lapacke_dlansy_work.o \ +lapacke_dlanky.o \ +lapacke_dlanky_work.o \ lapacke_dlantr.o \ lapacke_dlantr_work.o \ lapacke_dlapmr.o \ @@ -1082,10 +1084,14 @@ lapacke_dstemr.o \ lapacke_dstemr_work.o \ lapacke_dsteqr.o \ lapacke_dsteqr_work.o \ +lapacke_dkteqr.o \ +lapacke_dkteqr_work.o \ lapacke_dsterf.o \ lapacke_dsterf_work.o \ lapacke_dstev.o \ lapacke_dstev_work.o \ +lapacke_dktev.o \ +lapacke_dktev_work.o \ lapacke_dstevd.o \ lapacke_dstevd_work.o \ lapacke_dstevr.o \ @@ -1098,10 +1104,14 @@ lapacke_dsycon_3.o \ lapacke_dsycon_3_work.o \ lapacke_dsyconv.o \ lapacke_dsyconv_work.o \ +lapacke_dkyconv.o \ +lapacke_dkyconv_work.o \ lapacke_dsyequb.o \ lapacke_dsyequb_work.o \ lapacke_dsyev.o \ lapacke_dsyev_work.o \ +lapacke_dkyev.o \ +lapacke_dkyev_work.o \ lapacke_dsyev_2stage.o \ lapacke_dsyev_2stage_work.o \ lapacke_dsyevd.o \ @@ -1118,8 +1128,12 @@ lapacke_dsyevx_2stage.o \ lapacke_dsyevx_2stage_work.o \ lapacke_dsygst.o \ lapacke_dsygst_work.o \ +lapacke_dkygst.o \ +lapacke_dkygst_work.o \ lapacke_dsygv.o \ lapacke_dsygv_work.o \ +lapacke_dkygv.o \ +lapacke_dkygv_work.o \ lapacke_dsygv_2stage.o \ lapacke_dsygv_2stage_work.o \ lapacke_dsygvd.o \ @@ -1130,6 +1144,8 @@ lapacke_dsyrfs.o \ lapacke_dsyrfs_work.o \ lapacke_dsysv.o \ lapacke_dsysv_work.o \ +lapacke_dkysv.o \ +lapacke_dkysv_work.o \ lapacke_dsysv_aa.o \ lapacke_dsysv_aa_work.o \ lapacke_dsysv_aa_2stage.o \ @@ -1142,10 +1158,16 @@ lapacke_dsysvx.o \ lapacke_dsysvx_work.o \ lapacke_dsyswapr.o \ lapacke_dsyswapr_work.o \ +lapacke_dkyswapr.o \ +lapacke_dkyswapr_work.o \ lapacke_dsytrd.o \ lapacke_dsytrd_work.o \ +lapacke_dkytrd.o \ +lapacke_dkytrd_work.o \ lapacke_dsytrf.o \ lapacke_dsytrf_work.o \ +lapacke_dkytrf.o \ +lapacke_dkytrf_work.o \ lapacke_dsytrf_aa.o \ lapacke_dsytrf_aa_work.o \ lapacke_dsytrf_aa_2stage.o \ @@ -1156,16 +1178,26 @@ lapacke_dsytrf_rook.o \ lapacke_dsytrf_rook_work.o \ lapacke_dsytri.o \ lapacke_dsytri_work.o \ +lapacke_dkytri.o \ +lapacke_dkytri_work.o \ lapacke_dsytri2.o \ lapacke_dsytri2_work.o \ +lapacke_dkytri2.o \ +lapacke_dkytri2_work.o \ lapacke_dsytri2x.o \ lapacke_dsytri2x_work.o \ +lapacke_dkytri2x.o \ +lapacke_dkytri2x_work.o \ lapacke_dsytri_3.o \ lapacke_dsytri_3_work.o \ lapacke_dsytrs.o \ lapacke_dsytrs_work.o \ +lapacke_dkytrs.o \ +lapacke_dkytrs_work.o \ lapacke_dsytrs2.o \ lapacke_dsytrs2_work.o \ +lapacke_dkytrs2.o \ +lapacke_dkytrs2_work.o \ lapacke_dsytrs_3.o \ lapacke_dsytrs_3_work.o \ lapacke_dsytrs_aa.o \ @@ -1438,6 +1470,8 @@ lapacke_slange.o \ lapacke_slange_work.o \ lapacke_slansy.o \ lapacke_slansy_work.o \ +lapacke_slanky.o \ +lapacke_slanky_work.o \ lapacke_slantr.o \ lapacke_slantr_work.o \ lapacke_slapmr.o \ @@ -1658,10 +1692,14 @@ lapacke_sstemr.o \ lapacke_sstemr_work.o \ lapacke_ssteqr.o \ lapacke_ssteqr_work.o \ +lapacke_skteqr.o \ +lapacke_skteqr_work.o \ lapacke_ssterf.o \ lapacke_ssterf_work.o \ lapacke_sstev.o \ lapacke_sstev_work.o \ +lapacke_sktev.o \ +lapacke_sktev_work.o \ lapacke_sstevd.o \ lapacke_sstevd_work.o \ lapacke_sstevr.o \ @@ -1674,10 +1712,14 @@ lapacke_ssycon_3.o \ lapacke_ssycon_3_work.o \ lapacke_ssyconv.o \ lapacke_ssyconv_work.o \ +lapacke_skyconv.o \ +lapacke_skyconv_work.o \ lapacke_ssyequb.o \ lapacke_ssyequb_work.o \ lapacke_ssyev.o \ lapacke_ssyev_work.o \ +lapacke_skyev.o \ +lapacke_skyev_work.o \ lapacke_ssyev_2stage.o \ lapacke_ssyev_2stage_work.o \ lapacke_ssyevd.o \ @@ -1694,8 +1736,12 @@ lapacke_ssyevx_2stage.o \ lapacke_ssyevx_2stage_work.o \ lapacke_ssygst.o \ lapacke_ssygst_work.o \ +lapacke_skygst.o \ +lapacke_skygst_work.o \ lapacke_ssygv.o \ lapacke_ssygv_work.o \ +lapacke_skygv.o \ +lapacke_skygv_work.o \ lapacke_ssygv_2stage.o \ lapacke_ssygv_2stage_work.o \ lapacke_ssygvd.o \ @@ -1706,6 +1752,8 @@ lapacke_ssyrfs.o \ lapacke_ssyrfs_work.o \ lapacke_ssysv.o \ lapacke_ssysv_work.o \ +lapacke_skysv.o \ +lapacke_skysv_work.o \ lapacke_ssysv_aa.o \ lapacke_ssysv_aa_work.o \ lapacke_ssysv_aa_2stage.o \ @@ -1718,10 +1766,16 @@ lapacke_ssysvx.o \ lapacke_ssysvx_work.o \ lapacke_ssyswapr.o \ lapacke_ssyswapr_work.o \ +lapacke_skyswapr.o \ +lapacke_skyswapr_work.o \ lapacke_ssytrd.o \ lapacke_ssytrd_work.o \ +lapacke_skytrd.o \ +lapacke_skytrd_work.o \ lapacke_ssytrf.o \ lapacke_ssytrf_work.o \ +lapacke_skytrf.o \ +lapacke_skytrf_work.o \ lapacke_ssytrf_aa.o \ lapacke_ssytrf_aa_work.o \ lapacke_ssytrf_aa_2stage.o \ @@ -1732,16 +1786,26 @@ lapacke_ssytrf_rook.o \ lapacke_ssytrf_rook_work.o \ lapacke_ssytri.o \ lapacke_ssytri_work.o \ +lapacke_skytri.o \ +lapacke_skytri_work.o \ lapacke_ssytri2.o \ lapacke_ssytri2_work.o \ +lapacke_skytri2.o \ +lapacke_skytri2_work.o \ lapacke_ssytri2x.o \ lapacke_ssytri2x_work.o \ +lapacke_skytri2x.o \ +lapacke_skytri2x_work.o \ lapacke_ssytri_3.o \ lapacke_ssytri_3_work.o \ lapacke_ssytrs.o \ lapacke_ssytrs_work.o \ +lapacke_skytrs.o \ +lapacke_skytrs_work.o \ lapacke_ssytrs2.o \ lapacke_ssytrs2_work.o \ +lapacke_skytrs2.o \ +lapacke_skytrs2_work.o \ lapacke_ssytrs_3.o \ lapacke_ssytrs_3_work.o \ lapacke_ssytrs_aa.o \ diff --git a/LAPACKE/src/lapacke_dkteqr.c b/LAPACKE/src/lapacke_dkteqr.c new file mode 100644 index 000000000..0a680e78b --- /dev/null +++ b/LAPACKE/src/lapacke_dkteqr.c @@ -0,0 +1,80 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dkteqr +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkteqr)( int matrix_layout, char compz, lapack_int n, + double* e, double* z, lapack_int ldz ) +{ + lapack_int info = 0; + /* Additional scalars declarations for work arrays */ + lapack_int lwork; + double* work = NULL; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkteqr", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_d_nancheck)( n-1, e, 1 ) ) { + return -4; + } + if( API_SUFFIX(LAPACKE_lsame)( compz, 'v' ) ) { + if( API_SUFFIX(LAPACKE_dge_nancheck)( matrix_layout, n, n, z, ldz ) ) { + return -5; + } + } + } +#endif + /* Additional scalars initializations for work arrays */ + if( API_SUFFIX(LAPACKE_lsame)( compz, 'n' ) ) { + lwork = 1; + } else { + lwork = MAX(1,2*n-2); + } + /* Allocate memory for working array(s) */ + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_dkteqr_work)( matrix_layout, compz, n, e, z, ldz, work ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkteqr", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dkteqr_work.c b/LAPACKE/src/lapacke_dkteqr_work.c new file mode 100644 index 000000000..bfdf743e1 --- /dev/null +++ b/LAPACKE/src/lapacke_dkteqr_work.c @@ -0,0 +1,89 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dkteqr +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkteqr_work)( int matrix_layout, char compz, lapack_int n, + double* e, double* z, lapack_int ldz, + double* work ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dkteqr( &compz, &n, e, z, &ldz, work, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ldz_t = MAX(1,n); + double* z_t = NULL; + /* Check leading dimension(s) */ + if( ldz < n ) { + info = -7; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkteqr_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + if( API_SUFFIX(LAPACKE_lsame)( compz, 'i' ) || API_SUFFIX(LAPACKE_lsame)( compz, 'v' ) ) { + z_t = (double*)LAPACKE_malloc( sizeof(double) * ldz_t * MAX(1,n) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + } + /* Transpose input matrices */ + if( API_SUFFIX(LAPACKE_lsame)( compz, 'v' ) ) { + API_SUFFIX(LAPACKE_dge_trans)( matrix_layout, n, n, z, ldz, z_t, ldz_t ); + } + /* Call LAPACK function and adjust info */ + LAPACK_dkteqr( &compz, &n, e, z_t, &ldz_t, work, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + if( API_SUFFIX(LAPACKE_lsame)( compz, 'i' ) || API_SUFFIX(LAPACKE_lsame)( compz, 'v' ) ) { + API_SUFFIX(LAPACKE_dge_trans)( LAPACK_COL_MAJOR, n, n, z_t, ldz_t, z, ldz ); + } + /* Release memory and exit */ + if( API_SUFFIX(LAPACKE_lsame)( compz, 'i' ) || API_SUFFIX(LAPACKE_lsame)( compz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkteqr_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkteqr_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dktev.c b/LAPACKE/src/lapacke_dktev.c new file mode 100644 index 000000000..0d51211f8 --- /dev/null +++ b/LAPACKE/src/lapacke_dktev.c @@ -0,0 +1,74 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dktev +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dktev)( int matrix_layout, char jobz, lapack_int n, double* d, + double* e, double* z, lapack_int ldz ) +{ + lapack_int info = 0; + double* work = NULL; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dktev", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_d_nancheck)( n, d, 1 ) ) { + return -4; + } + if( API_SUFFIX(LAPACKE_d_nancheck)( n-1, e, 1 ) ) { + return -5; + } + } +#endif + /* Allocate memory for working array(s) */ + if( API_SUFFIX(LAPACKE_lsame)( jobz, 'v' ) ) { + work = (double*)LAPACKE_malloc( sizeof(double) * MAX(1,2*n-2) ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_dktev_work)( matrix_layout, jobz, n, d, e, z, ldz, work ); + /* Release memory and exit */ + if( API_SUFFIX(LAPACKE_lsame)( jobz, 'v' ) ) { + LAPACKE_free( work ); + } +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dktev", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dktev_work.c b/LAPACKE/src/lapacke_dktev_work.c new file mode 100644 index 000000000..cfda3f0e4 --- /dev/null +++ b/LAPACKE/src/lapacke_dktev_work.c @@ -0,0 +1,85 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dktev +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dktev_work)( int matrix_layout, char jobz, lapack_int n, + double* d, double* e, double* z, lapack_int ldz, + double* work ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dktev( &jobz, &n, d, e, z, &ldz, work, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ldz_t = MAX(1,n); + double* z_t = NULL; + /* Check leading dimension(s) */ + if( ldz < n ) { + info = -7; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dktev_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + if( API_SUFFIX(LAPACKE_lsame)( jobz, 'v' ) ) { + z_t = (double*)LAPACKE_malloc( sizeof(double) * ldz_t * MAX(1,n) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + } + /* Call LAPACK function and adjust info */ + LAPACK_dktev( &jobz, &n, d, e, z_t, &ldz_t, work, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + if( API_SUFFIX(LAPACKE_lsame)( jobz, 'v' ) ) { + API_SUFFIX(LAPACKE_dge_trans)( LAPACK_COL_MAJOR, n, n, z_t, ldz_t, z, ldz ); + } + /* Release memory and exit */ + if( API_SUFFIX(LAPACKE_lsame)( jobz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dktev_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dktev_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dkyconv.c b/LAPACKE/src/lapacke_dkyconv.c new file mode 100644 index 000000000..1700617d8 --- /dev/null +++ b/LAPACKE/src/lapacke_dkyconv.c @@ -0,0 +1,52 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dkyconv +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkyconv)( int matrix_layout, char uplo, char way, lapack_int n, + double* a, lapack_int lda, const lapack_int* ipiv, double* e ) +{ + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkyconv", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_dsy_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + } +#endif + /* Call middle-level interface */ + return API_SUFFIX(LAPACKE_dkyconv_work)( matrix_layout, uplo, way, n, a, lda, ipiv, e ); +} diff --git a/LAPACKE/src/lapacke_dkyconv_work.c b/LAPACKE/src/lapacke_dkyconv_work.c new file mode 100644 index 000000000..c429c9832 --- /dev/null +++ b/LAPACKE/src/lapacke_dkyconv_work.c @@ -0,0 +1,81 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dkyconv +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkyconv_work)( int matrix_layout, char uplo, char way, + lapack_int n, double* a, lapack_int lda, + const lapack_int* ipiv, double* e ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dkyconv( &uplo, &way, &n, a, &lda, ipiv, e, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,lda); + double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkyconv_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_dge_trans)( matrix_layout, lda, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dkyconv( &uplo, &way, &n, a_t, &lda_t, ipiv, e, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_dge_trans)( LAPACK_COL_MAJOR, lda, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkyconv_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkyconv_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dkyev.c b/LAPACKE/src/lapacke_dkyev.c new file mode 100644 index 000000000..c10ecda97 --- /dev/null +++ b/LAPACKE/src/lapacke_dkyev.c @@ -0,0 +1,77 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dkyev +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkyev)( int matrix_layout, char jobz, char uplo, lapack_int n, + double* a, lapack_int lda, double* w ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkyev", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_dky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + } +#endif + /* Query optimal working array(s) size */ + info = API_SUFFIX(LAPACKE_dkyev_work)( matrix_layout, jobz, uplo, n, a, lda, w, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_dkyev_work)( matrix_layout, jobz, uplo, n, a, lda, w, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkyev", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dkyev_work.c b/LAPACKE/src/lapacke_dkyev_work.c new file mode 100644 index 000000000..bbdfeaaad --- /dev/null +++ b/LAPACKE/src/lapacke_dkyev_work.c @@ -0,0 +1,90 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dkyev +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkyev_work)( int matrix_layout, char jobz, char uplo, + lapack_int n, double* a, lapack_int lda, + double* w, double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dkyev( &jobz, &uplo, &n, a, &lda, w, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkyev_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_dkyev( &jobz, &uplo, &n, a, &lda_t, w, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_dky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dkyev( &jobz, &uplo, &n, a_t, &lda_t, w, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + if ( jobz == 'V' || jobz == 'v' ) { + API_SUFFIX(LAPACKE_dge_trans)( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + } else { + API_SUFFIX(LAPACKE_dky_trans)( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + } + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkyev_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkyev_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dkygst.c b/LAPACKE/src/lapacke_dkygst.c new file mode 100644 index 000000000..1361f150c --- /dev/null +++ b/LAPACKE/src/lapacke_dkygst.c @@ -0,0 +1,55 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dkygst +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkygst)( int matrix_layout, lapack_int itype, char uplo, + lapack_int n, double* a, lapack_int lda, + const double* b, lapack_int ldb ) +{ + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkygst", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_dky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( API_SUFFIX(LAPACKE_dky_nancheck)( matrix_layout, uplo, n, b, ldb ) ) { + return -7; + } + } +#endif + return API_SUFFIX(LAPACKE_dkygst_work)( matrix_layout, itype, uplo, n, a, lda, b, ldb ); +} diff --git a/LAPACKE/src/lapacke_dkygst_work.c b/LAPACKE/src/lapacke_dkygst_work.c new file mode 100644 index 000000000..474a78b4f --- /dev/null +++ b/LAPACKE/src/lapacke_dkygst_work.c @@ -0,0 +1,96 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dkygst +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkygst_work)( int matrix_layout, lapack_int itype, char uplo, + lapack_int n, double* a, lapack_int lda, + const double* b, lapack_int ldb ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dkygst( &itype, &uplo, &n, a, &lda, b, &ldb, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + double* a_t = NULL; + double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkygst_work", info ); + return info; + } + if( ldb < n ) { + info = -8; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkygst_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (double*)LAPACKE_malloc( sizeof(double) * ldb_t * MAX(1,n) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_dky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + API_SUFFIX(LAPACKE_dge_trans)( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dkygst( &itype, &uplo, &n, a_t, &lda_t, b_t, &ldb_t, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_dky_trans)( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkygst_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkygst_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dkygv.c b/LAPACKE/src/lapacke_dkygv.c new file mode 100644 index 000000000..9cd21c4a1 --- /dev/null +++ b/LAPACKE/src/lapacke_dkygv.c @@ -0,0 +1,81 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dkygv +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkygv)( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, double* a, lapack_int lda, + double* b, lapack_int ldb, double* w ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkygv", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_dky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -6; + } + if( API_SUFFIX(LAPACKE_dky_nancheck)( matrix_layout, uplo, n, b, ldb ) ) { + return -8; + } + } +#endif + /* Query optimal working array(s) size */ + info = API_SUFFIX(LAPACKE_dkygv_work)( matrix_layout, itype, jobz, uplo, n, a, lda, b, + ldb, w, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_dkygv_work)( matrix_layout, itype, jobz, uplo, n, a, lda, b, + ldb, w, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkygv", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dkygv_work.c b/LAPACKE/src/lapacke_dkygv_work.c new file mode 100644 index 000000000..c602c774e --- /dev/null +++ b/LAPACKE/src/lapacke_dkygv_work.c @@ -0,0 +1,106 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dkygv +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkygv_work)( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, double* a, + lapack_int lda, double* b, lapack_int ldb, + double* w, double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dkygv( &itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + double* a_t = NULL; + double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -7; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkygv_work", info ); + return info; + } + if( ldb < n ) { + info = -9; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkygv_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_dkygv( &itype, &jobz, &uplo, &n, a, &lda_t, b, &ldb_t, w, + work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (double*)LAPACKE_malloc( sizeof(double) * ldb_t * MAX(1,n) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_dge_trans)( matrix_layout, n, n, a, lda, a_t, lda_t ); + API_SUFFIX(LAPACKE_dge_trans)( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dkygv( &itype, &jobz, &uplo, &n, a_t, &lda_t, b_t, &ldb_t, w, + work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_dge_trans)( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + API_SUFFIX(LAPACKE_dge_trans)( LAPACK_COL_MAJOR, n, n, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkygv_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkygv_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dkysv.c b/LAPACKE/src/lapacke_dkysv.c new file mode 100644 index 000000000..087a8db33 --- /dev/null +++ b/LAPACKE/src/lapacke_dkysv.c @@ -0,0 +1,81 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dkysv +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkysv)( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, double* a, lapack_int lda, + lapack_int* ipiv, double* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkysv", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_dky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( API_SUFFIX(LAPACKE_dge_nancheck)( matrix_layout, n, nrhs, b, ldb ) ) { + return -8; + } + } +#endif + /* Query optimal working array(s) size */ + info = API_SUFFIX(LAPACKE_dkysv_work)( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_dkysv_work)( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkysv", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dkysv_work.c b/LAPACKE/src/lapacke_dkysv_work.c new file mode 100644 index 000000000..e805c18a4 --- /dev/null +++ b/LAPACKE/src/lapacke_dkysv_work.c @@ -0,0 +1,106 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dkysv +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkysv_work)( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, double* a, lapack_int lda, + lapack_int* ipiv, double* b, lapack_int ldb, + double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dkysv( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + double* a_t = NULL; + double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkysv_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkysv_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_dkysv( &uplo, &n, &nrhs, a, &lda_t, ipiv, b, &ldb_t, work, + &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (double*)LAPACKE_malloc( sizeof(double) * ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_dky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + API_SUFFIX(LAPACKE_dge_trans)( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dkysv( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_dky_trans)( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + API_SUFFIX(LAPACKE_dge_trans)( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkysv_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkysv_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dkyswapr.c b/LAPACKE/src/lapacke_dkyswapr.c new file mode 100644 index 000000000..ea95da06b --- /dev/null +++ b/LAPACKE/src/lapacke_dkyswapr.c @@ -0,0 +1,51 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dkyswapr +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkyswapr)( int matrix_layout, char uplo, lapack_int n, + double* a, lapack_int lda, lapack_int i1, lapack_int i2 ) +{ + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkyswapr", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_dky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + } +#endif + return API_SUFFIX(LAPACKE_dkyswapr_work)( matrix_layout, uplo, n, a, lda, i1, i2 ); +} diff --git a/LAPACKE/src/lapacke_dkyswapr_work.c b/LAPACKE/src/lapacke_dkyswapr_work.c new file mode 100644 index 000000000..10694bd4f --- /dev/null +++ b/LAPACKE/src/lapacke_dkyswapr_work.c @@ -0,0 +1,73 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dkyswapr +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkyswapr_work)( int matrix_layout, char uplo, lapack_int n, + double* a, lapack_int lda, + lapack_int i1, lapack_int i2 ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dkyswapr( &uplo, &n, a, &lda, &i1, &i2 ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + double* a_t = NULL; + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_dky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dkyswapr( &uplo, &n, a_t, &lda_t, &i1, &i2 ); + info = 0; /* LAPACK call is ok! */ + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_dky_trans)( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkyswapr_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkyswapr_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dkytrd.c b/LAPACKE/src/lapacke_dkytrd.c new file mode 100644 index 000000000..c22292308 --- /dev/null +++ b/LAPACKE/src/lapacke_dkytrd.c @@ -0,0 +1,77 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dkytrd +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkytrd)( int matrix_layout, char uplo, lapack_int n, double* a, + lapack_int lda, double* e, double* tau ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytrd", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_dky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + } +#endif + /* Query optimal working array(s) size */ + info = API_SUFFIX(LAPACKE_dkytrd_work)( matrix_layout, uplo, n, a, lda, e, tau, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_dkytrd_work)( matrix_layout, uplo, n, a, lda, e, tau, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytrd", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dkytrd_work.c b/LAPACKE/src/lapacke_dkytrd_work.c new file mode 100644 index 000000000..c82f43bea --- /dev/null +++ b/LAPACKE/src/lapacke_dkytrd_work.c @@ -0,0 +1,87 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dkytrd +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkytrd_work)( int matrix_layout, char uplo, lapack_int n, + double* a, lapack_int lda, double* e, + double* tau, double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dkytrd( &uplo, &n, a, &lda, e, tau, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytrd_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_dkytrd( &uplo, &n, a, &lda_t, e, tau, work, &lwork, + &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_dky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dkytrd( &uplo, &n, a_t, &lda_t, e, tau, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_dky_trans)( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytrd_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytrd_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dkytrf.c b/LAPACKE/src/lapacke_dkytrf.c new file mode 100644 index 000000000..d7d2e186f --- /dev/null +++ b/LAPACKE/src/lapacke_dkytrf.c @@ -0,0 +1,77 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dkytrf +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkytrf)( int matrix_layout, char uplo, lapack_int n, double* a, + lapack_int lda, lapack_int* ipiv ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytrf", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_dky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + } +#endif + /* Query optimal working array(s) size */ + info = API_SUFFIX(LAPACKE_dkytrf_work)( matrix_layout, uplo, n, a, lda, ipiv, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_dkytrf_work)( matrix_layout, uplo, n, a, lda, ipiv, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytrf", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dkytrf_work.c b/LAPACKE/src/lapacke_dkytrf_work.c new file mode 100644 index 000000000..71c8e16f4 --- /dev/null +++ b/LAPACKE/src/lapacke_dkytrf_work.c @@ -0,0 +1,86 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dkytrf +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkytrf_work)( int matrix_layout, char uplo, lapack_int n, + double* a, lapack_int lda, lapack_int* ipiv, + double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dkytrf( &uplo, &n, a, &lda, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytrf_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_dkytrf( &uplo, &n, a, &lda_t, ipiv, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_dky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dkytrf( &uplo, &n, a_t, &lda_t, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_dky_trans)( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytrf_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytrf_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dkytri.c b/LAPACKE/src/lapacke_dkytri.c new file mode 100644 index 000000000..a06bbca4f --- /dev/null +++ b/LAPACKE/src/lapacke_dkytri.c @@ -0,0 +1,67 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dkytri +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkytri)( int matrix_layout, char uplo, lapack_int n, double* a, + lapack_int lda, const lapack_int* ipiv ) +{ + lapack_int info = 0; + double* work = NULL; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytri", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_dky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + } +#endif + /* Allocate memory for working array(s) */ + work = (double*)LAPACKE_malloc( sizeof(double) * MAX(1,2*n) ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_dkytri_work)( matrix_layout, uplo, n, a, lda, ipiv, work ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytri", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dkytri2.c b/LAPACKE/src/lapacke_dkytri2.c new file mode 100644 index 000000000..84aa9b15f --- /dev/null +++ b/LAPACKE/src/lapacke_dkytri2.c @@ -0,0 +1,78 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dkytri2 +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkytri2)( int matrix_layout, char uplo, lapack_int n, + double* a, lapack_int lda, const lapack_int* ipiv ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + double* work = NULL; + double work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytri2", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_dky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + } +#endif + /* Query optimal working array(s) size */ + info = API_SUFFIX(LAPACKE_dkytri2_work)( matrix_layout, uplo, n, a, lda, ipiv, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + work = (double*) + LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_dkytri2_work)( matrix_layout, uplo, n, a, lda, ipiv, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytri2", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dkytri2_work.c b/LAPACKE/src/lapacke_dkytri2_work.c new file mode 100644 index 000000000..8cbbef935 --- /dev/null +++ b/LAPACKE/src/lapacke_dkytri2_work.c @@ -0,0 +1,87 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dkytri2 +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkytri2_work)( int matrix_layout, char uplo, lapack_int n, + double* a, lapack_int lda, + const lapack_int* ipiv, + double* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dkytri2( &uplo, &n, a, &lda, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytri2_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_dkytri2( &uplo, &n, a, &lda_t, ipiv, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_dky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dkytri2( &uplo, &n, a_t, &lda_t, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_dky_trans)( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytri2_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytri2_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dkytri2x.c b/LAPACKE/src/lapacke_dkytri2x.c new file mode 100644 index 000000000..c4ea3b9ed --- /dev/null +++ b/LAPACKE/src/lapacke_dkytri2x.c @@ -0,0 +1,69 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dkytri2x +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkytri2x)( int matrix_layout, char uplo, lapack_int n, + double* a, lapack_int lda, const lapack_int* ipiv, + lapack_int nb ) +{ + lapack_int info = 0; + double* work = NULL; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytri2x", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_dky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + } +#endif + /* Allocate memory for working array(s) */ + work = (double*)LAPACKE_malloc( sizeof(double) * MAX(1,n+nb+1)*(+1) ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_dkytri2x_work)( matrix_layout, uplo, n, a, lda, ipiv, work, + nb ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytri2x", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dkytri2x_work.c b/LAPACKE/src/lapacke_dkytri2x_work.c new file mode 100644 index 000000000..9fc00df40 --- /dev/null +++ b/LAPACKE/src/lapacke_dkytri2x_work.c @@ -0,0 +1,82 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dkytri2x +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkytri2x_work)( int matrix_layout, char uplo, lapack_int n, + double* a, lapack_int lda, + const lapack_int* ipiv, double* work, + lapack_int nb ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dkytri2x( &uplo, &n, a, &lda, ipiv, work, &nb, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytri2x_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_dky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dkytri2x( &uplo, &n, a_t, &lda_t, ipiv, work, &nb, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_dky_trans)( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytri2x_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytri2x_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dkytri_work.c b/LAPACKE/src/lapacke_dkytri_work.c new file mode 100644 index 000000000..cfb526a4a --- /dev/null +++ b/LAPACKE/src/lapacke_dkytri_work.c @@ -0,0 +1,81 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dkytri +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkytri_work)( int matrix_layout, char uplo, lapack_int n, + double* a, lapack_int lda, + const lapack_int* ipiv, double* work ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dkytri( &uplo, &n, a, &lda, ipiv, work, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytri_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_dky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dkytri( &uplo, &n, a_t, &lda_t, ipiv, work, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_dky_trans)( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytri_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytri_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dkytrs.c b/LAPACKE/src/lapacke_dkytrs.c new file mode 100644 index 000000000..12cd8e52e --- /dev/null +++ b/LAPACKE/src/lapacke_dkytrs.c @@ -0,0 +1,56 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dkytrs +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkytrs)( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const double* a, lapack_int lda, + const lapack_int* ipiv, double* b, lapack_int ldb ) +{ + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytrs", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_dky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( API_SUFFIX(LAPACKE_dge_nancheck)( matrix_layout, n, nrhs, b, ldb ) ) { + return -8; + } + } +#endif + return API_SUFFIX(LAPACKE_dkytrs_work)( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb ); +} diff --git a/LAPACKE/src/lapacke_dkytrs2.c b/LAPACKE/src/lapacke_dkytrs2.c new file mode 100644 index 000000000..d377235a2 --- /dev/null +++ b/LAPACKE/src/lapacke_dkytrs2.c @@ -0,0 +1,72 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dkytrs2 +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkytrs2)( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const double* a, lapack_int lda, + const lapack_int* ipiv, double* b, lapack_int ldb ) +{ + lapack_int info = 0; + double* work = NULL; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytrs2", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_dky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( API_SUFFIX(LAPACKE_dge_nancheck)( matrix_layout, n, nrhs, b, ldb ) ) { + return -8; + } + } +#endif + /* Allocate memory for working array(s) */ + work = (double*)LAPACKE_malloc( sizeof(double) * MAX(1,n) ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_dkytrs2_work)( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, work ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytrs2", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dkytrs2_work.c b/LAPACKE/src/lapacke_dkytrs2_work.c new file mode 100644 index 000000000..b4afb8a08 --- /dev/null +++ b/LAPACKE/src/lapacke_dkytrs2_work.c @@ -0,0 +1,98 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dkytrs2 +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkytrs2_work)( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const double* a, + lapack_int lda, const lapack_int* ipiv, + double* b, lapack_int ldb, double* work ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dkytrs2( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + double* a_t = NULL; + double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytrs2_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytrs2_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (double*)LAPACKE_malloc( sizeof(double) * ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_dky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + API_SUFFIX(LAPACKE_dge_trans)( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dkytrs2( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t, work, + &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_dge_trans)( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytrs2_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytrs2_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dkytrs_work.c b/LAPACKE/src/lapacke_dkytrs_work.c new file mode 100644 index 000000000..0cbd7938e --- /dev/null +++ b/LAPACKE/src/lapacke_dkytrs_work.c @@ -0,0 +1,98 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dkytrs +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dkytrs_work)( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const double* a, + lapack_int lda, const lapack_int* ipiv, + double* b, lapack_int ldb ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dkytrs( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + double* a_t = NULL; + double* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytrs_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytrs_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (double*)LAPACKE_malloc( sizeof(double) * ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_dky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + API_SUFFIX(LAPACKE_dge_trans)( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_dkytrs( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t, + &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_dge_trans)( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytrs_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dkytrs_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_dlanky.c b/LAPACKE/src/lapacke_dlanky.c new file mode 100644 index 000000000..d514100f4 --- /dev/null +++ b/LAPACKE/src/lapacke_dlanky.c @@ -0,0 +1,74 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dlanky +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +double API_SUFFIX(LAPACKE_dlanky)( int matrix_layout, char norm, char uplo, lapack_int n, + const double* a, lapack_int lda ) +{ + lapack_int info = 0; + double res = 0.; + double* work = NULL; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dlanky", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_dky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + } +#endif + /* Allocate memory for working array(s) */ + if( API_SUFFIX(LAPACKE_lsame)( norm, 'i' ) || API_SUFFIX(LAPACKE_lsame)( norm, '1' ) || + API_SUFFIX(LAPACKE_lsame)( norm, 'O' ) ) { + work = (double*)LAPACKE_malloc( sizeof(double) * MAX(1,n) ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + } + /* Call middle-level interface */ + res = API_SUFFIX(LAPACKE_dlanky_work)( matrix_layout, norm, uplo, n, a, lda, work ); + /* Release memory and exit */ + if( API_SUFFIX(LAPACKE_lsame)( norm, 'i' ) || API_SUFFIX(LAPACKE_lsame)( norm, '1' ) || + API_SUFFIX(LAPACKE_lsame)( norm, 'O' ) ) { + LAPACKE_free( work ); + } +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dlanky", info ); + } + return res; +} diff --git a/LAPACKE/src/lapacke_dlanky_work.c b/LAPACKE/src/lapacke_dlanky_work.c new file mode 100644 index 000000000..7bd116c50 --- /dev/null +++ b/LAPACKE/src/lapacke_dlanky_work.c @@ -0,0 +1,78 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dlanky +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +double API_SUFFIX(LAPACKE_dlanky_work)( int matrix_layout, char norm, char uplo, + lapack_int n, const double* a, lapack_int lda, + double* work ) +{ + lapack_int info = 0; + double res = 0.; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + res = LAPACK_dlanky( &norm, &uplo, &n, a, &lda, work ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + double* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dlanky_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_dky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + res = LAPACK_dlanky( &norm, &uplo, &n, a_t, &lda_t, work ); + info = 0; /* LAPACK call is ok! */ + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dlanky_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dlanky_work", info ); + } + return res; +} diff --git a/LAPACKE/src/lapacke_skteqr.c b/LAPACKE/src/lapacke_skteqr.c new file mode 100644 index 000000000..ccc57ebd0 --- /dev/null +++ b/LAPACKE/src/lapacke_skteqr.c @@ -0,0 +1,80 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function skteqr +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skteqr)( int matrix_layout, char compz, lapack_int n, + float* e, float* z, lapack_int ldz ) +{ + lapack_int info = 0; + /* Additional scalars declarations for work arrays */ + lapack_int lwork; + float* work = NULL; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skteqr", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_s_nancheck)( n-1, e, 1 ) ) { + return -4; + } + if( API_SUFFIX(LAPACKE_lsame)( compz, 'v' ) ) { + if( API_SUFFIX(LAPACKE_sge_nancheck)( matrix_layout, n, n, z, ldz ) ) { + return -5; + } + } + } +#endif + /* Additional scalars initializations for work arrays */ + if( API_SUFFIX(LAPACKE_lsame)( compz, 'n' ) ) { + lwork = 1; + } else { + lwork = MAX(1,2*n-2); + } + /* Allocate memory for working array(s) */ + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_skteqr_work)( matrix_layout, compz, n, e, z, ldz, work ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skteqr", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_skteqr_work.c b/LAPACKE/src/lapacke_skteqr_work.c new file mode 100644 index 000000000..55c4dbf95 --- /dev/null +++ b/LAPACKE/src/lapacke_skteqr_work.c @@ -0,0 +1,89 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function skteqr +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skteqr_work)( int matrix_layout, char compz, lapack_int n, + float* e, float* z, lapack_int ldz, + float* work ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_skteqr( &compz, &n, e, z, &ldz, work, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ldz_t = MAX(1,n); + float* z_t = NULL; + /* Check leading dimension(s) */ + if( ldz < n ) { + info = -7; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skteqr_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + if( API_SUFFIX(LAPACKE_lsame)( compz, 'i' ) || API_SUFFIX(LAPACKE_lsame)( compz, 'v' ) ) { + z_t = (float*)LAPACKE_malloc( sizeof(float) * ldz_t * MAX(1,n) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + } + /* Transpose input matrices */ + if( API_SUFFIX(LAPACKE_lsame)( compz, 'v' ) ) { + API_SUFFIX(LAPACKE_sge_trans)( matrix_layout, n, n, z, ldz, z_t, ldz_t ); + } + /* Call LAPACK function and adjust info */ + LAPACK_skteqr( &compz, &n, e, z_t, &ldz_t, work, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + if( API_SUFFIX(LAPACKE_lsame)( compz, 'i' ) || API_SUFFIX(LAPACKE_lsame)( compz, 'v' ) ) { + API_SUFFIX(LAPACKE_sge_trans)( LAPACK_COL_MAJOR, n, n, z_t, ldz_t, z, ldz ); + } + /* Release memory and exit */ + if( API_SUFFIX(LAPACKE_lsame)( compz, 'i' ) || API_SUFFIX(LAPACKE_lsame)( compz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skteqr_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skteqr_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_sktev.c b/LAPACKE/src/lapacke_sktev.c new file mode 100644 index 000000000..aac69e052 --- /dev/null +++ b/LAPACKE/src/lapacke_sktev.c @@ -0,0 +1,74 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function sktev +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_sktev)( int matrix_layout, char jobz, lapack_int n, float* d, + float* e, float* z, lapack_int ldz ) +{ + lapack_int info = 0; + float* work = NULL; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_sktev", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_s_nancheck)( n, d, 1 ) ) { + return -4; + } + if( API_SUFFIX(LAPACKE_s_nancheck)( n-1, e, 1 ) ) { + return -5; + } + } +#endif + /* Allocate memory for working array(s) */ + if( API_SUFFIX(LAPACKE_lsame)( jobz, 'v' ) ) { + work = (float*)LAPACKE_malloc( sizeof(float) * MAX(1,2*n-2) ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_sktev_work)( matrix_layout, jobz, n, d, e, z, ldz, work ); + /* Release memory and exit */ + if( API_SUFFIX(LAPACKE_lsame)( jobz, 'v' ) ) { + LAPACKE_free( work ); + } +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_sktev", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_sktev_work.c b/LAPACKE/src/lapacke_sktev_work.c new file mode 100644 index 000000000..8b40a250f --- /dev/null +++ b/LAPACKE/src/lapacke_sktev_work.c @@ -0,0 +1,85 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function sktev +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_sktev_work)( int matrix_layout, char jobz, lapack_int n, + float* d, float* e, float* z, lapack_int ldz, + float* work ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_sktev( &jobz, &n, d, e, z, &ldz, work, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int ldz_t = MAX(1,n); + float* z_t = NULL; + /* Check leading dimension(s) */ + if( ldz < n ) { + info = -7; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_sktev_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + if( API_SUFFIX(LAPACKE_lsame)( jobz, 'v' ) ) { + z_t = (float*)LAPACKE_malloc( sizeof(float) * ldz_t * MAX(1,n) ); + if( z_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + } + /* Call LAPACK function and adjust info */ + LAPACK_sktev( &jobz, &n, d, e, z_t, &ldz_t, work, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + if( API_SUFFIX(LAPACKE_lsame)( jobz, 'v' ) ) { + API_SUFFIX(LAPACKE_sge_trans)( LAPACK_COL_MAJOR, n, n, z_t, ldz_t, z, ldz ); + } + /* Release memory and exit */ + if( API_SUFFIX(LAPACKE_lsame)( jobz, 'v' ) ) { + LAPACKE_free( z_t ); + } +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_sktev_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_sktev_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_skyconv.c b/LAPACKE/src/lapacke_skyconv.c new file mode 100644 index 000000000..da181531b --- /dev/null +++ b/LAPACKE/src/lapacke_skyconv.c @@ -0,0 +1,52 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function skyconv +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skyconv)( int matrix_layout, char uplo, char way, lapack_int n, + float* a, lapack_int lda, const lapack_int* ipiv, float* e ) +{ + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skyconv", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_ssy_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + } +#endif + /* Call middle-level interface */ + return API_SUFFIX(LAPACKE_skyconv_work)( matrix_layout, uplo, way, n, a, lda, ipiv, e ); +} diff --git a/LAPACKE/src/lapacke_skyconv_work.c b/LAPACKE/src/lapacke_skyconv_work.c new file mode 100644 index 000000000..77cf023b6 --- /dev/null +++ b/LAPACKE/src/lapacke_skyconv_work.c @@ -0,0 +1,81 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function skyconv +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skyconv_work)( int matrix_layout, char uplo, char way, + lapack_int n, float* a, lapack_int lda, + const lapack_int* ipiv, float* e ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_skyconv( &uplo, &way, &n, a, &lda, ipiv, e, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,lda); + float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skyconv_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_sge_trans)( matrix_layout, lda, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_skyconv( &uplo, &way, &n, a_t, &lda_t, ipiv, e, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_sge_trans)( LAPACK_COL_MAJOR, lda, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skyconv_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skyconv_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_skyev.c b/LAPACKE/src/lapacke_skyev.c new file mode 100644 index 000000000..751649d2a --- /dev/null +++ b/LAPACKE/src/lapacke_skyev.c @@ -0,0 +1,77 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function skyev +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skyev)( int matrix_layout, char jobz, char uplo, lapack_int n, + float* a, lapack_int lda, float* w ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skyev", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_sky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + } +#endif + /* Query optimal working array(s) size */ + info = API_SUFFIX(LAPACKE_skyev_work)( matrix_layout, jobz, uplo, n, a, lda, w, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_skyev_work)( matrix_layout, jobz, uplo, n, a, lda, w, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skyev", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_skyev_work.c b/LAPACKE/src/lapacke_skyev_work.c new file mode 100644 index 000000000..dd1e094cf --- /dev/null +++ b/LAPACKE/src/lapacke_skyev_work.c @@ -0,0 +1,90 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function skyev +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skyev_work)( int matrix_layout, char jobz, char uplo, + lapack_int n, float* a, lapack_int lda, float* w, + float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_skyev( &jobz, &uplo, &n, a, &lda, w, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skyev_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_skyev( &jobz, &uplo, &n, a, &lda_t, w, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_sky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_skyev( &jobz, &uplo, &n, a_t, &lda_t, w, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + if ( jobz == 'V' || jobz == 'v' ) { + API_SUFFIX(LAPACKE_sge_trans)( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + } else { + API_SUFFIX(LAPACKE_sky_trans)( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + } + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skyev_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skyev_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_skygst.c b/LAPACKE/src/lapacke_skygst.c new file mode 100644 index 000000000..df6a012fe --- /dev/null +++ b/LAPACKE/src/lapacke_skygst.c @@ -0,0 +1,55 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function skygst +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skygst)( int matrix_layout, lapack_int itype, char uplo, + lapack_int n, float* a, lapack_int lda, + const float* b, lapack_int ldb ) +{ + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skygst", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_sky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( API_SUFFIX(LAPACKE_sky_nancheck)( matrix_layout, uplo, n, b, ldb ) ) { + return -7; + } + } +#endif + return API_SUFFIX(LAPACKE_skygst_work)( matrix_layout, itype, uplo, n, a, lda, b, ldb ); +} diff --git a/LAPACKE/src/lapacke_skygst_work.c b/LAPACKE/src/lapacke_skygst_work.c new file mode 100644 index 000000000..1de0e599c --- /dev/null +++ b/LAPACKE/src/lapacke_skygst_work.c @@ -0,0 +1,96 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function skygst +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skygst_work)( int matrix_layout, lapack_int itype, char uplo, + lapack_int n, float* a, lapack_int lda, + const float* b, lapack_int ldb ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_skygst( &itype, &uplo, &n, a, &lda, b, &ldb, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + float* a_t = NULL; + float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skygst_work", info ); + return info; + } + if( ldb < n ) { + info = -8; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skygst_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (float*)LAPACKE_malloc( sizeof(float) * ldb_t * MAX(1,n) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_sky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + API_SUFFIX(LAPACKE_sge_trans)( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_skygst( &itype, &uplo, &n, a_t, &lda_t, b_t, &ldb_t, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_sky_trans)( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skygst_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skygst_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_skygv.c b/LAPACKE/src/lapacke_skygv.c new file mode 100644 index 000000000..8fc28c98e --- /dev/null +++ b/LAPACKE/src/lapacke_skygv.c @@ -0,0 +1,81 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function skygv +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skygv)( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, float* a, lapack_int lda, + float* b, lapack_int ldb, float* w ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skygv", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_sky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -6; + } + if( API_SUFFIX(LAPACKE_sky_nancheck)( matrix_layout, uplo, n, b, ldb ) ) { + return -8; + } + } +#endif + /* Query optimal working array(s) size */ + info = API_SUFFIX(LAPACKE_skygv_work)( matrix_layout, itype, jobz, uplo, n, a, lda, b, + ldb, w, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_skygv_work)( matrix_layout, itype, jobz, uplo, n, a, lda, b, + ldb, w, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skygv", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_skygv_work.c b/LAPACKE/src/lapacke_skygv_work.c new file mode 100644 index 000000000..740fd870c --- /dev/null +++ b/LAPACKE/src/lapacke_skygv_work.c @@ -0,0 +1,106 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function skygv +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skygv_work)( int matrix_layout, lapack_int itype, char jobz, + char uplo, lapack_int n, float* a, + lapack_int lda, float* b, lapack_int ldb, + float* w, float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_skygv( &itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + float* a_t = NULL; + float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -7; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skygv_work", info ); + return info; + } + if( ldb < n ) { + info = -9; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skygv_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_skygv( &itype, &jobz, &uplo, &n, a, &lda_t, b, &ldb_t, w, + work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (float*)LAPACKE_malloc( sizeof(float) * ldb_t * MAX(1,n) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_sge_trans)( matrix_layout, n, n, a, lda, a_t, lda_t ); + API_SUFFIX(LAPACKE_sge_trans)( matrix_layout, n, n, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_skygv( &itype, &jobz, &uplo, &n, a_t, &lda_t, b_t, &ldb_t, w, + work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_sge_trans)( LAPACK_COL_MAJOR, n, n, a_t, lda_t, a, lda ); + API_SUFFIX(LAPACKE_sge_trans)( LAPACK_COL_MAJOR, n, n, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skygv_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skygv_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_skysv.c b/LAPACKE/src/lapacke_skysv.c new file mode 100644 index 000000000..9902e64ce --- /dev/null +++ b/LAPACKE/src/lapacke_skysv.c @@ -0,0 +1,81 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function skysv +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skysv)( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, float* a, lapack_int lda, + lapack_int* ipiv, float* b, lapack_int ldb ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skysv", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_sky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( API_SUFFIX(LAPACKE_sge_nancheck)( matrix_layout, n, nrhs, b, ldb ) ) { + return -8; + } + } +#endif + /* Query optimal working array(s) size */ + info = API_SUFFIX(LAPACKE_skysv_work)( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_skysv_work)( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, work, lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skysv", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_skysv_work.c b/LAPACKE/src/lapacke_skysv_work.c new file mode 100644 index 000000000..e695e89ae --- /dev/null +++ b/LAPACKE/src/lapacke_skysv_work.c @@ -0,0 +1,106 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function skysv +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skysv_work)( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, float* a, lapack_int lda, + lapack_int* ipiv, float* b, lapack_int ldb, + float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_skysv( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, + &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + float* a_t = NULL; + float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skysv_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skysv_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_skysv( &uplo, &n, &nrhs, a, &lda_t, ipiv, b, &ldb_t, work, + &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (float*)LAPACKE_malloc( sizeof(float) * ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_sky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + API_SUFFIX(LAPACKE_sge_trans)( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_skysv( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t, work, + &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_sky_trans)( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + API_SUFFIX(LAPACKE_sge_trans)( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skysv_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skysv_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_skyswapr.c b/LAPACKE/src/lapacke_skyswapr.c new file mode 100644 index 000000000..572f6c676 --- /dev/null +++ b/LAPACKE/src/lapacke_skyswapr.c @@ -0,0 +1,51 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function skyswapr +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skyswapr)( int matrix_layout, char uplo, lapack_int n, + float* a, lapack_int lda, lapack_int i1, lapack_int i2 ) +{ + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skyswapr", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_sky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + } +#endif + return API_SUFFIX(LAPACKE_skyswapr_work)( matrix_layout, uplo, n, a, lda, i1, i2 ); +} diff --git a/LAPACKE/src/lapacke_skyswapr_work.c b/LAPACKE/src/lapacke_skyswapr_work.c new file mode 100644 index 000000000..093a79508 --- /dev/null +++ b/LAPACKE/src/lapacke_skyswapr_work.c @@ -0,0 +1,73 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function skyswapr +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skyswapr_work)( int matrix_layout, char uplo, lapack_int n, + float* a, lapack_int lda, + lapack_int i1, lapack_int i2 ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_skyswapr( &uplo, &n, a, &lda, &i1, &i2 ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + float* a_t = NULL; + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_sky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_skyswapr( &uplo, &n, a_t, &lda_t, &i1, &i2 ); + info = 0; /* LAPACK call is ok! */ + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_sky_trans)( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skyswapr_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skyswapr_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_skytrd.c b/LAPACKE/src/lapacke_skytrd.c new file mode 100644 index 000000000..fda45b894 --- /dev/null +++ b/LAPACKE/src/lapacke_skytrd.c @@ -0,0 +1,77 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function skytrd +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skytrd)( int matrix_layout, char uplo, lapack_int n, float* a, + lapack_int lda, float* e, float* tau ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytrd", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_sky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + } +#endif + /* Query optimal working array(s) size */ + info = API_SUFFIX(LAPACKE_skytrd_work)( matrix_layout, uplo, n, a, lda, e, tau, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_skytrd_work)( matrix_layout, uplo, n, a, lda, e, tau, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytrd", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_skytrd_work.c b/LAPACKE/src/lapacke_skytrd_work.c new file mode 100644 index 000000000..79283611b --- /dev/null +++ b/LAPACKE/src/lapacke_skytrd_work.c @@ -0,0 +1,87 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function skytrd +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skytrd_work)( int matrix_layout, char uplo, lapack_int n, + float* a, lapack_int lda, float* e, + float* tau, float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_skytrd( &uplo, &n, a, &lda, e, tau, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytrd_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_skytrd( &uplo, &n, a, &lda_t, e, tau, work, &lwork, + &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_sky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_skytrd( &uplo, &n, a_t, &lda_t, e, tau, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_sky_trans)( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytrd_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytrd_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_skytrf.c b/LAPACKE/src/lapacke_skytrf.c new file mode 100644 index 000000000..ec620dafb --- /dev/null +++ b/LAPACKE/src/lapacke_skytrf.c @@ -0,0 +1,77 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function skytrf +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skytrf)( int matrix_layout, char uplo, lapack_int n, float* a, + lapack_int lda, lapack_int* ipiv ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytrf", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_sky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + } +#endif + /* Query optimal working array(s) size */ + info = API_SUFFIX(LAPACKE_skytrf_work)( matrix_layout, uplo, n, a, lda, ipiv, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_skytrf_work)( matrix_layout, uplo, n, a, lda, ipiv, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytrf", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_skytrf_work.c b/LAPACKE/src/lapacke_skytrf_work.c new file mode 100644 index 000000000..76f4f2232 --- /dev/null +++ b/LAPACKE/src/lapacke_skytrf_work.c @@ -0,0 +1,86 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function skytrf +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skytrf_work)( int matrix_layout, char uplo, lapack_int n, + float* a, lapack_int lda, lapack_int* ipiv, + float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_skytrf( &uplo, &n, a, &lda, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytrf_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_skytrf( &uplo, &n, a, &lda_t, ipiv, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_sky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_skytrf( &uplo, &n, a_t, &lda_t, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_sky_trans)( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytrf_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytrf_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_skytri.c b/LAPACKE/src/lapacke_skytri.c new file mode 100644 index 000000000..b864e4f39 --- /dev/null +++ b/LAPACKE/src/lapacke_skytri.c @@ -0,0 +1,67 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function skytri +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skytri)( int matrix_layout, char uplo, lapack_int n, float* a, + lapack_int lda, const lapack_int* ipiv ) +{ + lapack_int info = 0; + float* work = NULL; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytri", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_sky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + } +#endif + /* Allocate memory for working array(s) */ + work = (float*)LAPACKE_malloc( sizeof(float) * MAX(1,2*n) ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_skytri_work)( matrix_layout, uplo, n, a, lda, ipiv, work ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytri", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_skytri2.c b/LAPACKE/src/lapacke_skytri2.c new file mode 100644 index 000000000..8192ae0ed --- /dev/null +++ b/LAPACKE/src/lapacke_skytri2.c @@ -0,0 +1,78 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function skytri2 +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skytri2)( int matrix_layout, char uplo, lapack_int n, float* a, + lapack_int lda, const lapack_int* ipiv ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + float* work = NULL; + float work_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytri2", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_sky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + } +#endif + /* Query optimal working array(s) size */ + info = API_SUFFIX(LAPACKE_skytri2_work)( matrix_layout, uplo, n, a, lda, ipiv, + &work_query, lwork ); + if( info != 0 ) { + goto exit_level_0; + } + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + work = (float*) + LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_skytri2_work)( matrix_layout, uplo, n, a, lda, ipiv, work, + lwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytri2", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_skytri2_work.c b/LAPACKE/src/lapacke_skytri2_work.c new file mode 100644 index 000000000..dc050dc06 --- /dev/null +++ b/LAPACKE/src/lapacke_skytri2_work.c @@ -0,0 +1,87 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function skytri2 +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skytri2_work)( int matrix_layout, char uplo, lapack_int n, + float* a, lapack_int lda, + const lapack_int* ipiv, + float* work, lapack_int lwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_skytri2( &uplo, &n, a, &lda, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytri2_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 ) { + LAPACK_skytri2( &uplo, &n, a, &lda_t, ipiv, work, &lwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_sky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_skytri2( &uplo, &n, a_t, &lda_t, ipiv, work, &lwork, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_sky_trans)( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytri2_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytri2_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_skytri2x.c b/LAPACKE/src/lapacke_skytri2x.c new file mode 100644 index 000000000..c9f438988 --- /dev/null +++ b/LAPACKE/src/lapacke_skytri2x.c @@ -0,0 +1,69 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function skytri2x +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skytri2x)( int matrix_layout, char uplo, lapack_int n, + float* a, lapack_int lda, const lapack_int* ipiv, + lapack_int nb ) +{ + lapack_int info = 0; + float* work = NULL; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytri2x", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_sky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -4; + } + } +#endif + /* Allocate memory for working array(s) */ + work = (float*)LAPACKE_malloc( sizeof(float) * MAX(1,n+nb+1)*(+1) ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_skytri2x_work)( matrix_layout, uplo, n, a, lda, ipiv, work, + nb ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytri2x", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_skytri2x_work.c b/LAPACKE/src/lapacke_skytri2x_work.c new file mode 100644 index 000000000..6adba4a5b --- /dev/null +++ b/LAPACKE/src/lapacke_skytri2x_work.c @@ -0,0 +1,82 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function skytri2x +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skytri2x_work)( int matrix_layout, char uplo, lapack_int n, + float* a, lapack_int lda, + const lapack_int* ipiv, float* work, + lapack_int nb ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_skytri2x( &uplo, &n, a, &lda, ipiv, work, &nb, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytri2x_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_sky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_skytri2x( &uplo, &n, a_t, &lda_t, ipiv, work, &nb, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_sky_trans)( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytri2x_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytri2x_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_skytri_work.c b/LAPACKE/src/lapacke_skytri_work.c new file mode 100644 index 000000000..e3359a6e0 --- /dev/null +++ b/LAPACKE/src/lapacke_skytri_work.c @@ -0,0 +1,81 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function skytri +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skytri_work)( int matrix_layout, char uplo, lapack_int n, + float* a, lapack_int lda, + const lapack_int* ipiv, float* work ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_skytri( &uplo, &n, a, &lda, ipiv, work, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -5; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytri_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_sky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + LAPACK_skytri( &uplo, &n, a_t, &lda_t, ipiv, work, &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_sky_trans)( LAPACK_COL_MAJOR, uplo, n, a_t, lda_t, a, lda ); + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytri_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytri_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_skytrs.c b/LAPACKE/src/lapacke_skytrs.c new file mode 100644 index 000000000..2bbdb480f --- /dev/null +++ b/LAPACKE/src/lapacke_skytrs.c @@ -0,0 +1,56 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function skytrs +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skytrs)( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const float* a, lapack_int lda, + const lapack_int* ipiv, float* b, lapack_int ldb ) +{ + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytrs", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_sky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( API_SUFFIX(LAPACKE_sge_nancheck)( matrix_layout, n, nrhs, b, ldb ) ) { + return -8; + } + } +#endif + return API_SUFFIX(LAPACKE_skytrs_work)( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb ); +} diff --git a/LAPACKE/src/lapacke_skytrs2.c b/LAPACKE/src/lapacke_skytrs2.c new file mode 100644 index 000000000..38be878c6 --- /dev/null +++ b/LAPACKE/src/lapacke_skytrs2.c @@ -0,0 +1,72 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function skytrs2 +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skytrs2)( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const float* a, lapack_int lda, + const lapack_int* ipiv, float* b, lapack_int ldb ) +{ + lapack_int info = 0; + float* work = NULL; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytrs2", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_sky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + if( API_SUFFIX(LAPACKE_sge_nancheck)( matrix_layout, n, nrhs, b, ldb ) ) { + return -8; + } + } +#endif + /* Allocate memory for working array(s) */ + work = (float*)LAPACKE_malloc( sizeof(float) * MAX(1,n) ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_skytrs2_work)( matrix_layout, uplo, n, nrhs, a, lda, ipiv, b, + ldb, work ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytrs2", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_skytrs2_work.c b/LAPACKE/src/lapacke_skytrs2_work.c new file mode 100644 index 000000000..f6335a0db --- /dev/null +++ b/LAPACKE/src/lapacke_skytrs2_work.c @@ -0,0 +1,98 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function skytrs2 +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skytrs2_work)( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const float* a, + lapack_int lda, const lapack_int* ipiv, + float* b, lapack_int ldb, float* work ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_skytrs2( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + float* a_t = NULL; + float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytrs2_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytrs2_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (float*)LAPACKE_malloc( sizeof(float) * ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_sky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + API_SUFFIX(LAPACKE_sge_trans)( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_skytrs2( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t, work, + &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_sge_trans)( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytrs2_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytrs2_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_skytrs_work.c b/LAPACKE/src/lapacke_skytrs_work.c new file mode 100644 index 000000000..dbd225fc3 --- /dev/null +++ b/LAPACKE/src/lapacke_skytrs_work.c @@ -0,0 +1,98 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function skytrs +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_skytrs_work)( int matrix_layout, char uplo, lapack_int n, + lapack_int nrhs, const float* a, lapack_int lda, + const lapack_int* ipiv, float* b, + lapack_int ldb ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_skytrs( &uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + lapack_int ldb_t = MAX(1,n); + float* a_t = NULL; + float* b_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytrs_work", info ); + return info; + } + if( ldb < nrhs ) { + info = -9; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytrs_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + b_t = (float*)LAPACKE_malloc( sizeof(float) * ldb_t * MAX(1,nrhs) ); + if( b_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_sky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + API_SUFFIX(LAPACKE_sge_trans)( matrix_layout, n, nrhs, b, ldb, b_t, ldb_t ); + /* Call LAPACK function and adjust info */ + LAPACK_skytrs( &uplo, &n, &nrhs, a_t, &lda_t, ipiv, b_t, &ldb_t, + &info ); + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + API_SUFFIX(LAPACKE_sge_trans)( LAPACK_COL_MAJOR, n, nrhs, b_t, ldb_t, b, ldb ); + /* Release memory and exit */ + LAPACKE_free( b_t ); +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytrs_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_skytrs_work", info ); + } + return info; +} diff --git a/LAPACKE/src/lapacke_slanky.c b/LAPACKE/src/lapacke_slanky.c new file mode 100644 index 000000000..e8ded69fd --- /dev/null +++ b/LAPACKE/src/lapacke_slanky.c @@ -0,0 +1,74 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function slanky +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +float API_SUFFIX(LAPACKE_slanky)( int matrix_layout, char norm, char uplo, lapack_int n, + const float* a, lapack_int lda ) +{ + lapack_int info = 0; + float res = 0.; + float* work = NULL; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_slanky", -1 ); + return -1; + } +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_sky_nancheck)( matrix_layout, uplo, n, a, lda ) ) { + return -5; + } + } +#endif + /* Allocate memory for working array(s) */ + if( API_SUFFIX(LAPACKE_lsame)( norm, 'i' ) || API_SUFFIX(LAPACKE_lsame)( norm, '1' ) || + API_SUFFIX(LAPACKE_lsame)( norm, 'O' ) ) { + work = (float*)LAPACKE_malloc( sizeof(float) * MAX(1,n) ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + } + /* Call middle-level interface */ + res = API_SUFFIX(LAPACKE_slanky_work)( matrix_layout, norm, uplo, n, a, lda, work ); + /* Release memory and exit */ + if( API_SUFFIX(LAPACKE_lsame)( norm, 'i' ) || API_SUFFIX(LAPACKE_lsame)( norm, '1' ) || + API_SUFFIX(LAPACKE_lsame)( norm, 'O' ) ) { + LAPACKE_free( work ); + } +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_slanky", info ); + } + return res; +} diff --git a/LAPACKE/src/lapacke_slanky_work.c b/LAPACKE/src/lapacke_slanky_work.c new file mode 100644 index 000000000..e785ded6a --- /dev/null +++ b/LAPACKE/src/lapacke_slanky_work.c @@ -0,0 +1,78 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function slanky +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +float API_SUFFIX(LAPACKE_slanky_work)( int matrix_layout, char norm, char uplo, + lapack_int n, const float* a, lapack_int lda, + float* work ) +{ + lapack_int info = 0; + float res = 0.; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + res = LAPACK_slanky( &norm, &uplo, &n, a, &lda, work ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_int lda_t = MAX(1,n); + float* a_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -6; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_slanky_work", info ); + return info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + /* Transpose input matrices */ + API_SUFFIX(LAPACKE_sky_trans)( matrix_layout, uplo, n, a, lda, a_t, lda_t ); + /* Call LAPACK function and adjust info */ + res = LAPACK_slanky( &norm, &uplo, &n, a_t, &lda_t, work ); + info = 0; /* LAPACK call is ok! */ + /* Release memory and exit */ + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_slanky_work", info ); + } + } else { + info = -1; + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_slanky_work", info ); + } + return res; +} diff --git a/LAPACKE/utils/CMakeLists.txt b/LAPACKE/utils/CMakeLists.txt index dfb9aa370..d07999b35 100644 --- a/LAPACKE/utils/CMakeLists.txt +++ b/LAPACKE/utils/CMakeLists.txt @@ -29,6 +29,9 @@ lapacke_csp_trans.c lapacke_dsp_trans.c lapacke_ssp_trans.c lapacke_cst_nancheck.c lapacke_dst_nancheck.c lapacke_sst_nancheck.c lapacke_zst_nancheck.c lapacke_csy_nancheck.c lapacke_dsy_nancheck.c lapacke_ssy_nancheck.c lapacke_zsy_nancheck.c lapacke_csy_trans.c lapacke_dsy_trans.c lapacke_ssy_trans.c lapacke_zsy_trans.c + lapacke_dkt_nancheck.c lapacke_skt_nancheck.c + lapacke_dky_nancheck.c lapacke_sky_nancheck.c + lapacke_dky_trans.c lapacke_sky_trans.c lapacke_ctb_nancheck.c lapacke_dtb_nancheck.c lapacke_stb_nancheck.c lapacke_ztb_nancheck.c lapacke_ctb_trans.c lapacke_dtb_trans.c lapacke_stb_trans.c lapacke_ztb_trans.c lapacke_ctf_nancheck.c lapacke_dtf_nancheck.c lapacke_stf_nancheck.c lapacke_ztf_nancheck.c diff --git a/LAPACKE/utils/Makefile b/LAPACKE/utils/Makefile index a1f863107..6716cf73f 100644 --- a/LAPACKE/utils/Makefile +++ b/LAPACKE/utils/Makefile @@ -104,6 +104,9 @@ OBJ = lapacke_cgb_nancheck.o \ lapacke_dst_nancheck.o \ lapacke_dsy_nancheck.o \ lapacke_dsy_trans.o \ + lapacke_dkt_nancheck.o \ + lapacke_dky_nancheck.o \ + lapacke_dky_trans.o \ lapacke_dtb_nancheck.o \ lapacke_dtb_trans.o \ lapacke_dtf_nancheck.o \ @@ -141,6 +144,9 @@ OBJ = lapacke_cgb_nancheck.o \ lapacke_sst_nancheck.o \ lapacke_ssy_nancheck.o \ lapacke_ssy_trans.o \ + lapacke_skt_nancheck.o \ + lapacke_sky_nancheck.o \ + lapacke_sky_trans.o \ lapacke_stb_nancheck.o \ lapacke_stb_trans.o \ lapacke_stf_nancheck.o \ diff --git a/LAPACKE/utils/lapacke_dkt_nancheck.c b/LAPACKE/utils/lapacke_dkt_nancheck.c new file mode 100644 index 000000000..77575e3e1 --- /dev/null +++ b/LAPACKE/utils/lapacke_dkt_nancheck.c @@ -0,0 +1,41 @@ +/***************************************************************************** + Copyright (c) 2010, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native C interface to LAPACK utility function +* Author: Intel Corporation +*****************************************************************************/ +#include "lapacke_utils.h" + +/* Check a matrix for NaN entries. */ + +lapack_logical API_SUFFIX(LAPACKE_dkt_nancheck)( lapack_int n, + const double *d, + const double *e ) +{ + return API_SUFFIX(LAPACKE_d_nancheck)( n-1, e, 1 ); +} diff --git a/LAPACKE/utils/lapacke_dky_nancheck.c b/LAPACKE/utils/lapacke_dky_nancheck.c new file mode 100644 index 000000000..7945abc4a --- /dev/null +++ b/LAPACKE/utils/lapacke_dky_nancheck.c @@ -0,0 +1,42 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native C interface to LAPACK utility function +* Author: Intel Corporation +*****************************************************************************/ +#include "lapacke_utils.h" + +/* Check a matrix for NaN entries. */ + +lapack_logical API_SUFFIX(LAPACKE_dky_nancheck)( int matrix_layout, char uplo, + lapack_int n, + const double *a, + lapack_int lda ) +{ + return API_SUFFIX(LAPACKE_dtr_nancheck)( matrix_layout, uplo, 'u', n, a, lda ); +} diff --git a/LAPACKE/utils/lapacke_dky_trans.c b/LAPACKE/utils/lapacke_dky_trans.c new file mode 100644 index 000000000..1572b8aba --- /dev/null +++ b/LAPACKE/utils/lapacke_dky_trans.c @@ -0,0 +1,44 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native C interface to LAPACK utility function +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +/* Converts input skew-symmetric matrix from row-major(C) to column-major(Fortran) + * layout or vice versa. + */ + +void API_SUFFIX(LAPACKE_dky_trans)( int matrix_layout, char uplo, lapack_int n, + const double *in, lapack_int ldin, + double *out, lapack_int ldout ) +{ + API_SUFFIX(LAPACKE_dtr_trans)( matrix_layout, uplo, 'u', n, in, ldin, out, ldout ); +} diff --git a/LAPACKE/utils/lapacke_skt_nancheck.c b/LAPACKE/utils/lapacke_skt_nancheck.c new file mode 100644 index 000000000..b374742b3 --- /dev/null +++ b/LAPACKE/utils/lapacke_skt_nancheck.c @@ -0,0 +1,41 @@ +/***************************************************************************** + Copyright (c) 2010, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native C interface to LAPACK utility function +* Author: Intel Corporation +*****************************************************************************/ +#include "lapacke_utils.h" + +/* Check a matrix for NaN entries. */ + +lapack_logical API_SUFFIX(LAPACKE_skt_nancheck)( lapack_int n, + const float *d, + const float *e ) +{ + return API_SUFFIX(LAPACKE_s_nancheck)( n-1, e, 1 ); +} diff --git a/LAPACKE/utils/lapacke_sky_nancheck.c b/LAPACKE/utils/lapacke_sky_nancheck.c new file mode 100644 index 000000000..d1348f62a --- /dev/null +++ b/LAPACKE/utils/lapacke_sky_nancheck.c @@ -0,0 +1,42 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native C interface to LAPACK utility function +* Author: Intel Corporation +*****************************************************************************/ +#include "lapacke_utils.h" + +/* Check a matrix for NaN entries. */ + +lapack_logical API_SUFFIX(LAPACKE_sky_nancheck)( int matrix_layout, char uplo, + lapack_int n, + const float *a, + lapack_int lda ) +{ + return API_SUFFIX(LAPACKE_str_nancheck)( matrix_layout, uplo, 'u', n, a, lda ); +} diff --git a/LAPACKE/utils/lapacke_sky_trans.c b/LAPACKE/utils/lapacke_sky_trans.c new file mode 100644 index 000000000..c41694cb9 --- /dev/null +++ b/LAPACKE/utils/lapacke_sky_trans.c @@ -0,0 +1,44 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +****************************************************************************** +* Contents: Native C interface to LAPACK utility function +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +/* Converts input skew-symmetric matrix from row-major(C) to column-major(Fortran) + * layout or vice versa. + */ + +void API_SUFFIX(LAPACKE_sky_trans)( int matrix_layout, char uplo, lapack_int n, + const float *in, lapack_int ldin, + float *out, lapack_int ldout ) +{ + API_SUFFIX(LAPACKE_str_trans)( matrix_layout, uplo, 'u', n, in, ldin, out, ldout ); +} diff --git a/SRC/CMakeLists.txt b/SRC/CMakeLists.txt index be426cecd..bc37a660b 100644 --- a/SRC/CMakeLists.txt +++ b/SRC/CMakeLists.txt @@ -48,7 +48,7 @@ set(SCLAUX sbdsqr.f sdisna.f slabad.f slacpy.f sladiv.f slae2.f slaebz.f slaed0.f slaed1.f slaed2.f slaed3.f slaed4.f slaed5.f slaed6.f slaed7.f slaed8.f slaed9.f slaeda.f slaev2.f slagtf.f - slagts.f slamrg.f slanst.f + slagts.f slamrg.f slanst.f slankt.f slapy2.f slapy3.f slarnv.f slarra.f slarrb.f slarrc.f slarrd.f slarre.f slarrf.f slarrj.f slarrk.f slarrr.f slaneg.f @@ -57,7 +57,7 @@ set(SCLAUX slasd7.f slasd8.f slasda.f slasdq.f slasdt.f slaset.f slasq1.f slasq2.f slasq3.f slasq4.f slasq5.f slasq6.f slasr.f slasrt.f slassq.f90 slasv2.f spttrf.f sstebz.f sstedc.f - sstein.f ssteqr.f ssterf.f sstevx.f + sstein.f ssteqr.f skteqr.f ssterf.f sstevx.f slartgp.f slartgs.f ../INSTALL/sroundup_lwork.f ${SECOND_SRC}) @@ -68,7 +68,7 @@ set(DZLAUX dlabad.f dlacpy.f dladiv.f dlae2.f dlaebz.f dlaed0.f dlaed1.f dlaed2.f dlaed3.f dlaed4.f dlaed5.f dlaed6.f dlaed7.f dlaed8.f dlaed9.f dlaeda.f dlaev2.f dlagtf.f - dlagts.f dlamrg.f dlanst.f + dlagts.f dlamrg.f dlanst.f dlankt.f dlapy2.f dlapy3.f dlarnv.f dlarra.f dlarrb.f dlarrc.f dlarrd.f dlarre.f dlarrf.f dlarrj.f dlarrk.f dlarrr.f dlaneg.f @@ -78,7 +78,7 @@ set(DZLAUX dlaset.f dlasq1.f dlasq2.f dlasq3.f dlasq4.f dlasq5.f dlasq6.f dlasr.f dlasrt.f dlassq.f90 dlasv2.f dlaisnan.f dpttrf.f - dstebz.f dstedc.f dstein.f dsteqr.f dsterf.f dstevx.f + dstebz.f dstedc.f dstein.f dsteqr.f dkteqr.f dsterf.f dstevx.f dlartgp.f dlartgs.f ../INSTALL/droundup_lwork.f ../INSTALL/dlamch.f ${DSECOND_SRC}) @@ -101,7 +101,7 @@ set(SLASRC slaein.f slaexc.f slag2.f slags2.f slagtm.f slagv2.f slahqr.f slahr2.f slaic1.f slaln2.f slals0.f slalsa.f slalsd.f slangb.f slange.f slangt.f slanhs.f slansb.f slansp.f - slansy.f slantb.f slantp.f slantr.f slanv2.f + slansy.f slanky.f slantb.f slantp.f slantr.f slanv2.f slapll.f slapmt.f slaqgb.f slaqge.f slaqp2.f slaqps.f slaqp2rk.f slaqp3rk.f slaqsb.f slaqsp.f slaqsy.f slaqr0.f slaqr1.f slaqr2.f slaqr3.f slaqr4.f slaqr5.f @@ -109,8 +109,8 @@ set(SLASRC slarf.f slarf1f.f slarf1l.f slarfb.f slarfb_gett.f slarfg.f slarfgp.f slarft.f slarfx.f slarfy.f slargv.f slarmm.f slarrv.f slartv.f slarz.f slarzb.f slarzt.f slasy2.f - slasyf.f slasyf_rook.f slasyf_rk.f slasyf_aa.f - slatbs.f slatdf.f slatps.f slatrd.f slatrs.f slatrs3.f slatrz.f + slasyf.f slakyf.f slasyf_rook.f slasyf_rk.f slasyf_aa.f + slatbs.f slatdf.f slatps.f slatrd.f slatrdk.f slatrs.f slatrs3.f slatrz.f slauu2.f slauum.f sopgtr.f sopmtr.f sorg2l.f sorg2r.f sorgbr.f sorghr.f sorgl2.f sorglq.f sorgql.f sorgqr.f sorgr2.f sorgrq.f sorgtr.f sorgtsqr.f sorgtsqr_row.f sorm2l.f sorm2r.f sorm22.f @@ -125,12 +125,14 @@ set(SLASRC ssbev.f ssbevd.f ssbevx.f ssbgst.f ssbgv.f ssbgvd.f ssbgvx.f ssbtrd.f sspcon.f sspev.f sspevd.f sspevx.f sspgst.f sspgv.f sspgvd.f sspgvx.f ssprfs.f sspsv.f sspsvx.f ssptrd.f - ssptrf.f ssptri.f ssptrs.f sstegr.f sstev.f sstevd.f sstevr.f - ssycon.f ssyev.f ssyevd.f ssyevr.f ssyevx.f ssygs2.f - ssygst.f ssygv.f ssygvd.f ssygvx.f ssyrfs.f ssysv.f ssysvx.f + ssptrf.f ssptri.f ssptrs.f sstegr.f sstev.f sktev.f sstevd.f sstevr.f + ssycon.f ssyev.f skyev.f ssyevd.f ssyevr.f ssyevx.f ssygs2.f skygs2.f + ssygst.f skygst.f ssygv.f skygv.f ssygvd.f ssygvx.f ssyrfs.f ssysv.f skysv.f ssysvx.f ssytd2.f ssytf2.f ssytrd.f ssytrf.f ssytri.f ssytri2.f ssytri2x.f + skytd2.f skytf2.f skytrd.f skytrf.f skytri.f skytri2.f skytri2x.f ssyswapr.f ssytrs.f ssytrs2.f - ssyconv.f ssyconvf.f ssyconvf_rook.f + skyswapr.f skytrs.f skytrs2.f + ssyconv.f skyconv.f ssyconvf.f ssyconvf_rook.f ssytf2_rook.f ssytrf_rook.f ssytrs_rook.f ssytri_rook.f ssycon_rook.f ssysv_rook.f ssytf2_rk.f ssytrf_rk.f ssytrs_3.f @@ -302,7 +304,7 @@ set(DLASRC dlaein.f dlaexc.f dlag2.f dlags2.f dlagtm.f dlagv2.f dlahqr.f dlahr2.f dlaic1.f dlaln2.f dlals0.f dlalsa.f dlalsd.f dlangb.f dlange.f dlangt.f dlanhs.f dlansb.f dlansp.f - dlansy.f dlantb.f dlantp.f dlantr.f dlanv2.f + dlansy.f dlanky.f dlantb.f dlantp.f dlantr.f dlanv2.f dlapll.f dlapmt.f dlaqgb.f dlaqge.f dlaqp2.f dlaqps.f dlaqp2rk.f dlaqp3rk.f dlaqsb.f dlaqsp.f dlaqsy.f dlaqr0.f dlaqr1.f dlaqr2.f dlaqr3.f dlaqr4.f dlaqr5.f @@ -310,8 +312,8 @@ set(DLASRC dlarf.f dlarfb.f dlarfb_gett.f dlarfg.f dlarfgp.f dlarft.f dlarfx.f dlarfy.f dlarf1f.f dlarf1l.f dlargv.f dlarmm.f dlarrv.f dlartv.f dlarz.f dlarzb.f dlarzt.f dlaswp.f dlasy2.f - dlasyf.f dlasyf_rook.f dlasyf_rk.f dlasyf_aa.f - dlatbs.f dlatdf.f dlatps.f dlatrd.f dlatrs.f dlatrs3.f dlatrz.f dlauu2.f + dlasyf.f dlakyf.f dlasyf_rook.f dlasyf_rk.f dlasyf_aa.f + dlatbs.f dlatdf.f dlatps.f dlatrd.f dlatrdk.f dlatrs.f dlatrs3.f dlatrz.f dlauu2.f dlauum.f dopgtr.f dopmtr.f dorg2l.f dorg2r.f dorgbr.f dorghr.f dorgl2.f dorglq.f dorgql.f dorgqr.f dorgr2.f dorgrq.f dorgtr.f dorgtsqr.f dorgtsqr_row.f dorm2l.f dorm2r.f dorm22.f @@ -326,13 +328,15 @@ set(DLASRC dsbev.f dsbevd.f dsbevx.f dsbgst.f dsbgv.f dsbgvd.f dsbgvx.f dsbtrd.f dspcon.f dspev.f dspevd.f dspevx.f dspgst.f dspgv.f dspgvd.f dspgvx.f dsprfs.f dspsv.f dspsvx.f dsptrd.f - dsptrf.f dsptri.f dsptrs.f dstegr.f dstev.f dstevd.f dstevr.f - dsycon.f dsyev.f dsyevd.f dsyevr.f - dsyevx.f dsygs2.f dsygst.f dsygv.f dsygvd.f dsygvx.f dsyrfs.f - dsysv.f dsysvx.f + dsptrf.f dsptri.f dsptrs.f dstegr.f dstev.f dktev.f dstevd.f dstevr.f + dsycon.f dsyev.f dkyev.f dsyevd.f dsyevr.f + dsyevx.f dsygs2.f dkygs2.f dsygst.f dkygst.f dsygv.f dkygv.f dsygvd.f dsygvx.f dsyrfs.f + dsysv.f dkysv.f dsysvx.f dsytd2.f dsytf2.f dsytrd.f dsytrf.f dsytri.f dsytrs.f dsytrs2.f + dkytd2.f dkytf2.f dkytrd.f dkytrf.f dkytri.f dkytrs.f dkytrs2.f dsytri2.f dsytri2x.f dsyswapr.f - dsyconv.f dsyconvf.f dsyconvf_rook.f + dkytri2.f dkytri2x.f dkyswapr.f + dsyconv.f dkyconv.f dsyconvf.f dsyconvf_rook.f dsytf2_rook.f dsytrf_rook.f dsytrs_rook.f dsytri_rook.f dsycon_rook.f dsysv_rook.f dsytf2_rk.f dsytrf_rk.f dsytrs_3.f diff --git a/SRC/Makefile b/SRC/Makefile index 0191626f0..f9c694cb1 100644 --- a/SRC/Makefile +++ b/SRC/Makefile @@ -80,7 +80,7 @@ SCLAUX = \ sbdsqr.o sdisna.o slabad.o slacpy.o sladiv.o slae2.o slaebz.o \ slaed0.o slaed1.o slaed2.o slaed3.o slaed4.o slaed5.o slaed6.o \ slaed7.o slaed8.o slaed9.o slaeda.o slaev2.o slagtf.o \ - slagts.o slamrg.o slanst.o \ + slagts.o slamrg.o slanst.o slankt.o \ slapy2.o slapy3.o slarnv.o \ slarra.o slarrb.o slarrc.o slarrd.o slarre.o slarrf.o slarrj.o \ slarrk.o slarrr.o slaneg.o \ @@ -89,7 +89,7 @@ SCLAUX = \ slasd7.o slasd8.o slasda.o slasdq.o slasdt.o \ slaset.o slasq1.o slasq2.o slasq3.o slasq4.o slasq5.o slasq6.o \ slasr.o slasrt.o slassq.o slasv2.o spttrf.o sstebz.o sstedc.o \ - ssteqr.o ssterf.o slaisnan.o sisnan.o \ + ssteqr.o skteqr.o ssterf.o slaisnan.o sisnan.o \ slartgp.o slartgs.o ../INSTALL/sroundup_lwork.o \ ../INSTALL/second_$(TIMER).o @@ -99,7 +99,7 @@ DZLAUX = \ dbdsqr.o ddisna.o dlabad.o dlacpy.o dladiv.o dlae2.o dlaebz.o \ dlaed0.o dlaed1.o dlaed2.o dlaed3.o dlaed4.o dlaed5.o dlaed6.o \ dlaed7.o dlaed8.o dlaed9.o dlaeda.o dlaev2.o dlagtf.o \ - dlagts.o dlamrg.o dlanst.o \ + dlagts.o dlamrg.o dlanst.o dlankt.o\ dlapy2.o dlapy3.o dlarnv.o \ dlarra.o dlarrb.o dlarrc.o dlarrd.o dlarre.o dlarrf.o dlarrj.o \ dlarrk.o dlarrr.o dlaneg.o \ @@ -108,7 +108,7 @@ DZLAUX = \ dlasd7.o dlasd8.o dlasda.o dlasdq.o dlasdt.o \ dlaset.o dlasq1.o dlasq2.o dlasq3.o dlasq4.o dlasq5.o dlasq6.o \ dlasr.o dlasrt.o dlassq.o dlasv2.o dpttrf.o dstebz.o dstedc.o \ - dsteqr.o dsterf.o dlaisnan.o disnan.o \ + dsteqr.o dkteqr.o dsterf.o dlaisnan.o disnan.o \ dlartgp.o dlartgs.o ../INSTALL/droundup_lwork.o \ ../INSTALL/dlamch.o ../INSTALL/dsecnd_$(TIMER).o @@ -132,16 +132,16 @@ SLASRC = \ slaein.o slaexc.o slag2.o slags2.o slagtm.o slagv2.o slahqr.o \ slahr2.o slaic1.o slaln2.o slals0.o slalsa.o slalsd.o \ slangb.o slange.o slangt.o slanhs.o slansb.o slansp.o \ - slansy.o slantb.o slantp.o slantr.o slanv2.o \ + slansy.o slanky.o slantb.o slantp.o slantr.o slanv2.o \ slapll.o slapmt.o \ slaqgb.o slaqge.o slaqp2.o slaqps.o slaqp2rk.o slaqp3rk.o slaqsb.o slaqsp.o slaqsy.o \ slaqr0.o slaqr1.o slaqr2.o slaqr3.o slaqr4.o slaqr5.o \ slaqtr.o slar1v.o slar2v.o ilaslr.o ilaslc.o \ slarf.o slarf1f.o slarf1l.o slarfb.o slarfb_gett.o slarfg.o slarfgp.o slarft.o slarfx.o slarfy.o \ slargv.o slarmm.o slarrv.o slartv.o \ - slarz.o slarzb.o slarzt.o slaswp.o slasy2.o slasyf.o slasyf_rook.o \ + slarz.o slarzb.o slarzt.o slaswp.o slasy2.o slasyf.o slakyf.o slasyf_rook.o \ slasyf_rk.o \ - slatbs.o slatdf.o slatps.o slatrd.o slatrs.o slatrs3.o slatrz.o \ + slatbs.o slatdf.o slatps.o slatrd.o slatrdk.o slatrs.o slatrs3.o slatrz.o \ slauu2.o slauum.o sopgtr.o sopmtr.o sorg2l.o sorg2r.o \ sorgbr.o sorghr.o sorgl2.o sorglq.o sorgql.o sorgqr.o sorgr2.o \ sorgrq.o sorgtr.o sorgtsqr.o sorgtsqr_row.o sorm2l.o sorm2r.o sorm22.o \ @@ -156,13 +156,15 @@ SLASRC = \ ssbev.o ssbevd.o ssbevx.o ssbgst.o ssbgv.o ssbgvd.o ssbgvx.o \ ssbtrd.o sspcon.o sspev.o sspevd.o sspevx.o sspgst.o \ sspgv.o sspgvd.o sspgvx.o ssprfs.o sspsv.o sspsvx.o ssptrd.o \ - ssptrf.o ssptri.o ssptrs.o sstegr.o sstein.o sstev.o sstevd.o sstevr.o \ + ssptrf.o ssptri.o ssptrs.o sstegr.o sstein.o sstev.o sktev.o sstevd.o sstevr.o \ sstevx.o \ - ssycon.o ssyev.o ssyevd.o ssyevr.o ssyevx.o ssygs2.o \ - ssygst.o ssygv.o ssygvd.o ssygvx.o ssyrfs.o ssysv.o ssysvx.o \ + ssycon.o ssyev.o skyev.o ssyevd.o ssyevr.o ssyevx.o ssygs2.o skygs2.o \ + ssygst.o skygst.o ssygv.o skygv.o ssygvd.o ssygvx.o ssyrfs.o ssysv.o skysv.o ssysvx.o \ ssytd2.o ssytf2.o ssytrd.o ssytrf.o ssytri.o ssytri2.o ssytri2x.o \ + skytd2.o skytf2.o skytrd.o skytrf.o skytri.o skytri2.o skytri2x.o \ ssyswapr.o ssytrs.o ssytrs2.o \ - ssyconv.o ssyconvf.o ssyconvf_rook.o \ + skyswapr.o skytrs.o skytrs2.o \ + ssyconv.o skyconv.o ssyconvf.o ssyconvf_rook.o \ ssytf2_rook.o ssytrf_rook.o ssytrs_rook.o \ ssytri_rook.o ssycon_rook.o ssysv_rook.o \ ssytf2_rk.o ssytrf_rk.o ssytrs_3.o \ @@ -334,7 +336,7 @@ DLASRC = \ dlaein.o dlaexc.o dlag2.o dlags2.o dlagtm.o dlagv2.o dlahqr.o \ dlahr2.o dlaic1.o dlaln2.o dlals0.o dlalsa.o dlalsd.o \ dlangb.o dlange.o dlangt.o dlanhs.o dlansb.o dlansp.o \ - dlansy.o dlantb.o dlantp.o dlantr.o dlanv2.o \ + dlansy.o dlanky.o dlantb.o dlantp.o dlantr.o dlanv2.o \ dlapll.o dlapmt.o \ dlaqgb.o dlaqge.o dlaqp2.o dlaqps.o dlaqp2rk.o dlaqp3rk.o dlaqsb.o dlaqsp.o dlaqsy.o \ dlaqr0.o dlaqr1.o dlaqr2.o dlaqr3.o dlaqr4.o dlaqr5.o \ @@ -342,8 +344,8 @@ DLASRC = \ dlarf.o dlarfb.o dlarfb_gett.o dlarfg.o dlarfgp.o dlarft.o dlarfx.o dlarfy.o dlarf1f.o dlarf1l.o\ dlargv.o dlarmm.o dlarrv.o dlartv.o \ dlarz.o dlarzb.o dlarzt.o dlaswp.o dlasy2.o \ - dlasyf.o dlasyf_rook.o dlasyf_rk.o \ - dlatbs.o dlatdf.o dlatps.o dlatrd.o dlatrs.o dlatrs3.o dlatrz.o dlauu2.o \ + dlasyf.o dlakyf.o dlasyf_rook.o dlasyf_rk.o \ + dlatbs.o dlatdf.o dlatps.o dlatrd.o dlatrdk.o dlatrs.o dlatrs3.o dlatrz.o dlauu2.o \ dlauum.o dopgtr.o dopmtr.o dorg2l.o dorg2r.o \ dorgbr.o dorghr.o dorgl2.o dorglq.o dorgql.o dorgqr.o dorgr2.o \ dorgrq.o dorgtr.o dorgtsqr.o dorgtsqr_row.o dorm2l.o dorm2r.o dorm22.o \ @@ -358,14 +360,16 @@ DLASRC = \ dsbev.o dsbevd.o dsbevx.o dsbgst.o dsbgv.o dsbgvd.o dsbgvx.o \ dsbtrd.o dspcon.o dspev.o dspevd.o dspevx.o dspgst.o \ dspgv.o dspgvd.o dspgvx.o dsprfs.o dspsv.o dspsvx.o dsptrd.o \ - dsptrf.o dsptri.o dsptrs.o dstegr.o dstein.o dstev.o dstevd.o dstevr.o \ + dsptrf.o dsptri.o dsptrs.o dstegr.o dstein.o dstev.o dktev.o dstevd.o dstevr.o \ dstevx.o \ - dsycon.o dsyev.o dsyevd.o dsyevr.o \ - dsyevx.o dsygs2.o dsygst.o dsygv.o dsygvd.o dsygvx.o dsyrfs.o \ - dsysv.o dsysvx.o \ + dsycon.o dsyev.o dkyev.o dsyevd.o dsyevr.o \ + dsyevx.o dsygs2.o dkygs2.o dsygst.o dkygst.o dsygv.o dkygv.o dsygvd.o dsygvx.o dsyrfs.o \ + dsysv.o dkysv.o dsysvx.o \ dsytd2.o dsytf2.o dsytrd.o dsytrf.o dsytri.o dsytri2.o dsytri2x.o \ + dkytd2.o dkytf2.o dkytrd.o dkytrf.o dkytri.o dkytri2.o dkytri2x.o \ dsyswapr.o dsytrs.o dsytrs2.o \ - dsyconv.o dsyconvf.o dsyconvf_rook.o \ + dkyswapr.o dkytrs.o dkytrs2.o \ + dsyconv.o dkyconv.o dsyconvf.o dsyconvf_rook.o \ dsytf2_rook.o dsytrf_rook.o dsytrs_rook.o \ dsytri_rook.o dsycon_rook.o dsysv_rook.o \ dsytf2_rk.o dsytrf_rk.o dsytrs_3.o \ diff --git a/SRC/dkteqr.f b/SRC/dkteqr.f new file mode 100644 index 000000000..383df723d --- /dev/null +++ b/SRC/dkteqr.f @@ -0,0 +1,860 @@ +*> \brief \b DKTEQR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DKTEQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DKTEQR( COMPZ, N, E, Z, LDZ, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER COMPZ +* INTEGER INFO, LDZ, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION E( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DKTEQR computes all eigenvalues and, optionally, eigenvectors of a +*> skew-symmetric tridiagonal matrix using the implicit double shift +*> QL or QR method. +*> The eigenvectors of a full skew-symmetric matrix can be found if +*> DKYTRD has been used to reduce this matrix to tridiagonal form. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] COMPZ +*> \verbatim +*> COMPZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only. +*> = 'V': Compute eigenvalues and eigenvectors of the original +*> skew-symmetric matrix. On entry, Z must contain the +*> orthogonal matrix used to reduce the original matrix +*> to tridiagonal form. +*> = 'I': Compute eigenvalues and eigenvectors of the +*> tridiagonal matrix. Z is initialized to the identity +*> matrix. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. N >= 0. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> On entry, the (n-1) lower subdiagonal elements of the +*> tridiagonal matrix. +*> On exit, the (n-1) lower subdiagonal elements of the +*> block diagonal matrix. If INFO = 0, the matrix consists +*> of 2-by-2 skew-symmetric blocks, and zeros. +*> The values in E, which represent blocks, are always +*> positive, and sorted in descending order. +*> The eigenvalues of each blocks can be evaluated directly. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, N) +*> On entry, if COMPZ = 'V', then Z contains the orthogonal +*> matrix used in the reduction to tridiagonal form. +*> On exit, if INFO = 0, then if COMPZ = 'V', Z is the +*> orthogonal matrix transforming the original skew-symmetric +*> matrix to the block diagonal matrix, and if COMPZ = 'I', +*> Z is the orthogonal matrix transforming the skew-symmetric +*> tridiagonal matrix to the block diagonal matrix. +*> The eigenvectors of corresponding matrix can be evaluated +*> directly. +*> If COMPZ = 'N', then Z is not referenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> eigenvectors are desired, then LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array. +*> WORK is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: the algorithm has failed to find all the eigenvalues in +*> a total of 30*N iterations; if INFO = i, then i +*> elements of E have not converged to zero; on exit +*> E contain the elements of a skew-symmetric tridiagonal +*> matrix which is orthogonally similar to the original +*> matrix. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kteqr +* +* ===================================================================== + SUBROUTINE DKTEQR( COMPZ, N, E, Z, LDZ, WORK, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER COMPZ + INTEGER INFO, LDZ, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION E( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0 ) + INTEGER MAXIT + PARAMETER ( MAXIT = 30 ) +* .. +* .. Local Scalars .. + INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, + $ LENDM1, LENDP1, LENDSV, LM3, LSV, M, MM1, + $ NM1, NMAXIT + DOUBLE PRECISION ANORM, B, EPS, EPS2, P, R, VA, VB, E3, + $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLAPY2, DLANKT + EXTERNAL LSAME, DLAMCH, DLAPY2, DLANKT +* .. +* .. External Subroutines .. + EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASET, + $ DLASRT, DSWAP, DSCAL, DROT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SIGN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( LSAME( COMPZ, 'N' ) ) THEN + ICOMPZ = 0 + ELSE IF( LSAME( COMPZ, 'V' ) ) THEN + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ICOMPZ = 2 + ELSE + ICOMPZ = -1 + END IF + IF( ICOMPZ.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, + $ N ) ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DKTEQR', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0) + $ RETURN +* + IF( N.EQ.1) THEN + IF( ICOMPZ.EQ.2 ) + $ Z( 1, 1 ) = ONE + RETURN + END IF +* + IF( N.EQ.2) THEN + IF( ICOMPZ.EQ.2 ) THEN + Z( 1, 1 ) = ONE + Z( 1, 2 ) = ZERO + Z( 2, 1 ) = ZERO + Z( 2, 2 ) = ONE + END IF + IF( E(1).LT.ZERO ) THEN + E(1) = -E(1) + CALL DSWAP( N, Z( 1, 1 ), 1, Z( 1, 2 ), 1 ) + END IF + RETURN + END IF +* +* Determine the unit roundoff and over/underflow thresholds. +* + EPS = DLAMCH( 'E' ) + EPS2 = EPS**2 + SAFMIN = DLAMCH( 'S' ) + SAFMAX = ONE / SAFMIN + SSFMAX = SQRT( SAFMAX ) / THREE + SSFMIN = SQRT( SAFMIN ) / EPS2 +* +* Compute the eigenvalues and eigenvectors of the tridiagonal +* matrix. +* + IF( ICOMPZ.EQ.2 ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +* + NMAXIT = N*MAXIT + JTOT = 0 +* +* Determine where the matrix splits and choose QL or QR iteration +* for each block, according to whether top or bottom diagonal +* element is smaller. +* + L1 = 1 + NM1 = N - 1 +* + 10 CONTINUE + IF( L1.GT.N ) + $ GO TO 160 + IF( L1.GT.1 ) + $ E( L1-1 ) = ZERO + IF( L1.LE.NM1 ) THEN + DO 20 M = L1, NM1 + TST = ABS( E( M ) ) + IF( TST.EQ.ZERO ) + $ GO TO 30 + IF( TST.LE.( ABS( E( M+ + $ 1 ) ) )*EPS .AND. M.EQ.L1 ) THEN + E( M ) = ZERO + GO TO 30 + ELSEIF( TST.LE.( ABS( E( M- + $ 1 ) ) )*EPS .AND. M.EQ.NM1 ) THEN + E( M ) = ZERO + GO TO 30 + ELSEIF( TST.LE.( SQRT( ABS( E( M-1 ) ) )* + $ SQRT( ABS( E( M+1 ) ) ) )*EPS ) THEN + E( M ) = ZERO + GO TO 30 + END IF + 20 CONTINUE + END IF + M = N +* + 30 CONTINUE + L = L1 + LSV = L + LEND = M + LENDSV = LEND + L1 = M + 1 + IF( LEND.EQ.L ) + $ GO TO 10 +* +* Scale submatrix in rows and columns L to LEND +* + ANORM = DLANKT( 'M', LEND-L+1, E( L ) ) + ISCALE = 0 + IF( ANORM.EQ.ZERO ) + $ GO TO 10 + IF( ANORM.GT.SSFMAX ) THEN + ISCALE = 1 + CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, + $ INFO ) + ELSE IF( ANORM.LT.SSFMIN ) THEN + ISCALE = 2 + CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, + $ INFO ) + END IF +* +* Choose between QL and QR iteration +* + IF( L.NE.LEND ) THEN + IF( ABS( E( LEND-1 ) ).LT.ABS( E( L ) ) ) THEN + LEND = LSV + L = LENDSV + END IF + END IF +* + IF( LEND.GT.L ) THEN +* +* QL Iteration +* +* Look for small subdiagonal element. +* + 40 CONTINUE + IF( L.NE.LEND .AND. L.NE.LEND-1 ) THEN + LENDM1 = LEND - 1 + DO 50 M = L, LENDM1 + TST = ABS( E( M ) )**2 + IF( TST.LE.( EPS2*ABS( E( M+1 ) ) )*ABS( E( M+1 ) )+ + $ SAFMIN .AND. M.EQ.L) THEN + GO TO 60 + ELSEIF( TST.LE.( EPS2*ABS( E( M-1 ) ) )*ABS( E( M-1 ) )+ + $ SAFMIN .AND. M.EQ.LENDM1 ) THEN + GO TO 60 + ELSEIF( TST.LE.( EPS2*ABS( E( M-1 ) ) )*ABS( E( M+1 ) )+ + $ SAFMIN ) THEN + GO TO 60 + END IF + 50 CONTINUE + END IF +* + M = LEND +* + 60 CONTINUE + IF( M.LT.LEND ) + $ E( M ) = ZERO +* + IF( M.EQ.L ) + $ GO TO 80 +* +* If remaining matrix is 2-by-2, get its eigensystem directly +* + IF( M.EQ.L+1 ) THEN + L = L + 2 + IF( L.LE.LEND ) + $ GO TO 40 + GO TO 140 + END IF +* +* Exit if all iteratives have been done +* + IF( JTOT.EQ.NMAXIT ) + $ GO TO 140 + JTOT = JTOT + 1 +* +* If remaining matrix is 3-by-3, get its eigensystem directly +* + IF( M.EQ.L+2 ) THEN + IF ( MOD( JTOT, 10 ).EQ.0 ) THEN + B = E(L)*E(L) * (ONE - MIN(ABS(E(L+1)/E(L)), ONE)) + ELSE + B = E(L)*E(L) + END IF + P = -E(M-1)*E(M-1) + B + R = E(M-1)*E(M-2) + S = SIGN(DLAPY2( P, R ), P) +* + IF(S.EQ.ZERO) THEN + VA = -ONE + VB = ZERO + ELSE + VA = -P/S + VB = -R/S + END IF +* +* Update E. +* + TEMP = E(M-1) + E(M-1) = VA*E(M-1) - VB*E(M-2) + E(M-2) = -VB*TEMP - VA*E(M-2) +* +* If eigenvectors are desired, then update Z initially. +* + IF( ICOMPZ.GT.0 ) THEN + CALL DROT(N, Z(1, M), 1, Z(1, M-2), 1, VA, VB) + CALL DSCAL(N, -ONE, Z(1, M-2), 1) + END IF +* + I = L + 1 +* +* Update E. +* + E(I) = -E(I) + E(I-1) = -E(I-1) +* +* If eigenvectors are desired, then update Z. +* + IF( ICOMPZ.GT.0 ) THEN + CALL DSCAL(N, -ONE, Z(1, I), 1) + END IF +* + GO TO 40 + END IF +* +* Form shift and set initial values. +* + IF ( MOD( JTOT, 10 ).EQ.0 ) THEN + B = E(L)*E(L) * (ONE - MIN(ABS(E(L+1)/E(L)), ONE)) + ELSE + B = E(L)*E(L) + END IF + P = -E(M-1)*E(M-1) + B + R = E(M-1)*E(M-2) + S = SIGN(DLAPY2( P, R ), P) +* + IF(S.EQ.ZERO) THEN + VA = -ONE + VB = ZERO + ELSE + VA = -P/S + VB = -R/S + END IF +* +* Update E. +* + TEMP = E(M-1) + E(M-1) = VA*E(M-1) - VB*E(M-2) + E(M-2) = -VB*TEMP - VA*E(M-2) + E3 = E(M-3) + E(M-3) = -VA*E(M-3) +* +* If eigenvectors are desired, then update Z initially. +* + IF( ICOMPZ.GT.0 ) THEN + CALL DROT(N, Z(1, M), 1, Z(1, M-2), 1, VA, VB) + CALL DSCAL(N, -ONE, Z(1, M-2), 1) + END IF +* +* Inner loop +* + MM1 = M - 1 + DO 70 I = MM1, L+3, -1 +* +* Set iterative values. +* + P = E(I) + R = VB*E3 + S = SIGN(DLAPY2( P, R ), P) + E(I) = -S +* + IF(S.EQ.ZERO) THEN + VA = -ONE + VB = ZERO + ELSE + VA = -P/S + VB = -R/S + END IF +* +* Update E. +* + TEMP = E(I-1) + E(I-1) = VA*E(I-1) - VB*E(I-2) + E(I-2) = -VB*TEMP - VA*E(I-2) + E3 = E(I-3) + E(I-3) = -VA*E(I-3) +* +* If eigenvectors are desired, then update Z. +* + IF( ICOMPZ.GT.0 ) THEN + CALL DROT(N, Z(1, I), 1, Z(1, I-2), 1, VA, VB) + CALL DSCAL(N, -ONE, Z(1, I-2), 1) + END IF +* + 70 CONTINUE +* + I = L + 2 +* +* Set iterative values. +* + P = E(I) + R = VB*E3 + S = SIGN(DLAPY2( P, R ), P) + E(I) = -S +* + IF(S.EQ.ZERO) THEN + VA = -ONE + VB = ZERO + ELSE + VA = -P/S + VB = -R/S + END IF +* +* Update E. +* + TEMP = E(I-1) + E(I-1) = VA*E(I-1) - VB*E(I-2) + E(I-2) = -VB*TEMP - VA*E(I-2) +* +* If eigenvectors are desired, then update Z. +* + IF( ICOMPZ.GT.0 ) THEN + CALL DROT(N, Z(1, I), 1, Z(1, I-2), 1, VA, VB) + CALL DSCAL(N, -ONE, Z(1, I-2), 1) + END IF +* + I = L + 1 +* +* Update E. +* + E(I) = -E(I) + E(I-1) = -E(I-1) +* +* If eigenvectors are desired, then update Z. +* + IF( ICOMPZ.GT.0 ) THEN + CALL DSCAL(N, -ONE, Z(1, I), 1) + END IF +* + GO TO 40 +* +* Eigenvalue found. +* + 80 CONTINUE + L = L + 1 + IF( L.LE.LEND ) + $ GO TO 40 + GO TO 140 +* + ELSE +* +* QR Iteration +* +* Look for small superdiagonal element. +* + 90 CONTINUE + IF( L.NE.LEND .AND. L.NE.LEND+1 ) THEN + LENDP1 = LEND + 1 + DO 100 M = L, LENDP1, -1 + TST = ABS( E( M-1 ) )**2 + IF( TST.LE.( EPS2*ABS( E( M-2 ) ) )*ABS( E( M-2 ) )+ + $ SAFMIN .AND. M.EQ.L) THEN + GO TO 110 + ELSEIF( TST.LE.( EPS2*ABS( E( M ) ) )*ABS( E( M ) )+ + $ SAFMIN .AND. M.EQ.LENDP1 ) THEN + GO TO 110 + ELSEIF( TST.LE.( EPS2*ABS( E( M-2 ) ) )*ABS( E( M ) )+ + $ SAFMIN ) THEN + GO TO 110 + END IF + 100 CONTINUE + END IF +* + M = LEND +* + 110 CONTINUE + IF( M.GT.LEND ) + $ E( M-1 ) = ZERO +* + IF( M.EQ.L ) + $ GO TO 130 +* +* If remaining matrix is 2-by-2, get its eigensystem directly +* + IF( M.EQ.L-1 ) THEN + L = L - 2 + IF( L.GE.LEND ) + $ GO TO 90 + GO TO 140 + END IF +* +* Exit if all iteratives have been done +* + IF( JTOT.EQ.NMAXIT ) + $ GO TO 140 + JTOT = JTOT + 1 +* +* If remaining matrix is 3-by-3, get its eigensystem directly +* + IF( M.EQ.L-2 ) THEN + IF ( MOD( JTOT, 10 ).EQ.0 ) THEN + B = E(L-1)*E(L-1) * (ONE - MIN(ABS(E(L-2)/E(L-1)), ONE)) + ELSE + B = E(L-1)*E(L-1) + END IF + P = -E(M)*E(M) + B + R = E(M)*E(M+1) + S = SIGN(DLAPY2( P, R ), P) +* + IF(S.EQ.ZERO) THEN + VA = -ONE + VB = ZERO + ELSE + VA = -P/S + VB = -R/S + END IF +* +* Update E. +* + TEMP = E(M) + E(M) = VA*E(M) - VB*E(M+1) + E(M+1) = -VB*TEMP - VA*E(M+1) +* +* If eigenvectors are desired, then update Z initially. +* + IF( ICOMPZ.GT.0 ) THEN + CALL DROT(N, Z(1, M), 1, Z(1, M+2), 1, VA, VB) + CALL DSCAL(N, -ONE, Z(1, M+2), 1) + END IF +* + I = L - 1 +* +* Update E. +* + E(I-1) = -E(I-1) + E(I) = -E(I) +* +* If eigenvectors are desired, then update Z. +* + IF( ICOMPZ.GT.0 ) THEN + CALL DSCAL(N, -ONE, Z(1, I), 1) + END IF +* + GO TO 90 + END IF +* +* Form shift and set initial values. +* + IF ( MOD( JTOT, 10 ).EQ.0 ) THEN + B = E(L-1)*E(L-1) * (ONE - MIN(ABS(E(L-2)/E(L-1)), ONE)) + ELSE + B = E(L-1)*E(L-1) + END IF + P = -E(M)*E(M) + B + R = E(M)*E(M+1) + S = SIGN(DLAPY2( P, R ), P) +* + IF(S.EQ.ZERO) THEN + VA = -ONE + VB = ZERO + ELSE + VA = -P/S + VB = -R/S + END IF +* +* Update E. +* + TEMP = E(M) + E(M) = VA*E(M) - VB*E(M+1) + E(M+1) = -VB*TEMP - VA*E(M+1) + E3 = E(M+2) + E(M+2) = -VA*E(M+2) +* +* If eigenvectors are desired, then update Z initially. +* + IF( ICOMPZ.GT.0 ) THEN + CALL DROT(N, Z(1, M), 1, Z(1, M+2), 1, VA, VB) + CALL DSCAL(N, -ONE, Z(1, M+2), 1) + END IF +* +* Inner loop +* + LM3 = L - 3 + DO 120 I = M + 1, LM3 +* +* Set iterative values. +* + P = E(I-1) + R = VB*E3 + S = SIGN(DLAPY2( P, R ), P) + E(I-1) = -S +* + IF(S.EQ.ZERO) THEN + VA = -ONE + VB = ZERO + ELSE + VA = -P/S + VB = -R/S + END IF +* +* Update E. +* + TEMP = E(I) + E(I) = VA*E(I) - VB*E(I+1) + E(I+1) = -VB*TEMP - VA*E(I+1) + E3 = E(I+2) + E(I+2) = -VA*E(I+2) +* +* If eigenvectors are desired, then update Z. +* + IF( ICOMPZ.GT.0 ) THEN + CALL DROT(N, Z(1, I), 1, Z(1, I+2), 1, VA, VB) + CALL DSCAL(N, -ONE, Z(1, I+2), 1) + END IF +* + 120 CONTINUE +* + I = L - 2 +* +* Set iterative values. +* + P = E(I-1) + R = VB*E3 + S = SIGN(DLAPY2( P, R ), P) + E(I-1) = -S +* + IF(S.EQ.ZERO) THEN + VA = -ONE + VB = ZERO + ELSE + VA = -P/S + VB = -R/S + END IF +* +* Update E. +* + TEMP = E(I) + E(I) = VA*E(I) - VB*E(I+1) + E(I+1) = -VB*TEMP - VA*E(I+1) +* +* If eigenvectors are desired, then update Z. +* + IF( ICOMPZ.GT.0 ) THEN + CALL DROT(N, Z(1, I), 1, Z(1, I+2), 1, VA, VB) + CALL DSCAL(N, -ONE, Z(1, I+2), 1) + END IF +* + I = L - 1 +* +* Update E. +* + E(I-1) = -E(I-1) + E(I) = -E(I) +* +* If eigenvectors are desired, then update Z. +* + IF( ICOMPZ.GT.0 ) THEN + CALL DSCAL(N, -ONE, Z(1, I), 1) + END IF +* + GO TO 90 +* +* Eigenvalue found. +* + 130 CONTINUE + L = L - 1 + IF( L.GE.LEND ) + $ GO TO 90 + GO TO 140 +* + END IF +* +* Undo scaling if necessary +* + 140 CONTINUE + IF( ISCALE.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E(LSV), + $ N, INFO ) + ELSE IF( ISCALE.EQ.2 ) THEN + CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E(LSV), + $ N, INFO ) + END IF +* +* Check for no convergence to an eigenvalue after a total +* of N*MAXIT iterations. +* + IF( JTOT.LT.NMAXIT ) + $ GO TO 10 + DO 150 I = 1, N - 1 + IF( E( I ).NE.ZERO ) + $ INFO = INFO + 1 + 150 CONTINUE + GO TO 190 +* +* Order blocks. +* Use Selection Sort to minimize swaps of eigenvectors +* + 160 CONTINUE + II = 1 + DO WHILE(II.LT.(N-1)) + IF(E(II).EQ.ZERO) THEN + DO K = II+1,N-1,2 + IF(E(K).EQ.ZERO) THEN + DO I = II, K-2 + E(I) = E(I+1) + IF( ICOMPZ.GT.0 ) THEN + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, I+1 ), 1 ) + END IF + END DO + E(K-1) = ZERO + II = K+1 + EXIT + ELSEIF(MOD(N,2).EQ.1 .AND. K.EQ.(N-1)) THEN + DO I = II, K-1 + E(I) = E(I+1) + IF( ICOMPZ.GT.0 ) THEN + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, I+1 ), 1 ) + END IF + END DO + IF( ICOMPZ.GT.0 ) THEN + CALL DSWAP( N, Z( 1, K ), 1, Z( 1, K+1 ), 1 ) + END IF + E(K) = ZERO + II = K+1 + EXIT + ELSEIF(MOD(N,2).EQ.0 .AND. K.EQ.(N-2)) THEN + DO I = II, K-1 + E(I) = E(I+1) + IF( ICOMPZ.GT.0 ) THEN + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, I+1 ), 1 ) + END IF + END DO + IF( ICOMPZ.GT.0 ) THEN + CALL DSWAP( N, Z( 1, K ), 1, Z( 1, K+1 ), 1 ) + END IF + E(K) = ZERO + II = K+1 + EXIT + END IF + END DO + IF (II.LT.(N-1)) THEN + CYCLE + END IF + END IF + II = II+2 + END DO +* + DO 180 II = 1, N-1, 2 + I = II + P = ABS(E(II)) + DO 170 K = II+2, N-1, 2 + IF(ABS(E(K)).GT.P) THEN + I = K + P = ABS(E(K)) + END IF + 170 CONTINUE + IF(I.NE.II) THEN + CALL DSWAP( 1, E( I ), 1, E( II ), 1 ) + IF( ICOMPZ.GT.0 ) THEN + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, II ), 1 ) + CALL DSWAP( N, Z( 1, I+1 ), 1, Z( 1, II+1 ), 1 ) + END IF + END IF + IF(E(II).LT.ZERO) THEN + E(II) = -E(II) + IF( ICOMPZ.GT.0 ) THEN + CALL DSWAP( N, Z( 1, II ), 1, Z( 1, II+1 ), 1 ) + END IF + END IF + 180 CONTINUE +* + 190 CONTINUE + RETURN +* +* End of DKTEQR +* + END diff --git a/SRC/dktev.f b/SRC/dktev.f new file mode 100644 index 000000000..a7b1dd4eb --- /dev/null +++ b/SRC/dktev.f @@ -0,0 +1,238 @@ +*> \brief DKTEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DKTEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DKTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ +* INTEGER INFO, LDZ, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DKTEV computes all eigenvalues and, optionally, eigenvectors of a +*> real skew-symmetric tridiagonal matrix A. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. N >= 0. +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the (N-1) lower subdiagonal elements of the +*> block diagonal matrix at front, and zero at last. +*> The matrix consists of 2-by-2 skew-symmetric blocks, and zeros. +*> The values in D, which represent blocks, are always +*> positive, and sorted in descending order. +*> The eigenvalues of each blocks can be evaluated directly. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> On entry, the (n-1) subdiagonal elements of the tridiagonal +*> matrix A, stored in elements 1 to N-1 of E. +*> On exit, the contents of E are destroyed. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, N) +*> If JOBZ = 'V', then if INFO = 0, Z is the orthogonal matrix +*> transforming the skew-symmetric tridiagonal matrix to the +*> block diagonal matrix. The eigenvectors of corresponding matrix +*> can be evaluated directly. +*> If JOBZ = 'N', then Z is not referenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array. +*> WORK is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of E did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup ktev +* +* ===================================================================== + SUBROUTINE DKTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO ) +* +* -- LAPACK driver routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER JOBZ + INTEGER INFO, LDZ, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL WANTZ + INTEGER IMAX, ISCALE + DOUBLE PRECISION BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM, + $ TNRM +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANKT + EXTERNAL LSAME, DLAMCH, DLANKT +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DCOPY, DKTEQR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) +* + INFO = 0 + IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -6 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DKTEV ', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + D(1) = ZERO + IF( WANTZ ) + $ Z( 1, 1 ) = ONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ISCALE = 0 + TNRM = DLANKT( 'M', N, E ) + IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / TNRM + ELSE IF( TNRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / TNRM + END IF + IF( ISCALE.EQ.1 ) THEN + CALL DSCAL( N-1, SIGMA, E( 1 ), 1 ) + END IF +* +* call DKTEQR. +* + IF( .NOT.WANTZ ) THEN + CALL DKTEQR( 'N', N, E, Z, LDZ, WORK, INFO ) + ELSE + CALL DKTEQR( 'I', N, E, Z, LDZ, WORK, INFO ) + END IF +* + CALL DCOPY(N-1, E, 1, D, 1) + D(N) = ZERO +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = N + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, D, 1 ) + END IF +* + RETURN +* +* End of DKTEV +* + END diff --git a/SRC/dkyconv.f b/SRC/dkyconv.f new file mode 100644 index 000000000..cd936a5da --- /dev/null +++ b/SRC/dkyconv.f @@ -0,0 +1,341 @@ +*> \brief \b DKYCONV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DKYCONV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DKYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO, WAY +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DKYCONV convert A given by TRF into L and D and vice-versa. +*> Get Non-diag elements of D (returned in workspace) and +*> apply or reverse permutation done in TRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] WAY +*> \verbatim +*> WAY is CHARACTER*1 +*> = 'C': Convert +*> = 'R': Revert +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by SKYTRF. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by SKYTRF. +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N) +*> E stores the supdiagonal/subdiagonal of the skew-symmetric +*> 2-by-2 block diagonal matrix D in LDLT. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kyconv +* +* ===================================================================== + SUBROUTINE DKYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO, WAY + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Local Scalars .. + LOGICAL UPPER, CONVERT + INTEGER I, IP, J + DOUBLE PRECISION TEMP +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + CONVERT = LSAME( WAY, 'C' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.CONVERT .AND. .NOT.LSAME( WAY, 'R' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DKYCONV', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* A is UPPER +* +* Convert A (A is upper) +* +* Convert VALUE +* + IF ( CONVERT ) THEN + I=N + E(1)=ZERO + DO WHILE ( I .GT. 1 ) + E(I)=A(I-1,I) + A(I-1,I)=ZERO + I=I-2 + END DO +* +* Convert PERMUTATIONS +* + I=N-2 + DO WHILE ( I .GT. 1 ) + IF( IPIV(I) .GT. 0) THEN + IP=IPIV(I) + DO 12 J= I+1,N + TEMP=A(IP,J) + A(IP,J)=A(I-1,J) + A(I-1,J)=TEMP + 12 CONTINUE + ELSEIF( IPIV(I) .LT. 0) THEN + IP=-IPIV(I) + DO 13 J= I+1,N + TEMP=A(I,J) + A(I,J)=A(I-1,J) + A(I-1,J)=TEMP + + TEMP=A(IP,J) + A(IP,J)=A(I-1,J) + A(I-1,J)=TEMP + 13 CONTINUE + ENDIF + I=I-2 + END DO + + ELSE +* +* Revert A (A is upper) +* +* +* Revert PERMUTATIONS +* + I=2 + DO WHILE ( I .LT. N-1 ) + IF( IPIV(I) .GT. 0 ) THEN + IP=IPIV(I) + DO J= I+1,N + TEMP=A(IP,J) + A(IP,J)=A(I-1,J) + A(I-1,J)=TEMP + END DO + ELSEIF( IPIV(I) .LT. 0 ) THEN + IP=-IPIV(I) + DO J= I+1,N + TEMP=A(IP,J) + A(IP,J)=A(I-1,J) + A(I-1,J)=TEMP + + TEMP=A(I,J) + A(I,J)=A(I-1,J) + A(I-1,J)=TEMP + END DO + ENDIF + I=I+2 + END DO +* +* Revert VALUE +* + I=N + DO WHILE ( I .GT. 1 ) + A(I-1,I)=E(I) + I=I-2 + END DO + END IF + ELSE +* +* A is LOWER +* + IF ( CONVERT ) THEN +* +* Convert A (A is lower) +* +* +* Convert VALUE +* + I=1 + E(N)=ZERO + DO WHILE ( I .LT. N ) + E(I)=A(I+1,I) + A(I+1,I)=ZERO + I=I+2 + END DO +* +* Convert PERMUTATIONS +* + I=3 + DO WHILE ( I .LT. N ) + IF( IPIV(I) .GT. 0 ) THEN + IP=IPIV(I) + DO 22 J= 1,I-1 + TEMP=A(IP,J) + A(IP,J)=A(I+1,J) + A(I+1,J)=TEMP + 22 CONTINUE + ELSEIF( IPIV(I) .LT. 0 ) THEN + IP=-IPIV(I) + DO 23 J= 1,I-1 + TEMP=A(I,J) + A(I,J)=A(I+1,J) + A(I+1,J)=TEMP + + TEMP=A(IP,J) + A(IP,J)=A(I+1,J) + A(I+1,J)=TEMP + 23 CONTINUE + ENDIF + I=I+2 + END DO + ELSE +* +* Revert A (A is lower) +* +* +* Revert PERMUTATIONS +* + I=N-1 + DO WHILE ( I .GT. 2 ) + IF( IPIV(I) .GT. 0 ) THEN + IP=IPIV(I) + DO J= 1,I-1 + TEMP=A(I+1,J) + A(I+1,J)=A(IP,J) + A(IP,J)=TEMP + END DO + ELSEIF( IPIV(I) .LT. 0 ) THEN + IP=-IPIV(I) + DO J= 1,I-1 + TEMP=A(I+1,J) + A(I+1,J)=A(IP,J) + A(IP,J)=TEMP + + TEMP=A(I+1,J) + A(I+1,J)=A(I,J) + A(I,J)=TEMP + END DO + ENDIF + I=I-2 + END DO +* +* Revert VALUE +* + I=1 + DO WHILE ( I .LT. N ) + A(I+1,I)=E(I) + I=I+2 + END DO + END IF + END IF + + RETURN +* +* End of DKYCONV +* + END diff --git a/SRC/dkyev.f b/SRC/dkyev.f new file mode 100644 index 000000000..412e45ddc --- /dev/null +++ b/SRC/dkyev.f @@ -0,0 +1,291 @@ +*> \brief DKYEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for KY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DKYEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DKYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DKYEV computes all eigenvalues and, optionally, eigenvectors of a +*> real skew-symmetric matrix A. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the skew-symmetric matrix A. If UPLO = 'U', the +*> strictly N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the strictly N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> On exit, if JOBZ = 'V', then if INFO = 0, A is the +*> orthogonal matrix transforming the original skew-symmetric +*> matrix to block skew-symmetric form in W. +*> The eigenvectors of the matrix can be evaluated directly. +*> If JOBZ = 'N', then on exit the strictly lower triangle +*> (if UPLO='L') or the upper triangle (if UPLO='U') of A, +*> is destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the (N-1) lower subdiagonal elements of the +*> block diagonal matrix at front, and zero at last. +*> The matrix consists of 2-by-2 skew-symmetric blocks, and zeros. +*> The values in W, which represent blocks, are always +*> positive, and sorted in descending order. +*> The eigenvalues of each blocks can be evaluated directly. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= max(1,2*N-1). +*> For optimal efficiency, LWORK >= (NB+1)*N, +*> where NB is the blocksize for DKYTRD returned by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of an intermediate tridiagonal +*> form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kyev +* +* ===================================================================== + SUBROUTINE DKYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) +* +* -- LAPACK driver routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, LQUERY, WANTZ + INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, + $ LLWORK, LWKOPT, NB + DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANKY + EXTERNAL ILAENV, LSAME, DLAMCH, DLANKY +* .. +* .. External Subroutines .. + EXTERNAL DLASCL, DORGTR, DSCAL, DKTEQR, DKYTRD, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF +* + IF( INFO.EQ.0 ) THEN + NB = ILAENV( 1, 'DKYTRD', UPLO, N, -1, -1, -1 ) + LWKOPT = MAX( 1, ( NB+1 )*N ) + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY ) + $ INFO = -8 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DKYEV ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + RETURN + END IF +* + IF( N.EQ.1 ) THEN + W( 1 ) = ZERO + WORK( 1 ) = 2 + IF( WANTZ ) + $ A( 1, 1 ) = ONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ANRM = DLANKY( 'M', UPLO, N, A, LDA, WORK ) + ISCALE = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) + $ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) +* +* Call DKYTRD to reduce skew-symmetric matrix to tridiagonal form. +* + INDE = 1 + INDTAU = 1 + INDWRK = INDTAU + N + LLWORK = LWORK - INDWRK + 1 + CALL DKYTRD( UPLO, N, A, LDA, W, WORK( INDTAU ), + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* For eigenvalues only, call DKTEQR, For eigenvectors, first call +* DORGTR to generate the orthogonal matrix, then call DKTEQR. +* + IF( WANTZ ) THEN + CALL DORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), + $ LLWORK, IINFO ) + END IF + IF(.NOT.LOWER) + $ CALL DSCAL(N-1, -ONE, W, 1) + CALL DKTEQR( JOBZ, N, W, A, LDA, WORK( INDTAU ), + $ INFO ) + W(N) = ZERO +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = N + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DKYEV +* + END diff --git a/SRC/dkygs2.f b/SRC/dkygs2.f new file mode 100644 index 000000000..01da408e8 --- /dev/null +++ b/SRC/dkygs2.f @@ -0,0 +1,257 @@ +*> \brief \b DKYGS2 reduces a skew-symmetric definite generalized eigenproblem to standard form, using the factorization results obtained from spotrf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DKYGS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DKYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, ITYPE, LDA, LDB, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DKYGS2 reduces a real skew-symmetric-definite generalized eigenproblem +*> to standard form. +*> +*> If ITYPE = 1, the problem is A*x = lambda*B*x, +*> and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) +*> +*> If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or +*> B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T *A*L. +*> +*> B must have been previously factorized as U**T *U or L*L**T by SPOTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is INTEGER +*> = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); +*> = 2 or 3: compute U*A*U**T or L**T *A*L. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> skew-symmetric matrix A is stored, and how B has been factorized. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the skew-symmetric matrix A. If UPLO = 'U', the +*> strictly n by n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the leading lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> strictly n by n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the leading upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, the transformed matrix, stored in the +*> same format as A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> The triangular factor from the Cholesky factorization of B, +*> as returned by SPOTRF. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kygs2 +* +* ===================================================================== + SUBROUTINE DKYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, ITYPE, LDA, LDB, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, HALF + PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER K + DOUBLE PRECISION BKK +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DSCAL, DKYR2, DTRMV, DTRSV, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN + INFO = -1 + ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DKYGS2', -INFO ) + RETURN + END IF +* + IF( ITYPE.EQ.1 ) THEN + IF( UPPER ) THEN +* +* Compute inv(U**T)*A*inv(U) +* + DO 10 K = 1, N +* +* Update the upper triangle of A(k:n,k:n) +* + BKK = B( K, K ) + IF( K.LT.N ) THEN + CALL DSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA ) + CALL DKYR2( UPLO, N-K, -ONE, A( K, K+1 ), LDA, + $ B( K, K+1 ), LDB, A( K+1, K+1 ), LDA ) + CALL DTRSV( UPLO, 'Transpose', 'Non-unit', N-K, + $ B( K+1, K+1 ), LDB, A( K, K+1 ), LDA ) + END IF + 10 CONTINUE + ELSE +* +* Compute inv(L)*A*inv(L**T) +* + DO 20 K = 1, N +* +* Update the lower triangle of A(k:n,k:n) +* + BKK = B( K, K ) + IF( K.LT.N ) THEN + CALL DSCAL( N-K, ONE / BKK, A( K+1, K ), 1 ) + CALL DKYR2( UPLO, N-K, ONE, A( K+1, K ), 1, + $ B( K+1, K ), 1, A( K+1, K+1 ), LDA ) + CALL DTRSV( UPLO, 'No transpose', 'Non-unit', N-K, + $ B( K+1, K+1 ), LDB, A( K+1, K ), 1 ) + END IF + 20 CONTINUE + END IF + ELSE + IF( UPPER ) THEN +* +* Compute U*A*U**T +* + DO 30 K = 1, N +* +* Update the upper triangle of A(1:k,1:k) +* + BKK = B( K, K ) + CALL DTRMV( UPLO, 'No transpose', 'Non-unit', K-1, B, + $ LDB, A( 1, K ), 1 ) + CALL DKYR2( UPLO, K-1, -ONE, A( 1, K ), 1, B( 1, K ), 1, + $ A, LDA ) + CALL DSCAL( K-1, BKK, A( 1, K ), 1 ) + 30 CONTINUE + ELSE +* +* Compute L**T *A*L +* + DO 40 K = 1, N +* +* Update the lower triangle of A(1:k,1:k) +* + BKK = B( K, K ) + CALL DTRMV( UPLO, 'Transpose', 'Non-unit', K-1, B, LDB, + $ A( K, 1 ), LDA ) + CALL DKYR2( UPLO, K-1, ONE, A( K, 1 ), LDA, B( K, 1 ), + $ LDB, A, LDA ) + CALL DSCAL( K-1, BKK, A( K, 1 ), LDA ) + 40 CONTINUE + END IF + END IF + RETURN +* +* End of DKYGS2 +* + END diff --git a/SRC/dkygst.f b/SRC/dkygst.f new file mode 100644 index 000000000..faaa17444 --- /dev/null +++ b/SRC/dkygst.f @@ -0,0 +1,319 @@ +*> \brief \b DKYGST +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DKYGST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DKYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, ITYPE, LDA, LDB, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DKYGST reduces a real skew-symmetric-definite generalized eigenproblem +*> to standard form. +*> +*> If ITYPE = 1, the problem is A*x = lambda*B*x, +*> and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) +*> +*> If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or +*> B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L. +*> +*> B must have been previously factorized as U**T*U or L*L**T by SPOTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is INTEGER +*> = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); +*> = 2 or 3: compute U*A*U**T or L**T*A*L. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored and B is factored as +*> U**T*U; +*> = 'L': Lower triangle of A is stored and B is factored as +*> L*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the skew-symmetric matrix A. If UPLO = 'U', the +*> strictly N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the leading lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> strictly N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the leading upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, the transformed matrix, stored in the +*> same format as A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,N) +*> The triangular factor from the Cholesky factorization of B, +*> as returned by SPOTRF. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kygst +* +* ===================================================================== + SUBROUTINE DKYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, ITYPE, LDA, LDB, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, HALF + PARAMETER ( ONE = 1.0, HALF = 0.5 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER K, KB, NB +* .. +* .. External Subroutines .. + EXTERNAL DKYGS2, DKYMM, DKYR2K, DTRMM, DTRSM, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN + INFO = -1 + ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DKYGST', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'DKYGST', UPLO, N, -1, -1, -1 ) +* + IF( NB.LE.1 .OR. NB.GE.N ) THEN +* +* Use unblocked code +* + CALL DKYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) + ELSE +* +* Use blocked code +* + IF( ITYPE.EQ.1 ) THEN + IF( UPPER ) THEN +* +* Compute inv(U**T)*A*inv(U) +* + DO 10 K = 1, N, NB + KB = MIN( N-K+1, NB ) +* +* Update the upper triangle of A(k:n,k:n) +* + CALL DKYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, + $ B( K, K ), LDB, INFO ) + IF( K+KB.LE.N ) THEN + CALL DTRSM( 'Left', UPLO, 'Transpose', 'Non-unit', + $ KB, N-K-KB+1, ONE, B( K, K ), LDB, + $ A( K, K+KB ), LDA ) + CALL DKYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, + $ A( K, K ), LDA, B( K, K+KB ), LDB, ONE, + $ A( K, K+KB ), LDA ) + CALL DKYR2K( UPLO, 'Transpose', N-K-KB+1, KB, -ONE, + $ A( K, K+KB ), LDA, B( K, K+KB ), LDB, + $ ONE, A( K+KB, K+KB ), LDA ) + CALL DKYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, + $ A( K, K ), LDA, B( K, K+KB ), LDB, ONE, + $ A( K, K+KB ), LDA ) + CALL DTRSM( 'Right', UPLO, 'No transpose', + $ 'Non-unit', KB, N-K-KB+1, ONE, + $ B( K+KB, K+KB ), LDB, A( K, K+KB ), + $ LDA ) + END IF + 10 CONTINUE + ELSE +* +* Compute inv(L)*A*inv(L**T) +* + DO 20 K = 1, N, NB + KB = MIN( N-K+1, NB ) +* +* Update the lower triangle of A(k:n,k:n) +* + CALL DKYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, + $ B( K, K ), LDB, INFO ) + IF( K+KB.LE.N ) THEN + CALL DTRSM( 'Right', UPLO, 'Transpose', 'Non-unit', + $ N-K-KB+1, KB, ONE, B( K, K ), LDB, + $ A( K+KB, K ), LDA ) + CALL DKYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, + $ A( K, K ), LDA, B( K+KB, K ), LDB, ONE, + $ A( K+KB, K ), LDA ) + CALL DKYR2K( UPLO, 'No transpose', N-K-KB+1, KB, + $ ONE, A( K+KB, K ), LDA, B( K+KB, K ), + $ LDB, ONE, A( K+KB, K+KB ), LDA ) + CALL DKYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, + $ A( K, K ), LDA, B( K+KB, K ), LDB, ONE, + $ A( K+KB, K ), LDA ) + CALL DTRSM( 'Left', UPLO, 'No transpose', + $ 'Non-unit', N-K-KB+1, KB, ONE, + $ B( K+KB, K+KB ), LDB, A( K+KB, K ), + $ LDA ) + END IF + 20 CONTINUE + END IF + ELSE + IF( UPPER ) THEN +* +* Compute U*A*U**T +* + DO 30 K = 1, N, NB + KB = MIN( N-K+1, NB ) +* +* Update the upper triangle of A(1:k+kb-1,1:k+kb-1) +* + CALL DTRMM( 'Left', UPLO, 'No transpose', 'Non-unit', + $ K-1, KB, ONE, B, LDB, A( 1, K ), LDA ) + CALL DKYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), + $ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA ) + CALL DKYR2K( UPLO, 'No transpose', K-1, KB, -ONE, + $ A( 1, K ), LDA, B( 1, K ), LDB, ONE, A, + $ LDA ) + CALL DKYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), + $ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA ) + CALL DTRMM( 'Right', UPLO, 'Transpose', 'Non-unit', + $ K-1, KB, ONE, B( K, K ), LDB, A( 1, K ), + $ LDA ) + CALL DKYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, + $ B( K, K ), LDB, INFO ) + 30 CONTINUE + ELSE +* +* Compute L**T*A*L +* + DO 40 K = 1, N, NB + KB = MIN( N-K+1, NB ) +* +* Update the lower triangle of A(1:k+kb-1,1:k+kb-1) +* + CALL DTRMM( 'Right', UPLO, 'No transpose', 'Non-unit', + $ KB, K-1, ONE, B, LDB, A( K, 1 ), LDA ) + CALL DKYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), + $ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA ) + CALL DKYR2K( UPLO, 'Transpose', K-1, KB, ONE, + $ A( K, 1 ), LDA, B( K, 1 ), LDB, ONE, A, + $ LDA ) + CALL DKYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), + $ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA ) + CALL DTRMM( 'Left', UPLO, 'Transpose', 'Non-unit', KB, + $ K-1, ONE, B( K, K ), LDB, A( K, 1 ), LDA ) + CALL DKYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, + $ B( K, K ), LDB, INFO ) + 40 CONTINUE + END IF + END IF + END IF + RETURN +* +* End of DKYGST +* + END diff --git a/SRC/dkygv.f b/SRC/dkygv.f new file mode 100644 index 000000000..670f9e872 --- /dev/null +++ b/SRC/dkygv.f @@ -0,0 +1,320 @@ +*> \brief \b DKYGV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DKYGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DKYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, ITYPE, LDA, LDB, LWORK, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DKYGV computes all the eigenvalues, and optionally, the eigenvectors +*> of a real generalized skew-symmetric-definite eigenproblem, of the form +*> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. +*> Here A is assumed to be skew-symmetric and B is assumed to be symmetric +*> positive definite. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is INTEGER +*> Specifies the problem type to be solved: +*> = 1: A*x = (lambda)*B*x +*> = 2: A*B*x = (lambda)*x +*> = 3: B*A*x = (lambda)*x +*> \endverbatim +*> +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangles of A and B are stored; +*> = 'L': Lower triangles of A and B are stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> On entry, the skew-symmetric matrix A. If UPLO = 'U', +*> the strictly N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the strictly N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> +*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the +*> matrix Z, which leads to the block diagonal form in W. +*> The matrix are normalized as follows: +*> if ITYPE = 1 or 2, Z**T*B*Z = I; +*> if ITYPE = 3, Z**T*inv(B)*Z = I. +*> The eigenvectors of the matrix can be evaluated directly. +*> If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') +*> or the lower triangle (if UPLO='L') of A, including the +*> diagonal, is destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB, N) +*> On entry, the symmetric positive definite matrix B. +*> If UPLO = 'U', the leading N-by-N upper triangular part of B +*> contains the upper triangular part of the matrix B. +*> If UPLO = 'L', the leading N-by-N lower triangular part of B +*> contains the lower triangular part of the matrix B. +*> +*> On exit, if INFO <= N, the part of B containing the matrix is +*> overwritten by the triangular factor U or L from the Cholesky +*> factorization B = U**T*U or B = L*L**T. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (N) +*> If INFO = 0, the (N-1) lower subdiagonal elements of the +*> block diagonal matrix at front, and zero at last. +*> The matrix consists of 2-by-2 skew-symmetric blocks, and zeros. +*> The values in W, which represent blocks, are always +*> positive, and sorted in descending order. +*> The eigenvalues of each blocks can be evaluated directly. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= max(1,3*N-1). +*> For optimal efficiency, LWORK >= (NB+2)*N, +*> where NB is the blocksize for SSYTRD returned by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: DPOTRF or DKYEV returned an error code: +*> <= N: if INFO = i, DKYEV failed to converge; +*> i off-diagonal elements of an intermediate +*> tridiagonal form did not converge to zero; +*> > N: if INFO = N + i, for 1 <= i <= N, then the leading +*> minor of order i of B is not positive definite. +*> The factorization of B could not be completed and +*> no eigenvalues or eigenvectors were computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kygv +* +* ===================================================================== + SUBROUTINE DKYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, ITYPE, LDA, LDB, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER, WANTZ + CHARACTER TRANS + INTEGER LWKMIN, LWKOPT, NB, NEIG +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DPOTRF, DKYEV, DKYGST, DTRMM, DTRSM, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN + INFO = -1 + ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + LWKMIN = MAX( 1, 2*N - 1 ) + NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 ) + LWKOPT = MAX( LWKMIN, ( NB + 1 )*N ) + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN + INFO = -11 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DKYGV ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Form a Cholesky factorization of B. +* + CALL DPOTRF( UPLO, N, B, LDB, INFO ) + IF( INFO.NE.0 ) THEN + INFO = N + INFO + RETURN + END IF +* +* Transform problem to standard eigenvalue problem and solve. +* + CALL DKYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) + CALL DKYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) +* + IF( WANTZ ) THEN +* +* Backtransform eigenvectors to the original problem. +* + NEIG = N + IF( INFO.GT.0 ) + $ NEIG = INFO - 1 + IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN +* +* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; +* backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y +* + IF( UPPER ) THEN + TRANS = 'N' + ELSE + TRANS = 'T' + END IF +* + CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, + $ ONE, + $ B, LDB, A, LDA ) +* + ELSE IF( ITYPE.EQ.3 ) THEN +* +* For B*A*x=(lambda)*x; +* backtransform eigenvectors: x = L*y or U**T*y +* + IF( UPPER ) THEN + TRANS = 'T' + ELSE + TRANS = 'N' + END IF +* + CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, + $ ONE, + $ B, LDB, A, LDA ) + END IF + END IF +* + WORK( 1 ) = LWKOPT + RETURN +* +* End of DKYGV +* + END diff --git a/SRC/dkysv.f b/SRC/dkysv.f new file mode 100644 index 000000000..87eba7595 --- /dev/null +++ b/SRC/dkysv.f @@ -0,0 +1,282 @@ +*> \brief DKYSV computes the solution to system of linear equations A * X = B for KY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DKYSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DKYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DKYSV computes the solution to a real system of linear equations +*> A * X = B, +*> where A is an N-by-N skew-symmetric matrix and X and B are N-by-NRHS +*> matrices. +*> +*> The partial pivoting method is used to factor A as +*> A = U * D * U**T, if UPLO = 'U', or +*> A = L * D * L**T, if UPLO = 'L', +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and D is skew-symmetric and block diagonal with +*> 1-by-1 and 2-by-2 diagonal blocks. All 2-by-2 diagonal blocks are +*> nonsingular and all 1-by-1 diagonal blocks are 0. If N is odd, there +*> is at least one 1-by-1 diagonal block. The factored form of A is then +*> used to solve the system of equations A * X = B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the skew-symmetric matrix A. If UPLO = 'U', the strictly +*> upper triangular part of A contains the upper +*> triangular part of the matrix A, and the leading N-by-N lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> strictly lower triangular part of A contains the lower +*> triangular part of the matrix A, and the leading N-by-N upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, the block diagonal matrix D and the +*> multipliers used to obtain the factor U or L from the +*> factorization A = U*D*U**T or A = L*D*L**T as computed by +*> DKYTRF. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges of D, as determined by DKYTRF. +*> +*> The elements of array IPIV are combined in pair, and the first +*> (if UPLO = 'U') or the second (if UPLO = 'L') element in +*> the pair always keeps the value 0. If N is odd, the first +*> (if UPLO = 'U') or the last (if UPLO = 'L') element of IPIV is +*> 0, which is the only element not in pair. So we only use the +*> first (if UPLO = 'L') or the second (if UPLO = 'U') element in +*> the pair to determine the interchanges. +*> +*> If IPIV(k) +*> = 0: there was no interchange. +*> > 0: rows and columns k-1 and IPIV(k) were interchanged, if +*> UPLO = 'U', and rows and columns k+1 and IPIV(k) were +*> interchanged, if UPLO = 'L'. +*> < 0: rows and columns k and k-1 were interchanged, +*> then rows and columns k-1 and -IPIV(k) were interchanged, if +*> UPLO = 'U', and rows and columns k and k+1 were interchanged, +*> then rows and columns k+1 and -IPIV(k) were interchanged, if +*> UPLO = 'L'. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= 1, and for best performance +*> LWORK >= max(1,N*NB), where NB is the optimal blocksize for +*> DKYTRF. +*> for LWORK < N, TRS will be done with Level BLAS 2 +*> for LWORK >= N, TRS will be done with Level BLAS 3 +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i-1,i) (if UPLO = 'U') or D(i+1,i) (if UPLO = 'L') +*> is exactly zero. The factorization has been completed, +*> but the block diagonal matrix D is exactly singular, +*> so the solution could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kysv +* +* ===================================================================== + SUBROUTINE DKYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DKYTRF, DKYTRS, DKYTRS2 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. + $ .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + CALL DKYTRF( UPLO, N, A, LDA, IPIV, WORK, -1, INFO ) + LWKOPT = INT( WORK( 1 ) ) + END IF + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DKYSV ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = U*D*U**T or A = L*D*L**T. +* + CALL DKYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* + IF ( LWORK.LT.N ) THEN +* +* Solve with TRS ( Use Level BLAS 2) +* + CALL DKYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* + ELSE +* +* Solve with TRS2 ( Use Level BLAS 3) +* + CALL DKYTRS2( UPLO,N,NRHS,A,LDA,IPIV,B,LDB,WORK,INFO ) +* + END IF +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DKYSV +* + END diff --git a/SRC/dkyswapr.f b/SRC/dkyswapr.f new file mode 100644 index 000000000..662b1c13e --- /dev/null +++ b/SRC/dkyswapr.f @@ -0,0 +1,172 @@ +*> \brief \b DKYSWAPR applies an elementary permutation on the rows and columns of a skew-symmetric matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DKYSWAPR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DKYSWAPR( UPLO, N, A, LDA, I1, I2) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER I1, I2, LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, N ) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DKYSWAPR applies an elementary permutation on the rows and the columns of +*> a skew-symmetric matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,*) +*> On entry, the N-by-N matrix A. On exit, the permuted matrix +*> where the rows I1 and I2 and columns I1 and I2 are interchanged. +*> If UPLO = 'U', the interchanges are applied to the upper +*> triangular part and the strictly lower triangular part of A is +*> not referenced; if UPLO = 'L', the interchanges are applied to +*> the lower triangular part and the part of A above the diagonal +*> is not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] I1 +*> \verbatim +*> I1 is INTEGER +*> Index of the first row to swap +*> \endverbatim +*> +*> \param[in] I2 +*> \verbatim +*> I2 is INTEGER +*> Index of the second row to swap +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kyswapr +* +* ===================================================================== + SUBROUTINE DKYSWAPR( UPLO, N, A, LDA, I1, I2) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER I1, I2, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL UPPER + DOUBLE PRECISION TMP +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DSWAP, DSCAL +* .. +* .. Executable Statements .. +* + UPPER = LSAME( UPLO, 'U' ) + IF (UPPER) THEN +* +* UPPER +* first swap +* - swap column I1 and I2 from I1 to I1-1 + CALL DSWAP( I1-1, A(1,I1), 1, A(1,I2), 1 ) +* +* second swap : +* - swap row I1 from I1+1 to I2-1 with col I2 from I1+1 to I2-1 +* + CALL DSWAP( I2-I1-1, A(I1,I1+1), LDA, A(I1+1,I2), 1 ) + CALL DSCAL( I2-I1, -ONE, A(I1,I2), 1) + CALL DSCAL( I2-I1-1, -ONE, A(I1,I1+1), LDA ) +* +* third swap +* - swap row I1 and I2 from I2+1 to N + IF ( I2.LT.N ) + $ CALL DSWAP( N-I2, A(I1,I2+1), LDA, A(I2,I2+1), LDA ) +* + ELSE +* +* LOWER +* first swap +* - swap row I1 and I2 from I1 to I1-1 + CALL DSWAP( I1-1, A(I1,1), LDA, A(I2,1), LDA ) +* +* second swap : +* - swap col I1 from I1+1 to I2-1 with row I2 from I1+1 to I2-1 +* + CALL DSWAP( I2-I1-1, A(I1+1,I1), 1, A(I2,I1+1), LDA ) + CALL DSCAL( I2-I1, -ONE, A(I1+1,I1), 1) + CALL DSCAL( I2-I1-1, -ONE, A(I2,I1+1), LDA ) +* +* third swap +* - swap col I1 and I2 from I2+1 to N + IF ( I2.LT.N ) + $ CALL DSWAP( N-I2, A(I2+1,I1), 1, A(I2+1,I2), 1 ) +* + ENDIF + END SUBROUTINE DKYSWAPR + diff --git a/SRC/dkytd2.f b/SRC/dkytd2.f new file mode 100644 index 000000000..bf91d418c --- /dev/null +++ b/SRC/dkytd2.f @@ -0,0 +1,300 @@ +*> \brief \b DKYTD2 reduces a skew-symmetric matrix to real skew-symmetric tridiagonal form by an orthogonal similarity transformation (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DKYTD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DKYTD2( UPLO, N, A, LDA, E, TAU, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DKYTD2 reduces a real skew-symmetric matrix A to skew-symmetric tridiagonal +*> form T by an orthogonal similarity transformation: Q**T * A * Q = T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> skew-symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the skew-symmetric matrix A. If UPLO = 'U', the strictly +*> n-by-n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the leading lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> strictly n-by-n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the leading upper +*> triangular part of A is not referenced. +*> On exit, if UPLO = 'U', the diagonal and first superdiagonal +*> of A are overwritten by the corresponding elements of the +*> tridiagonal matrix T, and the elements above the first +*> superdiagonal, with the array TAU, represent the orthogonal +*> matrix Q as a product of elementary reflectors; if UPLO +*> = 'L', the diagonal and first subdiagonal of A are over- +*> written by the corresponding elements of the tridiagonal +*> matrix T, and the elements below the first subdiagonal, with +*> the array TAU, represent the orthogonal matrix Q as a product +*> of elementary reflectors. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> The off-diagonal elements of the tridiagonal matrix T: +*> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (N-1) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kytd2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', the matrix Q is represented as a product of elementary +*> reflectors +*> +*> Q = H(n-1) . . . H(2) H(1). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in +*> A(1:i-1,i+1), and tau in TAU(i). +*> +*> If UPLO = 'L', the matrix Q is represented as a product of elementary +*> reflectors +*> +*> Q = H(1) H(2) . . . H(n-1). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), +*> and tau in TAU(i). +*> +*> The contents of A on exit are illustrated by the following examples +*> with n = 5: +*> +*> if UPLO = 'U': if UPLO = 'L': +*> +*> ( 0 e v2 v3 v4 ) ( 0 ) +*> ( 0 e v3 v4 ) ( e 0 ) +*> ( 0 e v4 ) ( v1 e 0 ) +*> ( 0 e ) ( v1 v2 e 0 ) +*> ( 0 ) ( v1 v2 v3 e 0 ) +*> +*> where d and e denote diagonal and off-diagonal elements of T, and vi +*> denotes an element of the vector defining H(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DKYTD2( UPLO, N, A, LDA, E, TAU, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO, HALF + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, + $ HALF = 1.0D0 / 2.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I + DOUBLE PRECISION ALPHA, TAUI +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DLARFG, DKYMV, DKYR2, XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .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 = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DKYTD2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Reduce the upper triangle of A +* + DO 10 I = N - 1, 1, -1 +* +* Generate elementary reflector H(i) = I - tau * v * v**T +* to annihilate A(1:i-1,i+1) +* + CALL DLARFG( I, A( I, I+1 ), A( 1, I+1 ), 1, TAUI ) + E( I ) = A( I, I+1 ) +* + IF( TAUI.NE.ZERO ) THEN +* +* Apply H(i) from both sides to A(1:i,1:i) +* + A( I, I+1 ) = ONE +* +* Compute x := tau * A * v storing x in TAU(1:i) +* + CALL DKYMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, + $ ZERO, + $ TAU, 1 ) +* +* Apply the transformation as a rank-2 update: +* A := A + v * x**T - x * v**T +* + CALL DKYR2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A, + $ LDA ) +* + A( I, I+1 ) = E( I ) + END IF + TAU( I ) = TAUI + 10 CONTINUE + ELSE +* +* Reduce the lower triangle of A +* + DO 20 I = 1, N - 1 +* +* Generate elementary reflector H(i) = I - tau * v * v**T +* to annihilate A(i+2:n,i) +* + CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, + $ TAUI ) + E( I ) = A( I+1, I ) +* + IF( TAUI.NE.ZERO ) THEN +* +* Apply H(i) from both sides to A(i+1:n,i+1:n) +* + A( I+1, I ) = ONE +* +* Compute x := tau * A * v storing y in TAU(i:n-1) +* + CALL DKYMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA, + $ A( I+1, I ), 1, ZERO, TAU( I ), 1 ) +* +* Apply the transformation as a rank-2 update: +* A := A + v * x**T - x * v**T +* + CALL DKYR2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), + $ 1, + $ A( I+1, I+1 ), LDA ) +* + A( I+1, I ) = E( I ) + END IF + TAU( I ) = TAUI + 20 CONTINUE + END IF +* + RETURN +* +* End of DKYTD2 +* + END diff --git a/SRC/dkytf2.f b/SRC/dkytf2.f new file mode 100644 index 000000000..fa92c9f3f --- /dev/null +++ b/SRC/dkytf2.f @@ -0,0 +1,586 @@ +*> \brief \b DKYTF2 computes the factorization of a real skew-symmetric matrix, using the Bunch partial pivoting method (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DKYTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DKYTF2( UPLO, N, A, LDA, IPIV, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DKYTF2 computes the factorization of a real skew-symmetric matrix A using +*> the Bunch block diagonal pivoting method: +*> +*> A = U*D*U**T or A = L*D*L**T +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, U**T is the transpose of U, and D is skew-symmetric +*> and block diagonal with 1-by-1 and 2-by-2 diagonal blocks. All 2-by-2 +*> diagonal blocks are nonsingular and all 1-by-1 diagonal blocks are 0. +*> If N is odd, there is at least one 1-by-1 diagonal block. +*> +*> This is the unblocked version of the algorithm, calling Level 2 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> skew-symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the skew-symmetric matrix A. If UPLO = 'U', the +*> strictly upper triangular part of A contains the upper +*> triangular part of the matrix A, and the leading N-by-N lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> strictly lower triangular part of A contains the lower +*> triangular part of the matrix A, and the leading N-by-N upper +*> triangular part of A is not referenced. +*> +*> On exit, the block diagonal matrix D and the multipliers used +*> to obtain the factor U or L (see below for further details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> The elements of array IPIV are combined in pair, and the first +*> element in the pair always keeps the value 0. If N is odd, the +*> first element of IPIV is 0, which is the only element not in pair. +*> So we only use the second element in the pair to determine the +*> interchanges. +*> +*> If IPIV(k) +*> = 0: there was no interchange. +*> > 0: rows and columns k-1 and IPIV(k) were interchanged. +*> < 0: rows and columns k and k-1 were interchanged, +*> then rows and columns k-1 and -IPIV(k) were interchanged. +*> +*> If UPLO = 'L': +*> The elements of array IPIV are combined in pair, and the second +*> element in the pair always keeps the value 0. If N is odd, the +*> last element of IPIV is 0, which is the only element not in pair. +*> So we only use the first element in the pair to determine the +*> interchanges. +*> +*> If IPIV(k) +*> = 0: there was no interchange. +*> > 0: rows and columns k+1 and IPIV(k) were interchanged。 +*> < 0: rows and columns k and k+1 were interchanged, +*> then rows and columns k+1 and -IPIV(k) were interchanged. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i-1,i) (if UPLO = 'U') or D(i+1,i) (if UPLO = 'L') +*> is exactly zero. The factorization has been completed, +*> but the block diagonal matrix D is exactly singular, +*> so the solution could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kytf2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', then A = U*D*U**T, where +*> U = P(n)*U(n)* ... *P(k)U(k)* ..., +*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to +*> 1 in steps of 2, and D is a block diagonal matrix with 2-by-2 +*> diagonal blocks D(k). P(k) is a permutation matrix as defined by +*> IPIV(k), and U(k) is a unit upper triangular matrix, such that if +*> the diagonal block D(k) is of order 2, namely s = 2, then +*> +*> ( I v 0 ) k-s +*> U(k) = ( 0 I 0 ) s +*> ( 0 0 I ) n-k +*> k-s s n-k +*> +*> The strictly upper triangle of D(k) overwrites A(k-1,k), and v overwrites +*> A(1:k-2,k-1:k). +*> +*> If UPLO = 'L', then A = L*D*L**T, where +*> L = P(1)*L(1)* ... *P(k)*L(k)* ..., +*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to +*> n in steps of 2, and D is a block diagonal matrix with 2-by-2 +*> diagonal blocks D(k). P(k) is a permutation matrix as defined by +*> IPIV(k), and L(k) is a unit lower triangular matrix, such that if +*> the diagonal block D(k) is of order 2, namely s = 2, then +*> +*> ( I 0 0 ) k-1 +*> L(k) = ( 0 I 0 ) s +*> ( 0 v I ) n-k-s+1 +*> k-1 s n-k-s+1 +*> +*> The strictly lower triangle of D(k) overwrites A(k+1,k), and v overwrites +*> A(k+2:n,k:k+1). +*> +*> Remind that if n is odd, A is always singular. +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> 09-29-06 - patch from +*> Bobby Cheng, MathWorks +*> +*> Replace l.204 and l.372 +*> IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +*> by +*> IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN +*> +*> 01-01-96 - Based on modifications by +*> J. Lewis, Boeing Computer Services Company +*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA +*> 1-96 - Based on modifications by J. Lewis, Boeing Computer Services +*> Company +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DKYTF2( UPLO, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, IMAX1, IMAX2, J,KSTEP + DOUBLE PRECISION ABSAKP1K, COLMAX1, COLMAX2, + $ D21, T, WK, WKM1, WKP1 +* .. +* .. External Functions .. + LOGICAL LSAME, DISNAN + INTEGER IDAMAX + EXTERNAL LSAME, IDAMAX, DISNAN +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSWAP, DSYR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .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 = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DKYTF2', -INFO ) + RETURN + END IF + + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* K is the main loop index, decreasing from N to 1 in steps +* of 2 +* + K = N + 10 CONTINUE +* +* If K <= 1, exit from loop +* + IF( K.EQ.1 ) THEN + IF( INFO.EQ.0 ) + $ INFO = K + KP = 0 + IPIV( K ) = KP + GO TO 70 + END IF + + IF( K.LT.1 ) + $ GO TO 70 + KSTEP = 2 +* +* Determine rows and columns to be interchanged +* + ABSAKP1K = ABS( A( K-1, K ) ) +* +* IMAX1 is the row-index of the absolute value largest element in +* row 1 to K-2, column K. +* IMAX2 is the row-index of the absolute value largest element in +* row 1 to K-2 column K-1. +* COLMAX1 and COLMAX2 are their absolute values. +* + IF(K.GT.2) THEN + IMAX1 = IDAMAX( K-2, A( 1, K ), 1 ) + COLMAX1 = ABS( A( IMAX1, K ) ) + IMAX2 = IDAMAX( K-2, A( 1, K-1 ), 1 ) + COLMAX2 = ABS( A( IMAX2, K-1 ) ) + ELSE + IMAX1 = 0 + COLMAX1 = ZERO + IMAX2 = 0 + COLMAX2 = ZERO + ENDIF +* + IF( MAX(MAX( ABSAKP1K, COLMAX1 ), COLMAX2).EQ.ZERO ) THEN +* +* Column K and K+1 is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = 0 + IPIV( K ) = KP + ELSE + IF( ABSAKP1K.GE.MAX( COLMAX1, COLMAX2 ) ) THEN +* +* No interchange +* + KP = 0 + IPIV( K ) = KP + ELSE + IF( COLMAX1.GE.COLMAX2 ) THEN + +* +* Absolute value largest element is in column K +* Interchange rows and columns K-1 and IMAX1 +* + KP = IMAX1 + IPIV( K ) = KP + + CALL DSWAP( K-IMAX1-2, A( IMAX1, IMAX1+1 ), LDA, + $ A( IMAX1+1, K-1 ), 1 ) + + CALL DSCAL( K-IMAX1-2, -ONE, A( IMAX1, IMAX1+1 ), + $ LDA ) + + CALL DSCAL( K-IMAX1-2, -ONE, A( IMAX1+1, K-1 ), + $ 1 ) + + CALL DSWAP( IMAX1-1, A( 1, IMAX1 ), 1, + $ A( 1, K-1 ), 1 ) + + A( IMAX1, K-1 ) = -A( IMAX1, K-1 ) + +* +* Interchange rows K-1 and IMAX1 in column K of A +* + T = A( K-1, K ) + A( K-1, K ) = A( IMAX1, K ) + A( IMAX1, K ) = T + ELSE +* +* Absolute value largest element is in column K-1 +* Interchange rows and columns K and K-1, then Interchange K-1 and IMAX2 +* + KP = -IMAX2 + IPIV( K ) = KP + + CALL DSWAP( K-2, A( 1, K ), 1, A( 1, K-1 ), + $ 1 ) + + A( K-1, K ) = -A( K-1, K ) + + CALL DSWAP( K-IMAX2-2, A( IMAX2, IMAX2+1 ), LDA, + $ A( IMAX2+1, K-1 ), 1 ) + + CALL DSCAL( K-IMAX2-2, -ONE, A( IMAX2, IMAX2+1 ), + $ LDA ) + + CALL DSCAL( K-IMAX2-2, -ONE, A( IMAX2+1, K-1 ), + $ 1 ) + + CALL DSWAP( IMAX2-1, A( 1, IMAX2 ), 1, + $ A( 1, K-1 ), 1 ) + + A( IMAX2, K-1 ) = -A( IMAX2, K-1 ) +* +* Interchange rows K-1 and IMAX2 in column K of A +* + T = A( K-1, K ) + A( K-1, K ) = A( IMAX2, K ) + A( IMAX2, K ) = T +* + END IF + END IF +* +* Update the lower triangle of A11 (= A(1:k-2,1:k-2)) +* + D21 = ONE/A( K-1, K ) + + DO 20 J = 1, K-2 +* + WK = -A( J, K-1 )*D21 + WKM1 = A( J, K )*D21 +* + DO 30 I = J+1, K-2 + A( J, I ) = A( J, I ) + A( I, K )*WK + + $ A( I, K-1 )*WKM1 + 30 CONTINUE + + 20 CONTINUE + +* +* Update C*S^-1 +* + DO 80 J = 1, K-2 + T = A( J, K-1 ) + A( J, K-1 ) = A( J, K )*D21 + A( J, K ) = -T*D21 + 80 CONTINUE + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* K is the main loop index, increasing from 1 to N in steps +* of 2 +* + K = 1 + 40 CONTINUE +* +* If K >= N, exit from loop +* + IF( K.EQ.N ) THEN + IF( INFO.EQ.0 ) + $ INFO = K + KP = 0 + IPIV( K ) = KP + GO TO 70 + END IF + + IF( K.GT.N ) + $ GO TO 70 + KSTEP = 2 +* +* Determine rows and columns to be interchanged +* + ABSAKP1K = ABS( A( K+1, K ) ) +* +* IMAX1 is the row-index of the absolute value largest element in +* row K+2 to N, column K. +* IMAX2 is the row-index of the absolute value largest element in +* row K+2 to N, column K+1. +* COLMAX1 and COLMAX2 are their absolute values. +* + IF(K.LT.N-1) THEN + IMAX1 = K+1 + IDAMAX( N-K-1, A( K+2, K ), 1 ) + COLMAX1 = ABS( A( IMAX1, K ) ) + IMAX2 = K+1 + IDAMAX( N-K-1, A( K+2, K+1 ), 1 ) + COLMAX2 = ABS( A( IMAX2, K+1 ) ) + ELSE + IMAX1 = 0 + COLMAX1 = ZERO + IMAX2 = 0 + COLMAX2 = ZERO + ENDIF +* + IF( MAX(MAX( ABSAKP1K, COLMAX1 ), COLMAX2).EQ.ZERO ) THEN +* +* Column K and K+1 is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = 0 + IPIV( K ) = KP + + ELSE + IF( ABSAKP1K.GE.MAX( COLMAX1, COLMAX2 ) ) THEN +* +* no interchange +* + KP = 0 + IPIV( K ) = KP + + ELSE + IF( COLMAX1.GE.COLMAX2 ) THEN +* +* Absolute value largest element is in column K +* Interchange rows and columns K+1 and IMAX1 +* + KP = IMAX1 + IPIV( K ) = KP + + CALL DSWAP( IMAX1-K-2, A( IMAX1, K+2 ), LDA, + $ A( K+2, K+1 ), 1 ) + + CALL DSCAL( IMAX1-K-2, -ONE, A( IMAX1, K+2 ), + $ LDA ) + + CALL DSCAL( IMAX1-K-2, -ONE, A( K+2, K+1 ), + $ 1 ) + + CALL DSWAP( N-IMAX1, A( IMAX1+1, IMAX1 ), 1, + $ A( IMAX1+1, K+1 ), 1 ) + + A( IMAX1, K+1 ) = -A( IMAX1, K+1 ) +* +* Interchange rows K+1 and IMAX1 in column K of A +* + T = A( K+1, K ) + A( K+1, K ) = A( IMAX1, K ) + A( IMAX1, K ) = T +* + ELSE +* +* Absolute value largest element is in column K+1 +* Interchange rows and columns K and K+1, then Interchange K+1 and IMAX2 +* + KP = -IMAX2 + IPIV( K ) = KP + + CALL DSWAP( N-K-1, A( K+2, K ), 1, A( K+2, K+1 ), + $ 1 ) + + A( K+1, K ) = -A( K+1, K ) + + CALL DSWAP( IMAX2-K-2, A( IMAX2, K+2 ), LDA, + $ A( K+2, K+1 ), 1 ) + + CALL DSCAL( IMAX2-K-2, -ONE, A( IMAX2, K+2 ), + $ LDA ) + + CALL DSCAL( IMAX2-K-2, -ONE, A( K+2, K+1 ), + $ 1 ) + + CALL DSWAP( N-IMAX2, A( IMAX2+1, IMAX2 ), 1, + $ A( IMAX2+1, K+1 ), 1 ) + + A( IMAX2, K+1 ) = -A( IMAX2, K+1 ) +* +* Interchange rows K+1 and IMAX2 in column K of A +* + T = A( K+1, K ) + A( K+1, K ) = A( IMAX2, K ) + A( IMAX2, K ) = T +* + END If + END If + +* +* Update the lower triangle of A22 (= A(k+2:n,k+2:n)) +* + D21 = ONE/A( K+1, K ) + + DO 60 J = K+2, N +* + WK = -A( J, K+1 )*D21 + WKP1 = A( J, K )*D21 +* + DO 50 I = K+2, J-1 + A( J, I ) = A( J, I ) + A( I, K )*WK + + $ A( I, K+1 )*WKP1 + 50 CONTINUE + + 60 CONTINUE + +* +* Update C*S^-1 +* + DO 90 J = K+2, N + T = A( J, K ) + A( J, K ) = -A( J, K+1 )*D21 + A( J, K+1 ) = T*D21 + 90 CONTINUE + END IF + + K = K + KSTEP + GO TO 40 +* + END IF +* + 70 CONTINUE +* + RETURN +* +* End of DKYTF2 +* + END diff --git a/SRC/dkytrd.f b/SRC/dkytrd.f new file mode 100644 index 000000000..e5a2a5959 --- /dev/null +++ b/SRC/dkytrd.f @@ -0,0 +1,362 @@ +*> \brief \b DKYTRD +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DKYTRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DKYTRD( UPLO, N, A, LDA, E, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DKYTRD reduces a real skew-symmetric matrix A to real skew-symmetric +*> tridiagonal form T by an orthogonal similarity transformation: +*> Q**T * A * Q = T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the skew-symmetric matrix A. If UPLO = 'U', the strictly +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the leading lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> strictly N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the leading upper +*> triangular part of A is not referenced. +*> On exit, if UPLO = 'U', the first superdiagonal of A are +*> overwritten by the corresponding elements of the tridiagonal +*> matrix T, and the elements above the first superdiagonal, with +*> the array TAU, represent the orthogonal matrix Q as a product +*> of elementary reflectors; if UPLO = 'L', the first subdiagonal +*> of A are overwritten by the corresponding elements of the +*> tridiagonal matrix T, and the elements below the first subdiagonal, +*> with the array TAU, represent the orthogonal matrix Q as a product +*> of elementary reflectors. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> The off-diagonal elements of the tridiagonal matrix T: +*> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (N-1) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 1. +*> For optimum performance LWORK >= N*NB, where NB is the +*> optimal blocksize. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kytrd +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', the matrix Q is represented as a product of elementary +*> reflectors +*> +*> Q = H(n-1) . . . H(2) H(1). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in +*> A(1:i-1,i+1), and tau in TAU(i). +*> +*> If UPLO = 'L', the matrix Q is represented as a product of elementary +*> reflectors +*> +*> Q = H(1) H(2) . . . H(n-1). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), +*> and tau in TAU(i). +*> +*> The contents of A on exit are illustrated by the following examples +*> with n = 5: +*> +*> if UPLO = 'U': if UPLO = 'L': +*> +*> ( 0 e v2 v3 v4 ) ( 0 ) +*> ( 0 e v3 v4 ) ( e 0 ) +*> ( 0 e v4 ) ( v1 e 0 ) +*> ( 0 e ) ( v1 v2 e 0 ) +*> ( 0 ) ( v1 v2 v3 e 0 ) +*> +*> where d and e denote diagonal and off-diagonal elements of T, and vi +*> denotes an element of the vector defining H(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DKYTRD( UPLO, N, A, LDA, E, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB, + $ NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL DLATRD, DKYR2K, DKYTD2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .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 = -4 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size. +* + NB = ILAENV( 1, 'DKYTRD', UPLO, N, -1, -1, -1 ) + LWKOPT = MAX( 1, N*NB ) + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DKYTRD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NX = N + IWS = 1 + IF( NB.GT.1 .AND. NB.LT.N ) THEN +* +* Determine when to cross over from blocked to unblocked code +* (last block is always handled by unblocked code). +* + NX = MAX( NB, ILAENV( 3, 'DKYTRD', UPLO, N, -1, -1, -1 ) ) + IF( NX.LT.N ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: determine the +* minimum value of NB, and reduce NB or force use of +* unblocked code by setting NX = N. +* + NB = MAX( LWORK / LDWORK, 1 ) + NBMIN = ILAENV( 2, 'DKYTRD', UPLO, N, -1, -1, -1 ) + IF( NB.LT.NBMIN ) + $ NX = N + END IF + ELSE + NX = N + END IF + ELSE + NB = 1 + END IF +* + IF( UPPER ) THEN +* +* Reduce the upper triangle of A. +* Columns 1:kk are handled by the unblocked method. +* + KK = N - ( ( N-NX+NB-1 ) / NB )*NB + DO 20 I = N - NB + 1, KK + 1, -NB +* +* Reduce columns i:i+nb-1 to tridiagonal form and form the +* matrix W which is needed to update the unreduced part of +* the matrix +* + CALL DLATRDK( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK, + $ LDWORK ) +* +* Update the unreduced submatrix A(1:i-1,1:i-1), using an +* update of the form: A := A + V*X**T - X*V**T +* + CALL DKYR2K( UPLO, 'No transpose', I-1, NB, -ONE, A( 1, + $ I ), + $ LDA, WORK, LDWORK, ONE, A, LDA ) +* +* Copy superdiagonal elements back into A +* + DO 10 J = I, I + NB - 1 + A( J-1, J ) = E( J-1 ) + 10 CONTINUE + 20 CONTINUE +* +* Use unblocked code to reduce the last or only block +* + CALL DKYTD2( UPLO, KK, A, LDA, E, TAU, IINFO ) + ELSE +* +* Reduce the lower triangle of A +* + DO 40 I = 1, N - NX, NB +* +* Reduce columns i:i+nb-1 to tridiagonal form and form the +* matrix W which is needed to update the unreduced part of +* the matrix +* + CALL DLATRDK( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ), + $ TAU( I ), WORK, LDWORK ) +* +* Update the unreduced submatrix A(i+ib:n,i+ib:n), using +* an update of the form: A := A + V*X**T - X*V**T +* + CALL DKYR2K( UPLO, 'No transpose', N-I-NB+1, NB, -ONE, + $ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, + $ ONE, A( I+NB, I+NB ), LDA ) +* +* Copy subdiagonal elements back into A +* + DO 30 J = I, I + NB - 1 + A( J+1, J ) = E( J ) + 30 CONTINUE + 40 CONTINUE +* +* Use unblocked code to reduce the last or only block +* + CALL DKYTD2( UPLO, N-I+1, A( I, I ), LDA, E( I ), + $ TAU( I ), IINFO ) + END IF +* + WORK( 1 ) = LWKOPT + RETURN +* +* End of DKYTRD +* + END diff --git a/SRC/dkytrf.f b/SRC/dkytrf.f new file mode 100644 index 000000000..d8a09ee3d --- /dev/null +++ b/SRC/dkytrf.f @@ -0,0 +1,377 @@ +*> \brief \b DKYTRF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DKYTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DKYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DKYTRF computes the factorization of a real skew-symmetric matrix A using +*> the Bunch partial pivoting method. The form of the +*> factorization is +*> +*> A = U**T*D*U or A = L*D*L**T +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and D is skew-symmetric and block diagonal with +*> 1-by-1 and 2-by-2 diagonal blocks. All 2-by-2 diagonal blocks are +*> nonsingular and all 1-by-1 diagonal blocks are 0. If N is odd, there +*> is at least one 1-by-1 diagonal block. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the skew-symmetric matrix A. If UPLO = 'U', the +*> strictly upper triangular part of A contains the upper +*> triangular part of the matrix A, and the leading N-by-N lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> strictly lower triangular part of A contains the lower +*> triangular part of the matrix A, and the leading N-by-N upper +*> triangular part of A is not referenced. +*> +*> On exit, the block diagonal matrix D and the multipliers used +*> to obtain the factor U or L (see below for further details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges of D, as determined by DKYTRF. +*> +*> The elements of array IPIV are combined in pair, and the first +*> (if UPLO = 'U') or the second (if UPLO = 'L') element in +*> the pair always keeps the value 0. If N is odd, the first +*> (if UPLO = 'U') or the last (if UPLO = 'L') element of IPIV is +*> 0, which is the only element not in pair. So we only use the +*> first (if UPLO = 'L') or the second (if UPLO = 'U') element in +*> the pair to determine the interchanges. +*> +*> If IPIV(k) +*> = 0: there was no interchange. +*> > 0: rows and columns k-1 and IPIV(k) were interchanged, if +*> UPLO = 'U', and rows and columns k+1 and IPIV(k) were +*> interchanged, if UPLO = 'L'. +*> < 0: rows and columns k and k-1 were interchanged, +*> then rows and columns k-1 and -IPIV(k) were interchanged, if +*> UPLO = 'U', and rows and columns k and k+1 were interchanged, +*> then rows and columns k+1 and -IPIV(k) were interchanged, if +*> UPLO = 'L'. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >=1. For best performance +*> LWORK >= N*NB, where NB is the block size returned by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i-1,i) (if UPLO = 'U') or D(i+1,i) (if UPLO = 'L') +*> is exactly zero. The factorization has been completed, +*> but the block diagonal matrix D is exactly singular, +*> so the solution could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kytrf +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', then A = U**T*D*U, where +*> U = P(n)*U(n)* ... *P(k)U(k)* ..., +*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to +*> 1 in steps of 2, and D is a block diagonal matrix with 2-by-2 +*> diagonal blocks D(k). P(k) is a permutation matrix as defined by +*> IPIV(k), and U(k) is a unit upper triangular matrix, such that if +*> the diagonal block D(k) is of order 2, namely s = 2, then +*> +*> ( I v 0 ) k-s +*> U(k) = ( 0 I 0 ) s +*> ( 0 0 I ) n-k +*> k-s s n-k +*> +*> The strictly upper triangle of D(k) overwrites A(k-1,k), and v overwrites +*> A(1:k-2,k-1:k). +*> +*> If UPLO = 'L', then A = L*D*L**T, where +*> L = P(1)*L(1)* ... *P(k)*L(k)* ..., +*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to +*> n in steps of 2, and D is a block diagonal matrix with 2-by-2 +*> diagonal blocks D(k). P(k) is a permutation matrix as defined by +*> IPIV(k), and L(k) is a unit lower triangular matrix, such that if +*> the diagonal block D(k) is of order 2, namely s = 2, then +*> +*> ( I 0 0 ) k-1 +*> L(k) = ( 0 I 0 ) s +*> ( 0 v I ) n-k-s+1 +*> k-1 s n-k-s+1 +*> +*> The strictly lower triangle of D(k) overwrites A(k+1,k), and v overwrites +*> A(k+2:n,k:k+1). +*> +*> Remind that if n is odd, A is always singular. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DKYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLAKYF, DKYTF2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .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 = -4 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size +* + NB = ILAENV( 1, 'DKYTRF', UPLO, N, -1, -1, -1 ) + LWKOPT = MAX( 1, N*NB ) + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DKYTRF', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* + NBMIN = 2 + LDWORK = N + IF( NB.GT.1 .AND. NB.LT.N ) THEN + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN + NB = MAX( LWORK / LDWORK, 1 ) + NBMIN = MAX( 2, ILAENV( 2, 'DKYTRF', UPLO, N, -1, -1, + $ -1 ) ) + END IF + ELSE + IWS = 1 + END IF + IF( NB.LT.NBMIN ) + $ NB = N +* + IF( UPPER ) THEN +* +* Factorize A as U**T*D*U using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* KB, where KB is the number of columns factorized by DLAKYF; +* KB is either NB or NB-1, or K for the last block +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 40 +* + IF( K.GT.NB ) THEN +* +* Factorize columns k-kb+1:k of A and use blocked code to +* update columns 1:k-kb +* + CALL DLAKYF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, LDWORK, + $ IINFO ) + ELSE +* +* Use unblocked code to factorize columns 1:k of A +* + CALL DKYTF2( UPLO, K, A, LDA, IPIV, IINFO ) + KB = K + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO +* +* Decrease K and return to the start of the main loop +* + K = K - KB + GO TO 10 +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* KB, where KB is the number of columns factorized by DLAKYF; +* KB is either NB or NB-1, or N-K+1 for the last block +* + K = 1 + 20 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 40 +* + IF( K.LE.N-NB ) THEN +* +* Factorize columns k:k+kb-1 of A and use blocked code to +* update columns k+kb:n +* + CALL DLAKYF( UPLO, N-K+1, NB, KB, A( K, K ), LDA, + $ IPIV( K ), + $ WORK, LDWORK, IINFO ) + ELSE +* +* Use unblocked code to factorize columns k:n of A +* + CALL DKYTF2( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), + $ IINFO ) + KB = N - K + 1 + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + K - 1 +* +* Adjust IPIV +* + DO 30 J = K, K + KB - 1 + IF( IPIV( J ).GT.0 ) THEN + IPIV( J ) = IPIV( J ) + K - 1 + ELSEIF( IPIV( J ).LT.0 ) THEN + IPIV( J ) = IPIV( J ) - K + 1 + END IF + 30 CONTINUE +* +* Increase K and return to the start of the main loop +* + K = K + KB + GO TO 20 +* + END IF +* + 40 CONTINUE + WORK( 1 ) = LWKOPT + RETURN +* +* End of DKYTRF +* + END diff --git a/SRC/dkytri.f b/SRC/dkytri.f new file mode 100644 index 000000000..e0395d855 --- /dev/null +++ b/SRC/dkytri.f @@ -0,0 +1,333 @@ +*> \brief \b DKYTRI +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DKYTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DKYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DKYTRI computes the inverse of a real skew-symmetric indefinite matrix +*> A using the factorization A = U*D*U**T or A = L*D*L**T computed by +*> DSYTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the block diagonal matrix D and the multipliers +*> used to obtain the factor U or L as computed by SKYTRF. +*> +*> On exit, if INFO = 0, the (skew-symmetric) inverse of the original +*> matrix. If UPLO = 'U', the upper triangular part of the +*> inverse is formed and the part of A below the diagonal is not +*> referenced; if UPLO = 'L' the lower triangular part of the +*> inverse is formed and the part of A above the diagonal is +*> not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by DSYTRF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kytri +* +* ===================================================================== + SUBROUTINE DKYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER K, KP, KSTEP + DOUBLE PRECISION TEMP +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DSWAP, DKYMV, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .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 = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DKYTRI', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. MOD(N,2).NE.0 ) + $ RETURN +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO 10 INFO = N, 2, -2 + IF( A( INFO - 1, INFO ).EQ.ZERO ) + $ RETURN + 10 CONTINUE + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO 20 INFO = 1, N-1, 2 + IF( A( INFO + 1, INFO ).EQ.ZERO ) + $ RETURN + 20 CONTINUE + END IF + INFO = 0 +* + IF( UPPER ) THEN +* +* Compute inv(A) from the factorization A = U*D*U**T. +* +* K is the main loop index, increasing from 1 to N in steps of 2 +* + K = 1 + 30 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GE.N ) + $ GO TO 40 +* +* +* 2 x 2 diagonal block +* +* Invert the diagonal block. +* + A( K, K+1 ) = -ONE / A( K, K+1 ) +* +* Compute columns K and K+1 of the inverse. +* + IF( K.GT.1 ) THEN + CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 ) + CALL DKYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, + $ A( 1, K ), 1 ) + A( K, K+1 ) = A( K, K+1 ) + + $ DDOT( K-1, A( 1, K ), 1, A( 1, K+1 ), + $ 1 ) + CALL DCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 ) + CALL DKYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, + $ A( 1, K+1 ), 1 ) + END IF + KSTEP = 2 +* + KP = IPIV( K+1 ) +* +* Interchange rows and columns K and KP in the leading +* submatrix A(1:k+1,1:k+1) +* + IF( KP.GT.0 ) THEN + CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) + CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) + CALL DSCAL( K-KP, -ONE, A( KP, K ), 1) + CALL DSCAL( K-KP-1, -ONE, A( KP, KP+1 ), LDA ) + TEMP = A( K, K+1 ) + A( K, K+1 ) = A( KP, K+1 ) + A( KP, K+1 ) = TEMP + ELSEIF( KP.LT.0 ) THEN + KP = -KP + CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) + CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) + CALL DSCAL( K-KP, -ONE, A( KP, K ), 1) + CALL DSCAL( K-KP-1, -ONE, A( KP, KP+1 ), LDA ) + TEMP = A( K, K+1 ) + A( K, K+1 ) = A( KP, K+1 ) + A( KP, K+1 ) = TEMP + CALL DSWAP( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 ) + A( K, K+1 ) = -A( K, K+1 ) + END IF +* + K = K + KSTEP + GO TO 30 + 40 CONTINUE +* + ELSE +* +* Compute inv(A) from the factorization A = L*D*L**T. +* +* K is the main loop index, increasing from 1 to N in steps of 2 +* + K = N + 50 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LE.1 ) + $ GO TO 60 +* +* +* 2 x 2 diagonal block +* +* Invert the diagonal block. +* + A( K, K-1 ) = -ONE / A( K, K-1 ) +* +* Compute columns K-1 and K of the inverse. +* + IF( K.LT.N ) THEN + CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) + CALL DKYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, + $ 1, ZERO, A( K+1, K ), 1 ) + A( K, K-1 ) = A( K, K-1 ) + + $ DDOT( N-K, A( K+1, K ), 1, A( K+1, K-1 ), + $ 1 ) + CALL DCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 ) + CALL DKYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, + $ 1, ZERO, A( K+1, K-1 ), 1 ) + END IF + KSTEP = 2 +* + KP = IPIV( K-1 ) +* +* Interchange rows and columns K and KP in the trailing +* submatrix A(k-1:n,k-1:n) +* + IF( KP.GT.0 ) THEN + IF( KP.LT.N ) + $ CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) + CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA ) + CALL DSCAL( KP-K, -ONE, A( K+1, K ), 1) + CALL DSCAL( KP-K-1, -ONE, A( KP, K+1 ), LDA ) + TEMP = A( K, K-1 ) + A( K, K-1 ) = A( KP, K-1 ) + A( KP, K-1 ) = TEMP + ELSEIF( KP.LT.0 ) THEN + KP = -KP + IF( KP.LT.N ) + $ CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) + CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA ) + CALL DSCAL( KP-K, -ONE, A( K+1, K ), 1) + CALL DSCAL( KP-K-1, -ONE, A( KP, K+1 ), LDA ) + TEMP = A( K, K-1 ) + A( K, K-1 ) = A( KP, K-1 ) + A( KP, K-1 ) = TEMP + CALL DSWAP( N-K, A( K+1, K ), 1, A( K+1, K-1 ), 1 ) + A( K, K-1 ) = -A( K, K-1 ) + END IF +* + K = K - KSTEP + GO TO 50 + 60 CONTINUE + END IF +* + RETURN +* +* End of DKYTRI +* + END diff --git a/SRC/dkytri2.f b/SRC/dkytri2.f new file mode 100644 index 000000000..8312bc207 --- /dev/null +++ b/SRC/dkytri2.f @@ -0,0 +1,207 @@ +*> \brief \b DKYTRI2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DKYTRI2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DKYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DKYTRI2 computes the inverse of a DOUBLE PRECISION skew-symmetric indefinite matrix +*> A using the factorization A = U*D*U**T or A = L*D*L**T computed by +*> SKYTRF. DKYTRI2 sets the LEADING DIMENSION of the workspace +*> before calling DKYTRI2X that actually computes the inverse. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the block diagonal matrix D and the multipliers +*> used to obtain the factor U or L as computed by SKYTRF. +*> +*> On exit, if INFO = 0, the (skew-symmetric) inverse of the original +*> matrix. If UPLO = 'U', the upper triangular part of the +*> inverse is formed and the part of A below the diagonal is not +*> referenced; if UPLO = 'L' the lower triangular part of the +*> inverse is formed and the part of A above the diagonal is +*> not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by SKYTRF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N+NB+1)*(NB+3) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> WORK is size >= (N+NB+1)*(NB+3) +*> If LWORK = -1, then a workspace query is assumed; the routine +*> calculates: +*> - the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, +*> - and no error message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kytri2 +* +* ===================================================================== + SUBROUTINE DKYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL UPPER, LQUERY + INTEGER MINSIZE, NBMAX +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DKYTRI, DKYTRI2X, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* Get blocksize +* + NBMAX = ILAENV( 1, 'DKYTRF', UPLO, N, -1, -1, -1 ) + IF( N.EQ.0 ) THEN + MINSIZE = 1 + ELSE IF ( NBMAX .GE. N ) THEN + MINSIZE = N + ELSE + MINSIZE = (N+NBMAX+1)*(NBMAX+3) + END IF +* + IF( .NOT.UPPER .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 = -4 + ELSE IF (LWORK .LT. MINSIZE .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* +* Quick return if possible +* +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DKYTRI2', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + WORK(1)=MINSIZE + RETURN + END IF + IF( N.EQ.0 ) + $ RETURN + + IF( NBMAX .GE. N ) THEN + CALL DKYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) + ELSE + CALL DKYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NBMAX, INFO ) + END IF +* + RETURN +* +* End of DKYTRI2 +* + END diff --git a/SRC/dkytri2x.f b/SRC/dkytri2x.f new file mode 100644 index 000000000..8589c524b --- /dev/null +++ b/SRC/dkytri2x.f @@ -0,0 +1,541 @@ +*> \brief \b DKYTRI2X +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DKYTRI2X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DKYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), WORK( N+NB+1,* ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DKYTRI2X computes the inverse of a real skew-symmetric indefinite matrix +*> A using the factorization A = U*D*U**T or A = L*D*L**T computed by +*> DKYTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the NNB diagonal matrix D and the multipliers +*> used to obtain the factor U or L as computed by DKYTRF. +*> +*> On exit, if INFO = 0, the (skew-symmetric) inverse of the original +*> matrix. If UPLO = 'U', the upper triangular part of the +*> inverse is formed and the part of A below the diagonal is not +*> referenced; if UPLO = 'L' the lower triangular part of the +*> inverse is formed and the part of A above the diagonal is +*> not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the NNB structure of D +*> as determined by DKYTRF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N+NB+1,NB+3) +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Block size +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kytri2x +* +* ===================================================================== + SUBROUTINE DKYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), WORK( N+NB+1,* ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, IINFO, IP, K, CUT, NNB + INTEGER COUNT + INTEGER J, U11, INVD + + DOUBLE PRECISION T + DOUBLE PRECISION U01_I_J, U01_IP1_J + DOUBLE PRECISION U11_I_J, U11_IP1_J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DKYCONV, XERBLA, DTRTRI + EXTERNAL DGEMM, DTRMM, DKYSWAPR +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .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 = -4 + END IF +* +* Quick return if possible +* +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DKYTRI2X', -INFO ) + RETURN + END IF + IF( N.EQ.0 .OR. MOD(N,2).NE.0 ) + $ RETURN +* +* Convert A +* Workspace got Non-diag elements of D +* + CALL DKYCONV( UPLO, 'C', N, A, LDA, IPIV, WORK, IINFO ) +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO INFO = N, 2, -2 + IF( WORK( INFO, 1 ).EQ.ZERO ) + $ RETURN + END DO + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO INFO = 1, N-1, 2 + IF( WORK( INFO, 1 ).EQ.ZERO ) + $ RETURN + END DO + END IF + INFO = 0 +* +* Splitting Workspace +* U01 is a block (N,NB+1) +* The first element of U01 is in WORK(1,1) +* U11 is a block (NB+1,NB+1) +* The first element of U11 is in WORK(N+1,1) + U11 = N +* INVD is a block (N,2) +* The first element of INVD is in WORK(1,INVD) + INVD = NB+2 + + IF( UPPER ) THEN +* +* invA = P * inv(U**T)*inv(D)*inv(U)*P**T. +* + CALL DTRTRI( UPLO, 'U', N, A, LDA, INFO ) +* +* inv(D) and inv(D)*inv(U) +* + K=1 + DO WHILE ( K .LE. N ) +* 2 x 2 diagonal NNB + T = WORK(K+1,1) + WORK(K,INVD) = ZERO + WORK(K+1,INVD+1) = ZERO + WORK(K,INVD+1) = -ONE / T + WORK(K+1,INVD) = ONE / T + K=K+2 + END DO +* +* inv(U**T) = (inv(U))**T +* +* inv(U**T)*inv(D)*inv(U) +* + CUT=N + DO WHILE (CUT .GT. 0) + NNB=NB + IF (CUT .LE. NNB) THEN + NNB=CUT + ELSE +* need a even number for a clear cut + IF (MOD(NNB,2) .EQ. 1) NNB=NNB+1 + END IF + + CUT=CUT-NNB +* +* U01 Block +* + DO I=1,CUT + DO J=1,NNB + WORK(I,J)=A(I,CUT+J) + END DO + END DO +* +* U11 Block +* + DO I=1,NNB + WORK(U11+I,I)=ONE + DO J=1,I-1 + WORK(U11+I,J)=ZERO + END DO + DO J=I+1,NNB + WORK(U11+I,J)=A(CUT+I,CUT+J) + END DO + END DO +* +* invD*U01 +* + I=1 + DO WHILE (I .LE. CUT) + DO J=1,NNB + U01_I_J = WORK(I,J) + U01_IP1_J = WORK(I+1,J) + WORK(I,J)=WORK(I,INVD)*U01_I_J+ + $ WORK(I,INVD+1)*U01_IP1_J + WORK(I+1,J)=WORK(I+1,INVD)*U01_I_J+ + $ WORK(I+1,INVD+1)*U01_IP1_J + END DO + I=I+2 + END DO +* +* invD1*U11 +* + I=1 + DO WHILE (I .LE. NNB) + DO J=I,NNB + U11_I_J = WORK(U11+I,J) + U11_IP1_J = WORK(U11+I+1,J) + WORK(U11+I,J)=WORK(CUT+I,INVD)*WORK(U11+I,J) + + $ WORK(CUT+I,INVD+1)*WORK(U11+I+1,J) + WORK(U11+I+1,J)=WORK(CUT+I+1,INVD)*U11_I_J+ + $ WORK(CUT+I+1,INVD+1)*U11_IP1_J + END DO + I=I+2 + END DO +* +* U11**T*invD1*U11->U11 +* + CALL DTRMM('L','U','T','U',NNB, NNB, + $ ONE,A(CUT+1,CUT+1),LDA,WORK(U11+1,1),N+NB+1) +* + DO I=1,NNB + DO J=I,NNB + A(CUT+I,CUT+J)=WORK(U11+I,J) + END DO + END DO +* +* U01**T*invD*U01->A(CUT+I,CUT+J) +* + CALL DGEMM('T','N',NNB,NNB,CUT,ONE,A(1,CUT+1),LDA, + $ WORK,N+NB+1, ZERO, WORK(U11+1,1), N+NB+1) +* +* U11 = U11**T*invD1*U11 + U01**T*invD*U01 +* + DO I=1,NNB + DO J=I,NNB + A(CUT+I,CUT+J)=A(CUT+I,CUT+J)+WORK(U11+I,J) + END DO + END DO +* +* U01 = U00**T*invD0*U01 +* + CALL DTRMM('L',UPLO,'T','U',CUT, NNB, + $ ONE,A,LDA,WORK,N+NB+1) + +* +* Update U01 +* + DO I=1,CUT + DO J=1,NNB + A(I,CUT+J)=WORK(I,J) + END DO + END DO +* +* Next Block +* + END DO +* +* Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T +* + I=1 + DO WHILE ( I .LT. N ) + IF( IPIV(I+1) .GT. 0 ) THEN + IP=IPIV(I+1) + I=I+1 + IF ( (I-1) .LT. IP) + $ CALL DKYSWAPR( UPLO, N, A, LDA, I-1 ,IP ) + IF ( (I-1) .GT. IP) + $ CALL DKYSWAPR( UPLO, N, A, LDA, IP ,I-1 ) + ELSEIF( IPIV(I+1) .LT. 0 ) THEN + IP=-IPIV(I+1) + I=I+1 + IF ( (I-1) .LT. IP) + $ CALL DKYSWAPR( UPLO, N, A, LDA, I-1 ,IP ) + IF ( (I-1) .GT. IP) + $ CALL DKYSWAPR( UPLO, N, A, LDA, IP ,I-1 ) + CALL DKYSWAPR( UPLO, N, A, LDA, I-1 ,I ) + ELSE + I=I+1 + ENDIF + I=I+1 + END DO + ELSE +* +* LOWER... +* +* invA = P * inv(U**T)*inv(D)*inv(U)*P**T. +* + CALL DTRTRI( UPLO, 'U', N, A, LDA, INFO ) +* +* inv(D) and inv(D)*inv(U) +* + K=N + DO WHILE ( K .GE. 1 ) +* 2 x 2 diagonal NNB + T = WORK(K-1,1) + WORK(K-1,INVD) = ZERO + WORK(K,INVD) = ZERO + WORK(K,INVD+1) = -ONE / T + WORK(K-1,INVD+1) = ONE / T + K=K-2 + END DO +* +* inv(U**T) = (inv(U))**T +* +* inv(U**T)*inv(D)*inv(U) +* + CUT=0 + DO WHILE (CUT .LT. N) + NNB=NB + IF (CUT + NNB .GT. N) THEN + NNB=N-CUT + ELSE +* need a even number for a clear cut + IF (MOD(NNB,2) .EQ. 1) NNB=NNB+1 + END IF +* L21 Block + DO I=1,N-CUT-NNB + DO J=1,NNB + WORK(I,J)=A(CUT+NNB+I,CUT+J) + END DO + END DO +* L11 Block + DO I=1,NNB + WORK(U11+I,I)=ONE + DO J=I+1,NNB + WORK(U11+I,J)=ZERO + END DO + DO J=1,I-1 + WORK(U11+I,J)=A(CUT+I,CUT+J) + END DO + END DO +* +* invD*L21 +* + I=N-CUT-NNB + DO WHILE (I .GE. 1) + DO J=1,NNB + U01_I_J = WORK(I,J) + U01_IP1_J = WORK(I-1,J) + WORK(I,J)=WORK(CUT+NNB+I,INVD)*U01_I_J+ + $ WORK(CUT+NNB+I,INVD+1)*U01_IP1_J + WORK(I-1,J)=WORK(CUT+NNB+I-1,INVD+1)*U01_I_J+ + $ WORK(CUT+NNB+I-1,INVD)*U01_IP1_J + END DO + I=I-2 + END DO +* +* invD1*L11 +* + I=NNB + DO WHILE (I .GE. 1) + DO J=1,NNB + U11_I_J = WORK(U11+I,J) + U11_IP1_J = WORK(U11+I-1,J) + WORK(U11+I,J)=WORK(CUT+I,INVD)*WORK(U11+I,J) + + $ WORK(CUT+I,INVD+1)*U11_IP1_J + WORK(U11+I-1,J)=WORK(CUT+I-1,INVD+1)*U11_I_J+ + $ WORK(CUT+I-1,INVD)*U11_IP1_J + END DO + I=I-2 + END DO +* +* L11**T*invD1*L11->L11 +* + CALL DTRMM('L',UPLO,'T','U',NNB, NNB, + $ ONE,A(CUT+1,CUT+1),LDA,WORK(U11+1,1),N+NB+1) + +* + DO I=1,NNB + DO J=1,I + A(CUT+I,CUT+J)=WORK(U11+I,J) + END DO + END DO +* + IF ( (CUT+NNB) .LT. N ) THEN +* +* L21**T*invD2*L21->A(CUT+I,CUT+J) +* + CALL DGEMM('T','N',NNB,NNB,N-NNB-CUT,ONE,A(CUT+NNB+1,CUT+1) + $ ,LDA,WORK,N+NB+1, ZERO, WORK(U11+1,1), N+NB+1) + +* +* L11 = L11**T*invD1*L11 + U01**T*invD*U01 +* + DO I=1,NNB + DO J=1,I + A(CUT+I,CUT+J)=A(CUT+I,CUT+J)+WORK(U11+I,J) + END DO + END DO +* +* L01 = L22**T*invD2*L21 +* + CALL DTRMM('L',UPLO,'T','U', N-NNB-CUT, NNB, + $ ONE,A(CUT+NNB+1,CUT+NNB+1),LDA,WORK,N+NB+1) +* +* Update L21 +* + DO I=1,N-CUT-NNB + DO J=1,NNB + A(CUT+NNB+I,CUT+J)=WORK(I,J) + END DO + END DO + + ELSE +* +* L11 = L11**T*invD1*L11 +* + DO I=1,NNB + DO J=1,I + A(CUT+I,CUT+J)=WORK(U11+I,J) + END DO + END DO + END IF +* +* Next Block +* + CUT=CUT+NNB + END DO +* +* Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T +* + I=N + DO WHILE ( I .GT. 1 ) + IF( IPIV(I-1) .GT. 0 ) THEN + IP=IPIV(I-1) + IF ( I .LT. IP) CALL DKYSWAPR( UPLO, N, A, LDA, I , + $ IP ) + IF ( I .GT. IP) CALL DKYSWAPR( UPLO, N, A, LDA, IP , + $ I ) + I=I-1 + ELSEIF( IPIV(I-1) .LT. 0 ) THEN + IP=-IPIV(I-1) + IF ( I .LT. IP) CALL DKYSWAPR( UPLO, N, A, LDA, I , + $ IP ) + IF ( I .GT. IP) CALL DKYSWAPR( UPLO, N, A, LDA, IP , + $ I ) + CALL DKYSWAPR( UPLO, N, A, LDA, I-1 ,I ) + I=I-1 + ELSE + I=I-1 + ENDIF + I=I-1 + END DO + END IF +* + RETURN +* +* End of DKYTRI2X +* + END + diff --git a/SRC/dkytrs.f b/SRC/dkytrs.f new file mode 100644 index 000000000..2fb368b85 --- /dev/null +++ b/SRC/dkytrs.f @@ -0,0 +1,527 @@ +*> \brief \b DKYTRS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DKYTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DKYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DKYTRS solves a system of linear equations A*X = B with a real +*> skew-symmetric matrix A using the factorization A = U*D*U**T or +*> A = L*D*L**T computed by SKYTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by SKYTRF. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by SKYTRF. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kytrs +* +* ===================================================================== + SUBROUTINE DKYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J, K, KP + DOUBLE PRECISION AK, AKM1, AKM1K, BK, BKM1, DENOM +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DGER, DSCAL, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( (N.LT.0) .OR. (MOD(N,2).NE.0) ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DKYTRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Solve A*X = B, where A = U*D*U**T. +* +* First solve U*D*X = B, overwriting B with X. +* +* K is the main loop index, decreasing from N to 1 +* in steps of 2. +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 30 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 2 x 2 diagonal block +* +* Interchange rows K-1 and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K-1 ) THEN + CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) + END IF +* +* Multiply by inv(U(K)), where U(K) is the transformation +* stored in columns K-1 and K of A. +* + CALL DGER( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, + $ B( 1, 1 ), LDB ) + CALL DGER( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ), + $ LDB, B( 1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + CALL DSCAL( NRHS, -ONE / A( K-1, K ), B( K, 1 ), LDB ) + CALL DSCAL( NRHS, ONE / A( K-1, K ), B( K-1, 1 ), LDB ) + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( K-1, 1 ), LDB ) +* + K = K - 2 + ELSEIF( IPIV( K ).LT.0 ) THEN +* +* 2 x 2 diagonal block +* +* Interchange rows K and K-1, then K-1 and -IPIV(K). +* + KP = -IPIV( K ) + IF( KP.NE.K-1 ) THEN + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( K-1, 1 ), LDB ) + CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) + END IF +* +* Multiply by inv(U(K)), where U(K) is the transformation +* stored in columns K-1 and K of A. +* + CALL DGER( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, + $ B( 1, 1 ), LDB ) + CALL DGER( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ), + $ LDB, B( 1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + CALL DSCAL( NRHS, -ONE / A( K-1, K ), B( K, 1 ), LDB ) + CALL DSCAL( NRHS, ONE / A( K-1, K ), B( K-1, 1 ), LDB ) + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( K-1, 1 ), LDB ) +* + K = K - 2 + ELSE +* +* 2 x 2 diagonal block +* +* Multiply by inv(U(K)), where U(K) is the transformation +* stored in columns K-1 and K of A. +* + CALL DGER( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, + $ B( 1, 1 ), LDB ) + CALL DGER( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ), + $ LDB, B( 1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + CALL DSCAL( NRHS, -ONE / A( K-1, K ), B( K, 1 ), LDB ) + CALL DSCAL( NRHS, ONE / A( K-1, K ), B( K-1, 1 ), LDB ) + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( K-1, 1 ), LDB ) +* + K = K - 2 + END IF +* + GO TO 10 + 30 CONTINUE +* +* Next solve U**T *X = B, overwriting B with X. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + 40 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 50 +* + IF( IPIV( K+1 ).GT.0 ) THEN +* +* 2 x 2 diagonal block +* +* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation +* stored in columns K and K+1 of A. +* + CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, + $ K ), + $ 1, ONE, B( K, 1 ), LDB ) + CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, + $ A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB ) +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K+1 ) + IF( KP.NE.K ) THEN + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + K = K + 2 + ELSEIF( IPIV( K+1 ).LT.0 ) THEN +* +* 2 x 2 diagonal block +* +* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation +* stored in columns K and K+1 of A. +* + CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, + $ K ), + $ 1, ONE, B( K, 1 ), LDB ) + CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, + $ A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB ) +* +* Interchange rows K and -IPIV(K), then K and K+1. +* + KP = -IPIV( K+1 ) + IF( KP.NE.K ) THEN + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( K, 1 ), LDB ) + END IF + K = K + 2 + ELSE +* +* 2 x 2 diagonal block +* +* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation +* stored in columns K and K+1 of A. +* + CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, + $ A( 1, K ), 1, ONE, B( K, 1 ), LDB ) + CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, + $ A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB ) + K = K + 2 + END IF +* + GO TO 40 + 50 CONTINUE +* + ELSE +* +* Solve A*X = B, where A = L*D*L**T. +* +* First solve L*D*X = B, overwriting B with X. +* +* K is the main loop index, increasing from 1 to N +* in steps of 2. +* + K = 1 + 60 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 80 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 2 x 2 diagonal block +* +* Interchange rows K+1 and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K+1 ) THEN + CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) + END IF +* +* Multiply by inv(L(K)), where L(K) is the transformation +* stored in columns K and K+1 of A. +* + IF( K.LT.N-1 ) THEN + CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K ), 1, + $ B( K, 1 ), LDB, B( K+2, 1 ), LDB ) + CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1, + $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) + END IF +* +* Multiply by the inverse of the diagonal block. +* + CALL DSCAL( NRHS, -ONE / A( K+1, K ), B( K, 1 ), LDB ) + CALL DSCAL( NRHS, ONE / A( K+1, K ), B( K+1, 1 ), LDB ) + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( K+1, 1 ), LDB ) +* + K = K + 2 + ELSEIF( IPIV( K ).LT.0 ) THEN +* +* 2 x 2 diagonal block +* +* Interchange rows K and K+1, then K+1 and -IPIV(K). +* + KP = -IPIV( K ) + IF( KP.NE.K+1 ) THEN + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( K+1, 1 ), LDB ) + CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) + END IF +* +* Multiply by inv(L(K)), where L(K) is the transformation +* stored in columns K and K+1 of A. +* + IF( K.LT.N-1 ) THEN + CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K ), 1, + $ B( K, 1 ), LDB, B( K+2, 1 ), LDB ) + CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1, + $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) + END IF +* +* Multiply by the inverse of the diagonal block. +* + CALL DSCAL( NRHS, -ONE / A( K+1, K ), B( K, 1 ), LDB ) + CALL DSCAL( NRHS, ONE / A( K+1, K ), B( K+1, 1 ), LDB ) + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( K+1, 1 ), LDB ) +* + K = K + 2 + ELSE +* +* 2 x 2 diagonal block +* +* Multiply by inv(L(K)), where L(K) is the transformation +* stored in columns K and K+1 of A. +* + IF( K.LT.N-1 ) THEN + CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K ), 1, + $ B( K, 1 ), LDB, B( K+2, 1 ), LDB ) + CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1, + $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) + END IF +* +* Multiply by the inverse of the diagonal block. + CALL DSCAL( NRHS, -ONE / A( K+1, K ), B( K, 1 ), LDB ) + CALL DSCAL( NRHS, ONE / A( K+1, K ), B( K+1, 1 ), LDB ) + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( K+1, 1 ), LDB ) +* + K = K + 2 + END IF +* + GO TO 60 + 80 CONTINUE +* +* Next solve L**T *X = B, overwriting B with X. +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = N + 90 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 100 +* + IF( IPIV( K-1 ).GT.0 ) THEN +* +* 2 x 2 diagonal block +* +* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation +* stored in columns K-1 and K of A. +* + IF( K.LT.N ) THEN + CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), + $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) + CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), + $ LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ), + $ LDB ) + END IF +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K-1 ) + IF( KP.NE.K ) THEN + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + K = K - 2 + ELSEIF( IPIV( K-1 ).LT.0 ) THEN +* +* 2 x 2 diagonal block +* +* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation +* stored in columns K-1 and K of A. +* + IF( K.LT.N ) THEN + CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), + $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) + CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), + $ LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ), + $ LDB ) + END IF +* +* Interchange rows K and -IPIV(K), then K and K-1. +* + KP = -IPIV( K-1 ) + IF( KP.NE.K ) THEN + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( K, 1 ), LDB ) + END IF + K = K - 2 + ELSE +* +* 2 x 2 diagonal block +* +* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation +* stored in columns K-1 and K of A. +* + IF( K.LT.N ) THEN + CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), + $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) + CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), + $ LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ), + $ LDB ) + END IF + K = K - 2 + END IF +* + GO TO 90 + 100 CONTINUE + END IF +* + RETURN +* +* End of DKYTRS +* + END diff --git a/SRC/dkytrs2.f b/SRC/dkytrs2.f new file mode 100644 index 000000000..5cd6447e3 --- /dev/null +++ b/SRC/dkytrs2.f @@ -0,0 +1,324 @@ +*> \brief \b DKYTRS2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DKYTRS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DKYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, +* WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DKYTRS2 solves a system of linear equations A*X = B with a real +*> skew-symmetric matrix A using the factorization A = U*D*U**T or +*> A = L*D*L**T computed by SKYTRF and converted by DKYCONV. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by SKYTRF. +*> Note that A is input / output. This might be counter-intuitive, +*> and one may think that A is input only. A is input / output. This +*> is because, at the start of the subroutine, we permute A in a +*> "better" form and then we permute A back to its original form at +*> the end. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by SKYTRF. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kytrs2 +* +* ===================================================================== + SUBROUTINE DKYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + $ WORK, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, IINFO, K, KP +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DKYCONV, DSWAP, DTRSM, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DKYTRS2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* +* Convert A +* + CALL DKYCONV( UPLO, 'C', N, A, LDA, IPIV, WORK, IINFO ) +* + IF( UPPER ) THEN +* +* Solve A*X = B, where A = U*D*U**T. +* +* P**T * B + K=N + DO WHILE ( K .GE. 2 ) + IF( IPIV( K ).GT.0 ) THEN +* 2 x 2 diagonal block +* Interchange rows K-1 and IPIV(K). + KP = IPIV( K ) + CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) + ELSEIF ( IPIV( K ).LT.0) THEN +* 2 x 2 diagonal block +* Interchange rows K-1 and -IPIV(K), then K and K-1. + KP = -IPIV( K ) + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( K-1, 1 ), LDB ) + CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + K=K-2 + END DO +* +* Compute (U \P**T * B) -> B [ (U \P**T * B) ] +* + CALL DTRSM('L','U','N','U',N,NRHS,ONE,A,LDA,B,LDB) +* +* Compute D \ B -> B [ D \ (U \P**T * B) ] +* + I=N + DO WHILE ( I .GE. 2 ) + CALL DSCAL( NRHS, -ONE / WORK( I ), B( I, 1 ), LDB ) + CALL DSCAL( NRHS, ONE / WORK( I ), B( I-1, 1 ), LDB ) + CALL DSWAP( NRHS, B( I, 1 ), LDB, B( I-1, 1 ), LDB ) + I = I - 2 + END DO +* +* Compute (U**T \ B) -> B [ U**T \ (D \ (U \P**T * B) ) ] +* + CALL DTRSM('L','U','T','U',N,NRHS,ONE,A,LDA,B,LDB) +* +* P * B [ P * (U**T \ (D \ (U \P**T * B) )) ] +* + K=2 + DO WHILE ( K .LE. N ) + IF( IPIV( K ).GT.0 ) THEN +* 2 x 2 diagonal block +* Interchange rows K-1 and IPIV(K). + KP = IPIV( K ) + CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) + ELSEIF ( IPIV( K ).LT.0) THEN +* 2 x 2 diagonal block +* Interchange rows K and K-1, then K-1 and -IPIV(K). + KP = -IPIV( K ) + CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( K-1, 1 ), LDB ) + ENDIF + K=K+2 + END DO +* + ELSE +* +* Solve A*X = B, where A = L*D*L**T. +* +* P**T * B + K=1 + DO WHILE ( K .LE. N-1 ) + IF( IPIV( K ).GT.0 ) THEN +* 2 x 2 diagonal block +* Interchange rows K+1 and IPIV(K). + KP = IPIV( K ) + CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) + ELSEIF ( IPIV( K ).LT.0) THEN +* 2 x 2 diagonal block +* Interchange rows K+1 and -IPIV(K), then K and K+1. + KP = -IPIV( K ) + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( K+1, 1 ), LDB ) + CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) + ENDIF + K=K+2 + END DO +* +* Compute (L \P**T * B) -> B [ (L \P**T * B) ] +* + CALL DTRSM('L','L','N','U',N,NRHS,ONE,A,LDA,B,LDB) +* +* Compute D \ B -> B [ D \ (L \P**T * B) ] +* + I=1 + DO WHILE ( I .LE. N-1 ) + CALL DSCAL( NRHS, -ONE / WORK( I ), B( I, 1 ), LDB ) + CALL DSCAL( NRHS, ONE / WORK( I ), B( I+1, 1 ), LDB ) + CALL DSWAP( NRHS, B( I, 1 ), LDB, B( I+1, 1 ), LDB ) + I = I + 2 + END DO +* +* Compute (L**T \ B) -> B [ L**T \ (D \ (L \P**T * B) ) ] +* + CALL DTRSM('L','L','T','U',N,NRHS,ONE,A,LDA,B,LDB) +* +* P * B [ P * (L**T \ (D \ (L \P**T * B) )) ] +* + K=N-1 + DO WHILE ( K .GE. 1 ) + IF( IPIV( K ).GT.0 ) THEN +* 2 x 2 diagonal block +* Interchange rows K+1 and IPIV(K). + KP = IPIV( K ) + CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) + ELSEIF ( IPIV( K ).LT.0) THEN +* 2 x 2 diagonal block +* Interchange rows K and K+1, then K+1 and -IPIV(K). + KP = -IPIV( K ) + CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( K+1, 1 ), LDB ) + ENDIF + K=K-2 + END DO +* + END IF +* +* Revert A +* + CALL DKYCONV( UPLO, 'R', N, A, LDA, IPIV, WORK, IINFO ) +* + RETURN +* +* End of DKYTRS2 +* + END diff --git a/SRC/dlakyf.f b/SRC/dlakyf.f new file mode 100644 index 000000000..379016a44 --- /dev/null +++ b/SRC/dlakyf.f @@ -0,0 +1,849 @@ +*> \brief \b DLAKYF computes a partial factorization of a real skew-symmetric matrix using the Bunch partial pivoting method. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SLASYF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAKYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), W( LDW, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAKYF computes a partial factorization of a real skew-symmetric matrix A +*> using the Bunch partial pivoting method. The partial factorization has +*> the form: +*> +*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: +*> ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) +*> +*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L' +*> ( L21 I ) ( 0 A22 ) ( 0 I ) +*> +*> where the order of D is at most NB. The actual order is returned in the +*> argument KB, and is either NB or NB-1, or N if N <= NB. +*> +*> DLAKYF is an auxiliary routine called by DKYTRF. It uses blocked code +*> (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or +*> A22 (if UPLO = 'L'). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> skew-symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The maximum number of columns of the matrix A that should be +*> factored. NB should be at least 2 to allow for 2-by-2 pivot +*> blocks. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> The number of columns of A that were actually factored. +*> KB is either NB-1 or NB, or N if N <= NB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the skew-symmetric matrix A. If UPLO = 'U', the +*> strictly upper triangular part of A contains the upper +*> triangular part of the matrix A, and the leading N-by-N lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> strictly lower triangular part of A contains the lower +*> triangular part of the matrix A, and the leading N-by-N upper +*> triangular part of A is not referenced. +*> On exit, A contains details of the partial factorization. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> Only the last KB elements of IPIV are set. +*> +*> The elements of array IPIV are combined in pair, and the first +*> element in the pair always keeps the value 0. If N is odd, the +*> first element of IPIV is 0, which is the only element not in pair. +*> So we only use the second element in the pair to determine the +*> interchanges. +*> +*> If IPIV(k) +*> = 0: there was no interchange. +*> > 0: rows and columns k-1 and IPIV(k) were interchanged. +*> < 0: rows and columns k and k-1 were interchanged, +*> then rows and columns k-1 and -IPIV(k) were interchanged. +*> +*> If UPLO = 'L': +*> Only the first KB elements of IPIV are set. +*> +*> The elements of array IPIV are combined in pair, and the second +*> element in the pair always keeps the value 0. If N is odd, the +*> last element of IPIV is 0, which is the only element not in pair. +*> So we only use the first element in the pair to determine the +*> interchanges. +*> +*> If IPIV(k) +*> = 0: there was no interchange. +*> > 0: rows and columns k+1 and IPIV(k) were interchanged。 +*> < 0: rows and columns k and k+1 were interchanged, +*> then rows and columns k+1 and -IPIV(k) were interchanged. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (LDW,NB) +*> \endverbatim +*> +*> \param[in] LDW +*> \verbatim +*> LDW is INTEGER +*> The leading dimension of the array W. LDW >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i-1,i) (if UPLO = 'U') or D(i+1,i) (if UPLO = 'L') +*> is exactly zero. The factorization has been completed, +*> but the block diagonal matrix D is exactly singular, +*> so the solution could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup lakyf +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> December 2023, Shuo Zheng +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DLAKYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), W( LDW, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER IMAX1, IMAX2, J, JB, JJ, JMAX, JP, K, + $ KP, KW, KADJ + DOUBLE PRECISION ABSAKP1K, COLMAX1, COLMAX2 +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + EXTERNAL LSAME, IDAMAX +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DSCAL, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + KADJ = 0 + +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Factorize the leading columns of A using the upper triangle +* of A and working forwards, and compute the matrix W = U12*D +* for use in updating A11 +* +* K is the main loop index, decreasing from N in steps of 2 +* + K = N + 10 CONTINUE + KW = NB + K - N +* +* Exit from loop +* + IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LE.2 ) THEN + IF ( NB.GE.N .AND. K.EQ.2 ) THEN + CALL DCOPY( K-1, A( 1, K ), 1, W( 1, KW ), 1 ) + W( K, KW ) = ZERO + IF( K.LT.N ) THEN + CALL DGEMV( 'No transpose', K, N-K, ONE, + $ A( 1, K+1 ), LDA, W( K, KW+1 ), LDW, + $ ONE, W( 1, KW ), 1 ) + END IF + A( K-1, K ) = W( K-1, KW ) + IF ( ABS( A( K-1, K ) ) .EQ. ZERO) THEN + IF( INFO.EQ.0 ) + $ INFO = K + END IF + IPIV( K ) = 0 + K = K-2 + ELSEIF ( NB.GE.N .AND. K.EQ.1 ) THEN + IF( INFO.EQ.0 ) + $ INFO = K +* K = K-1 + KADJ = 1 + END IF + GO TO 30 + END IF +* +* Copy column K and K-1 of A to column K and K-1 of W and update them +* + CALL DCOPY( K-1, A( 1, K ), 1, W( 1, KW ), 1 ) + CALL DCOPY( K-2, A( 1, K-1 ), 1, W( 1, KW-1 ), 1 ) + W( K, KW ) = ZERO + W( K-1, KW-1 ) = ZERO + IF( K.LT.N ) THEN + CALL DGEMV( 'No transpose', K, N-K, ONE, A( 1, K+1 ), + $ LDA, W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 ) + CALL DGEMV( 'No transpose', K-1, N-K, ONE, A( 1, K+1 ), + $ LDA, W( K-1, KW+1 ), LDW, ONE, W( 1, KW-1 ), 1 ) + END IF + + W( K, KW-1 ) = -W( K-1, KW ) +* +* Determine rows and columns to be interchanged +* + ABSAKP1K = ABS( W( K-1, KW ) ) +* +* IMAX1 is the row-index of the absolute value largest element in +* row 1 to K-2, column K. +* IMAX2 is the row-index of the absolute value largest element in +* row 1 to K-2 column K-1. +* COLMAX1 and COLMAX2 are their absolute values. +* + IF(K.GT.2) THEN + IMAX1 = IDAMAX( K-2, W( 1, KW ), 1 ) + COLMAX1 = ABS( W( IMAX1, KW ) ) + IMAX2 = IDAMAX( K-2, W( 1, KW-1 ), 1 ) + COLMAX2 = ABS( W( IMAX2, KW-1 ) ) + ELSE + IMAX1 = 0 + COLMAX1 = ZERO + IMAX2 = 0 + COLMAX2 = ZERO + ENDIF +* + IF( MAX(MAX( ABSAKP1K, COLMAX1 ), COLMAX2).EQ.ZERO ) THEN +* +* Column K and K+1 is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = 0 + IPIV( K ) = KP + ELSE + IF( ABSAKP1K.GE.MAX( COLMAX1, COLMAX2 ) ) THEN +* +* No interchange +* + KP = 0 + IPIV( K ) = KP + ELSE + + IF( COLMAX1.GE.COLMAX2 ) THEN + +* +* Absolute value largest element is in column K +* Interchange rows and columns K-1 and IMAX1 +* + KP = IMAX1 + IPIV( K ) = KP + +* +* Write the column KW-1 of W with elements in column IMAX1 +* + CALL DCOPY( IMAX1-1, A( 1, IMAX1 ), 1, + $ W( 1, KW-1 ), 1 ) + + W( IMAX1, KW-1 ) = ZERO + + CALL DCOPY( K-IMAX1, A( IMAX1, IMAX1+1 ), LDA, + $ W( IMAX1+1, KW-1 ), 1 ) + + CALL DSCAL( K-IMAX1, -ONE, W( IMAX1+1, KW-1 ), 1) + +* +* Update the column KW-1 of W +* + IF( K.LT.N ) THEN + CALL DGEMV( 'No transpose', K, N-K, ONE, + $ A( 1, K+1 ), LDA, W( IMAX1, KW+1 ), LDW, + $ ONE, W( 1, KW-1 ), 1 ) + END IF + +* W( K, KW-1 ) = -W( K-1, KW ) + +* +* Write the column IMAX1 of A with elements in column K-1 of A +* + CALL DCOPY( IMAX1-1, A( 1, K-1 ), 1, + $ A( 1, IMAX1 ), 1 ) + + CALL DCOPY( K-IMAX1-2, A( IMAX1+1, K-1 ), 1, + $ A( IMAX1, IMAX1+1 ), LDA ) + + CALL DSCAL( K-IMAX1-2, -ONE, A( IMAX1, IMAX1+1 ), + $ LDA) +* +* Interchange rows K-1 and IMAX1 in last K-1 columns of A +* + IF( K.LT.N ) THEN + CALL DSWAP( N-K, A( K-1, K+1 ), LDA, + $ A( IMAX1, K+1 ), LDA ) + END IF + +* +* Interchange rows K-1 and IMAX1 in last KW-1 columns of W +* + CALL DSWAP( N-K+2, W( K-1, KW-1 ), LDW, + $ W( IMAX1, KW-1 ), LDW ) + + ELSE + +* +* Absolute value largest element is in column K-1 +* Interchange rows and columns K and K-1, then Interchange K-1 and IMAX2 +* + KP = -IMAX2 + IPIV( K ) = KP + +* +* Interchange columns KW and KW-1, then write the column KW-1 of W with elements in column IMAX2 +* + CALL DSWAP( K, W( 1, KW ), 1, W( 1, KW-1 ), + $ 1 ) + + CALL DCOPY( IMAX2-1, A( 1, IMAX2 ), 1, + $ W( 1, KW-1 ), 1 ) + + W( IMAX2, KW-1 ) = ZERO + + CALL DCOPY( K-IMAX2, A( IMAX2, IMAX2+1 ), LDA, + $ W( IMAX2+1, KW-1 ), 1 ) + + CALL DSCAL( K-IMAX2, -ONE, W( IMAX2+1, KW-1 ), 1) + +* +* Update the column KW-1 of W +* + IF( K.LT.N ) THEN + CALL DGEMV( 'No transpose', K, N-K, ONE, + $ A( 1, K+1 ), LDA, W( IMAX2, KW+1 ), LDW, + $ ONE, W( 1, KW-1 ), 1 ) + END IF + +* W( K, KW-1 ) = -W( K-1, KW ) + +* Interchange rows K and K-1 columns of A +* + CALL DSWAP( K-2, A( 1, K ), 1, A( 1, K-1 ), + $ 1 ) + + A( K-1, K ) = -A( K-1, K ) + +* +* Write the column IMAX2 of A with elements in column K-1 of A +* + CALL DCOPY( IMAX2-1, A( 1, K-1 ), 1, + $ A( 1, IMAX2 ), 1 ) + + CALL DCOPY( K-IMAX2-2, A( IMAX2+1, K-1 ), 1, + $ A( IMAX2, IMAX2+1 ), LDA ) + + CALL DSCAL( K-IMAX2-2, -ONE, A( IMAX2, IMAX2+1 ), + $ LDA) +* +* Interchange rows K and K-1, then K-1 and IMAX2 in last K+1 columns of A +* + IF( K.LT.N ) THEN + CALL DSWAP( N-K, A( K, K+1 ), LDA, A( K-1, K+1 ), + $ LDA ) + + CALL DSWAP( N-K, A( K-1, K+1 ), LDA, + $ A( IMAX2, K+1 ), LDA ) + END IF + +* +* Interchange rows K and K-1, then K-1 and IMAX2 in last K-1 columns of W +* + CALL DSWAP( N-K+2, W( K, KW-1 ), LDW, + $ W( K-1, KW-1 ), LDW ) + + CALL DSWAP( N-K+2, W( K-1, KW-1 ), LDW, + $ W( IMAX2, KW-1 ), LDW ) + + END IF + END IF + +* +* Write back C*S^-1 to A +* + DO 20 J = 1, K-2 + A( J, K-1 ) = W( J, KW )/W( K-1, KW ) + A( J, K ) = -W( J, KW-1 )/W( K-1, KW ) +20 CONTINUE + + A( K-1, K ) = W( K-1, KW ) + + END IF + + K = K-2 + + GO TO 10 +* +30 CONTINUE + + KW = NB + K - N +* +* Update the upper triangle of A11 (= A(1:k,1:k)) as +* +* A11 := A11 + U12*D*U12**T = A11 + U12*W**T +* +* computing blocks of NB columns at a time +* + DO 50 J = 1, K, NB + JB = MIN( NB, K-J+1 ) + +* +* Update the rectangular subdiagonal block +* + IF( J+JB.LE.K ) + $ CALL DGEMM( 'No transpose', 'Transpose', K-J-JB+1, + $ JB, N-K, ONE, A( 1, K+1 ), LDA, + $ W( K-J-JB+2, KW+1 ), LDW, ONE, + $ A( 1, K-J-JB+2 ), LDA ) +* +* Update the upper triangle of the diagonal block +* + DO 40 JJ = 1, JB - 1 + CALL DGEMV( 'No transpose', JJ, N-K, ONE, + $ A( K-J-JB+2, K+1 ), LDA, + $ W( K+JJ-J-JB+2, KW+1 ), LDW, ONE, + $ A( K-J-JB+2, K+JJ-J-JB+2 ), 1 ) + 40 CONTINUE + + 50 CONTINUE +* +* Put U12 in standard form by partially undoing the interchanges +* of rows in columns 1:k-1 looping backwards from k-1 to 1 +* + J = N - K - 1 + 60 CONTINUE +* +* Undo the interchanges (if any) of rows JJ and JP at each +* step J +* +* (Here, J is a diagonal index) + + IF( J.GT.1 ) THEN + JJ = N-J+1 + JP = IPIV( N-J+1 ) + + IF( JP.LT.0 ) THEN + JP = -JP +* (Here, J is a diagonal index) + CALL DSWAP( J-1, A( JP, N-J+2 ), LDA, + $ A( JJ-1, N-J+2 ), LDA ) + CALL DSWAP( J-1, A( JJ-1, N-J+2 ), LDA, + $ A( JJ, N-J+2 ), LDA ) + ELSEIF( JP.GT.0 ) THEN + CALL DSWAP( J-1, A( JP, N-J+2 ), LDA, + $ A( JJ-1, N-J+2 ), LDA ) + END IF + + END IF +* (NOTE: Here, J is used to determine row length. Length J +* of the rows to swap back doesn't include diagonal element) + + J = J - 2 + IF( J.GT.1 ) + $ GO TO 60 +* +* Set KB to the number of columns factorized +* + KB = N - K + KADJ +* + ELSE +* +* Factorize the leading columns of A using the lower triangle +* of A and working forwards, and compute the matrix W = L21*D +* for use in updating A22 +* +* K is the main loop index, increasing from 1 in steps 2 +* + K = 1 + 70 CONTINUE +* +* Exit from loop +* + IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GE.N-1 ) THEN + IF( NB.GE.N .AND. K.EQ.N-1 ) THEN + CALL DCOPY( N-K, A( K+1, K ), 1, W( K+1, K ), 1 ) + W( K, K ) = ZERO + CALL DGEMV( 'No transpose', N-K+1, K-1, ONE, + $ A( K, 1 ), LDA, W( K, 1 ), LDW, ONE, + $ W( K, K ), 1 ) + A( K+1, K ) = W( K+1, K ) + IF ( ABS( A( K+1, K ) ) .EQ. ZERO) THEN + IF( INFO.EQ.0 ) + $ INFO = K + END IF + IPIV( K ) = 0 + K = K+2 + ELSEIF( NB.GE.N .AND. K.EQ.N ) THEN + IF( INFO.EQ.0 ) + $ INFO = K +* K = K+1 + KADJ = 1 + END IF + GO TO 90 + END IF +* +* Copy column K and K+1 of A to column K and K+1 of W and update them +* + CALL DCOPY( N-K, A( K+1, K ), 1, W( K+1, K ), 1 ) + CALL DCOPY( N-K-1, A( K+2, K+1 ), 1, W( K+2, K+1 ), 1 ) + W( K, K ) = ZERO + W( K+1, K+1 ) = ZERO + CALL DGEMV( 'No transpose', N-K+1, K-1, ONE, A( K, 1 ), + $ LDA, W( K, 1 ), LDW, ONE, W( K, K ), 1 ) + CALL DGEMV( 'No transpose', N-K, K-1, ONE, A( K+1, 1 ), + $ LDA, W( K+1, 1 ), LDW, ONE, W( K+1, K+1 ), 1 ) + + W( K, K+1 ) = -W( K+1, K ) +* +* Determine rows and columns to be interchanged +* + ABSAKP1K = ABS( W( K+1, K ) ) +* +* IMAX1 is the row-index of the absolute value largest element in +* row K+2 to N, column K. +* IMAX2 is the row-index of the absolute value largest element in +* row K+2 to N, column K+1. +* COLMAX1 and COLMAX2 are their absolute values. +* + IF(K.LT.N-1) THEN + IMAX1 = K+1 + IDAMAX( N-K-1, W( K+2, K ), 1 ) + COLMAX1 = ABS( W( IMAX1, K ) ) + IMAX2 = K+1 + IDAMAX( N-K-1, W( K+2, K+1 ), 1 ) + COLMAX2 = ABS( W( IMAX2, K+1 ) ) + ELSE + IMAX1 = 0 + COLMAX1 = ZERO + IMAX2 = 0 + COLMAX2 = ZERO + ENDIF +* + IF( MAX(MAX( ABSAKP1K, COLMAX1 ), COLMAX2).EQ.ZERO ) THEN +* +* Column K and K+1 is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = 0 + IPIV( K ) = KP + ELSE + IF( ABSAKP1K.GE.MAX( COLMAX1, COLMAX2 ) ) THEN +* +* No interchange +* + KP = 0 + IPIV( K ) = KP + ELSE + + IF( COLMAX1.GE.COLMAX2 ) THEN + +* +* Absolute value largest element is in column K +* Interchange rows and columns K+1 and IMAX1 +* + KP = IMAX1 + IPIV( K ) = KP + +* +* Write the column K+1 of W with elements in column IMAX1 +* + CALL DCOPY( IMAX1-K, A( IMAX1, K ), LDA, + $ W( K, K+1 ), 1 ) + + CALL DSCAL( IMAX1-K, -ONE, W( K, K+1 ), 1) + + W( IMAX1, K+1 ) = ZERO + + CALL DCOPY( N-IMAX1, A( IMAX1+1, IMAX1 ), 1, + $ W( IMAX1+1, K+1 ), 1 ) + +* +* Update the column K+1 of W +* + CALL DGEMV( 'No transpose', N-K+1, K-1, ONE, + $ A( K, 1 ), LDA, W( IMAX1, 1 ), LDW, ONE, + $ W( K, K+1 ), 1 ) + +* W( K, K+1 ) = -W( K+1, K ) + +* +* Write the column IMAX1 of A with elements in column K+1 of A +* + CALL DCOPY( IMAX1-K-2, A( K+2, K+1 ), 1, + $ A( IMAX1, K+2 ), LDA ) + + CALL DSCAL( IMAX1-K-2, -ONE, A( IMAX1, K+2 ), LDA) + + CALL DCOPY( N-IMAX1, A( IMAX1+1, K+1 ), 1, + $ A( IMAX1+1, IMAX1 ), 1 ) + +* +* Interchange rows K+1 and IMAX1 in first K-1 columns of A +* + CALL DSWAP( K-1, A( K+1, 1 ), LDA, A( IMAX1, 1 ), + $ LDA ) + +* +* Interchange rows K+1 and IMAX1 in first K-1 columns of W +* + CALL DSWAP( K+1, W( K+1, 1 ), LDW, W( IMAX1, 1 ), + $ LDW ) + + ELSE + +* +* Absolute value largest element is in column K+1 +* Interchange rows and columns K and K+1, then Interchange K+1 and IMAX2 +* + KP = -IMAX2 + IPIV( K ) = KP + +* +* Interchange columns K and K+1, then write the column K+1 of W with elements in column IMAX2 +* + CALL DSWAP( N-K+1, W( K, K ), 1, W( K, K+1 ), + $ 1 ) + + CALL DCOPY( IMAX2-K, A( IMAX2, K ), LDA, + $ W( K, K+1 ), 1 ) + + CALL DSCAL( IMAX2-K, -ONE, W( K, K+1 ), 1) + + W( IMAX2, K+1 ) = ZERO + + CALL DCOPY( N-IMAX2, A( IMAX2+1, IMAX2 ), 1, + $ W( IMAX2+1, K+1 ), 1 ) + +* +* Update the column K+1 of W +* + CALL DGEMV( 'No transpose', N-K+1, K-1, ONE, + $ A( K, 1 ), LDA, W( IMAX2, 1 ), LDW, ONE, + $ W( K, K+1 ), 1 ) + +* W( K, K+1 ) = -W( K+1, K ) + +* Interchange rows K and K+1 columns of A +* + CALL DSWAP( N-K-1, A( K+2, K ), 1, A( K+2, K+1 ), + $ 1 ) + + A( K+1, K ) = -A( K+1, K ) + +* +* Write the column IMAX2 of A with elements in column K+1 of A +* + CALL DCOPY( IMAX2-K-2, A( K+2, K+1 ), 1, + $ A( IMAX2, K+2 ), LDA ) + + CALL DSCAL( IMAX2-K-2, -ONE, A( IMAX2, K+2 ), LDA) + + CALL DCOPY( N-IMAX2, A( IMAX2+1, K+1 ), 1, + $ A( IMAX2+1, IMAX2 ), 1 ) + +* +* Interchange rows K and K+1, then K+1 and IMAX2 in first K-1 columns of A +* + CALL DSWAP( K-1, A( K, 1 ), LDA, A( K+1, 1 ), + $ LDA ) + + CALL DSWAP( K-1, A( K+1, 1 ), LDA, A( IMAX2, 1 ), + $ LDA ) + +* +* Interchange rows K and K+1, then K+1 and IMAX2 in first K-1 columns of W +* + CALL DSWAP( K+1, W( K, 1 ), LDW, W( K+1, 1 ), + $ LDW ) + + CALL DSWAP( K+1, W( K+1, 1 ), LDW, W( IMAX2, 1 ), + $ LDW ) + + END IF + END IF + +* +* Write back C*S^-1 to A +* + DO 80 J = K+2, N + A( J, K ) = -W( J, K+1 )/W( K+1, K ) + A( J, K+1 ) = W( J, K )/W( K+1, K ) +80 CONTINUE + + A( K+1, K ) = W( K+1, K ) + + END IF + + K = K+2 + + GO TO 70 +* +90 CONTINUE +* +* Update the lower triangle of A22 (= A(k:n,k:n)) as +* +* A22 := A22 + L21*D*L21**T = A22 + L21*W**T +* +* computing blocks of NB columns at a time +* + DO 110 J = K, N, NB + JB = MIN( NB, N-J+1 ) +* +* Update the lower triangle of the diagonal block +* + DO 100 JJ = J, J + JB - 2 + CALL DGEMV( 'No transpose', J+JB-JJ-1, K-1, ONE, + $ A( JJ+1, 1 ), LDA, W( JJ, 1 ), LDW, + $ ONE, A( JJ+1, JJ ), 1 ) + 100 CONTINUE +* +* Update the rectangular subdiagonal block +* + IF( J+JB.LE.N ) + $ CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, + $ K-1, ONE, A( J+JB, 1 ), LDA, W( J, 1 ), + $ LDW, ONE, A( J+JB, J ), LDA ) + 110 CONTINUE +* +* Put L21 in standard form by partially undoing the interchanges +* of rows in columns 1:k-1 looping backwards from k-1 to 1 +* + J = K - 2 + 120 CONTINUE +* +* Undo the interchanges (if any) of rows JJ and JP at each +* step J +* +* (Here, J is a diagonal index) + + IF( J.GT.1 ) THEN + JJ = J + JP = IPIV( J ) + + IF( JP.LT.0 ) THEN + JP = -JP +* (Here, J is a diagonal index) + CALL DSWAP( J-1, A( JP, 1 ), LDA, A( JJ+1, 1 ), + $ LDA ) + CALL DSWAP( J-1, A( JJ+1, 1 ), LDA, A( JJ, 1 ), + $ LDA ) + ELSEIF( JP.GT.0 ) THEN + CALL DSWAP( J-1, A( JP, 1 ), LDA, A( JJ+1, 1 ), + $ LDA ) + END IF + + END IF +* (NOTE: Here, J is used to determine row length. Length J +* of the rows to swap back doesn't include diagonal element) + + J = J - 2 + IF( J.GT.1 ) + $ GO TO 120 +* +* Set KB to the number of columns factorized +* + KB = K - 1 + KADJ +* + END IF + RETURN +* +* End of SLASYF +* + END diff --git a/SRC/dlankt.f b/SRC/dlankt.f new file mode 100644 index 000000000..9fe3e6e0e --- /dev/null +++ b/SRC/dlankt.f @@ -0,0 +1,175 @@ +*> \brief \b DLANKT returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real skew-symmetric tridiagonal matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLANKT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLANKT( NORM, N, E ) +* +* .. Scalar Arguments .. +* CHARACTER NORM +* INTEGER N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLANKT returns the value of the one norm, or the Frobenius norm, or +*> the infinity norm, or the element of largest absolute value of a +*> real skew-symmetric tridiagonal matrix A. +*> \endverbatim +*> +*> \return DLANKT +*> \verbatim +*> +*> DLANKT = ( max(abs(A(i,j))), NORM = 'M' or 'm' +*> ( +*> ( norm1(A), NORM = '1', 'O' or 'o' +*> ( +*> ( normI(A), NORM = 'I' or 'i' +*> ( +*> ( normF(A), NORM = 'F', 'f', 'E' or 'e' +*> +*> where norm1 denotes the one norm of a matrix (maximum column sum), +*> normI denotes the infinity norm of a matrix (maximum row sum) and +*> normF denotes the Frobenius norm of a matrix (square root of sum of +*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is CHARACTER*1 +*> Specifies the value to be returned in DLANKT as described +*> above. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. When N = 0, DLANKT is +*> set to zero. +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) sub-diagonal or super-diagonal elements of A. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup lankt +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLANKT( NORM, N, E ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER N +* .. +* .. Array Arguments .. + DOUBLE PRECISION E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION ANORM, SCALE, SUM +* .. +* .. External Functions .. + LOGICAL LSAME, DISNAN + EXTERNAL LSAME, DISNAN +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +* .. +* .. Executable Statements .. +* + IF( N.LE.0 ) THEN + ANORM = ZERO + ELSE IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + ANORM = ABS( E( N-1 ) ) + DO 10 I = 1, N - 2 + SUM = ABS( E( I ) ) + IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM + 10 CONTINUE + ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR. + $ LSAME( NORM, 'I' ) ) THEN +* +* Find norm1(A). +* + IF( N.EQ.1 ) THEN + ANORM = ZERO + ELSE + ANORM = ABS( E( 1 ) ) + SUM = ABS( E( N-1 ) ) + IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM + DO 20 I = 2, N - 1 + SUM = ABS( E( I ) )+ABS( E( I-1 ) ) + IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM + 20 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. + $ ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + IF( N.GT.1 ) THEN + CALL DLASSQ( N-1, E, 1, SCALE, SUM ) + SUM = 2*SUM + END IF + ANORM = SCALE*SQRT( SUM ) + END IF +* + DLANKT = ANORM + RETURN +* +* End of DLANKT +* + END diff --git a/SRC/dlanky.f b/SRC/dlanky.f new file mode 100644 index 000000000..d505e4328 --- /dev/null +++ b/SRC/dlanky.f @@ -0,0 +1,239 @@ +*> \brief \b DLANKY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real skew-symmetric matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLANKY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DLANKY( NORM, UPLO, N, A, LDA, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER NORM, UPLO +* INTEGER LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLANKY returns the value of the one norm, or the Frobenius norm, or +*> the infinity norm, or the element of largest absolute value of a +*> real skew-symmetric matrix A. +*> \endverbatim +*> +*> \return DLANKY +*> \verbatim +*> +*> DLANKY = ( max(abs(A(i,j))), NORM = 'M' or 'm' +*> ( +*> ( norm1(A), NORM = '1', 'O' or 'o' +*> ( +*> ( normI(A), NORM = 'I' or 'i' +*> ( +*> ( normF(A), NORM = 'F', 'f', 'E' or 'e' +*> +*> where norm1 denotes the one norm of a matrix (maximum column sum), +*> normI denotes the infinity norm of a matrix (maximum row sum) and +*> normF denotes the Frobenius norm of a matrix (square root of sum of +*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is CHARACTER*1 +*> Specifies the value to be returned in DLANKY as described +*> above. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> skew-symmetric matrix A is to be referenced. +*> = 'U': Upper triangular part of A is referenced +*> = 'L': Lower triangular part of A is referenced +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. When N = 0, DLANKY is +*> set to zero. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The skew-symmetric matrix A. If UPLO = 'U', the leading n by n +*> upper triangular part of A contains the upper triangular part +*> of the matrix A, and the strictly lower triangular part of A +*> is not referenced. If UPLO = 'L', the leading n by n lower +*> triangular part of A contains the lower triangular part of +*> the matrix A, and the strictly upper triangular part of A is +*> not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(N,1). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), +*> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, +*> WORK is not referenced. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup lanke +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DLANKY( NORM, UPLO, N, A, LDA, WORK ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER NORM, UPLO + INTEGER LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION ABSA, SCALE, SUM, VALUE +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. External Functions .. + LOGICAL LSAME, DISNAN + EXTERNAL LSAME, DISNAN +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +* .. +* .. Executable Statements .. +* + IF( N.EQ.0 ) THEN + VALUE = ZERO + ELSE IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + VALUE = ZERO + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, J - 1 + SUM = ABS( A( I, J ) ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = J + 1, N + SUM = ABS( A( I, J ) ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 30 CONTINUE + 40 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. + $ ( LSAME( NORM, 'O' ) ) .OR. + $ ( NORM.EQ.'1' ) ) THEN +* +* Find normI(A) ( = norm1(A), since A is skew-symmetric). +* + VALUE = ZERO + IF( LSAME( UPLO, 'U' ) ) THEN + DO 60 J = 1, N + SUM = ZERO + DO 50 I = 1, J - 1 + ABSA = ABS( A( I, J ) ) + SUM = SUM + ABSA + WORK( I ) = WORK( I ) + ABSA + 50 CONTINUE + WORK( J ) = SUM + 60 CONTINUE + DO 70 I = 1, N + SUM = WORK( I ) + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 70 CONTINUE + ELSE + DO 80 I = 1, N + WORK( I ) = ZERO + 80 CONTINUE + DO 100 J = 1, N + SUM = WORK( J ) + DO 90 I = J + 1, N + ABSA = ABS( A( I, J ) ) + SUM = SUM + ABSA + WORK( I ) = WORK( I ) + ABSA + 90 CONTINUE + IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM + 100 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. + $ ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + IF( LSAME( UPLO, 'U' ) ) THEN + DO 110 J = 2, N + CALL DLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) + 110 CONTINUE + ELSE + DO 120 J = 1, N - 1 + CALL DLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) + 120 CONTINUE + END IF + SUM = 2*SUM + VALUE = SCALE*SQRT( SUM ) + END IF +* + DLANKY = VALUE + RETURN +* +* End of DLANKY +* + END diff --git a/SRC/dlatrdk.f b/SRC/dlatrdk.f new file mode 100644 index 000000000..bebf2a958 --- /dev/null +++ b/SRC/dlatrdk.f @@ -0,0 +1,332 @@ +*> \brief \b DLATRDK reduces the first nb rows and columns of a skew-symmetric/Hermitian matrix A to DOUBLE PRECISION tridiagonal form by an orthogonal similarity transformation. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLATRDK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLATRDK( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDW, N, NB +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLATRDK reduces NB rows and columns of a DOUBLE PRECISION skew-symmetric matrix A to +*> skew-symmetric tridiagonal form by an orthogonal similarity +*> transformation Q**T * A * Q, and returns the matrices V and W which are +*> needed to apply the transformation to the unreduced part of A. +*> +*> If UPLO = 'U', DLATRDK reduces the last NB rows and columns of a +*> matrix, of which the upper triangle is supplied; +*> if UPLO = 'L', DLATRDK reduces the first NB rows and columns of a +*> matrix, of which the lower triangle is supplied. +*> +*> This is an auxiliary routine called by SSYTRD. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> skew-symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The number of rows and columns to be reduced. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the skew-symmetric matrix A. If UPLO = 'U', the strictly +*> n-by-n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the leading lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> strictly n-by-n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the leading upper +*> triangular part of A is not referenced. +*> On exit: +*> if UPLO = 'U', the last NB columns have been reduced to +*> tridiagonal form, with the elements above the diagonal +*> with the array TAU, represent the orthogonal matrix Q as a +*> product of elementary reflectors; +*> if UPLO = 'L', the first NB columns have been reduced to +*> tridiagonal form, with the elements below the diagonal +*> with the array TAU, represent the orthogonal matrix Q as a +*> product of elementary reflectors. +*> See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= (1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal +*> elements of the last NB columns of the reduced matrix; +*> if UPLO = 'L', E(1:nb) contains the subdiagonal elements of +*> the first NB columns of the reduced matrix. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (N-1) +*> The scalar factors of the elementary reflectors, stored in +*> TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. +*> See Further Details. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is DOUBLE PRECISION array, dimension (LDW,NB) +*> The n-by-nb matrix W required to update the unreduced part +*> of A. +*> \endverbatim +*> +*> \param[in] LDW +*> \verbatim +*> LDW is INTEGER +*> The leading dimension of the array W. LDW >= max(1,N). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup latrdk +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', the matrix Q is represented as a product of elementary +*> reflectors +*> +*> Q = H(n) H(n-1) . . . H(n-nb+1). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), +*> and tau in TAU(i-1). +*> +*> If UPLO = 'L', the matrix Q is represented as a product of elementary +*> reflectors +*> +*> Q = H(1) H(2) . . . H(nb). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), +*> and tau in TAU(i). +*> +*> The elements of the vectors v together form the n-by-nb matrix V +*> which is needed, with W, to apply the transformation to the unreduced +*> part of the matrix, using a skew-symmetric rank-2k update of the form: +*> A := A - V*W**T + W*V**T. +*> +*> The contents of A on exit are illustrated by the following examples +*> with n = 5 and nb = 2: +*> +*> if UPLO = 'U': if UPLO = 'L': +*> +*> ( 0 a a v4 v5 ) ( 0 ) +*> ( 0 a v4 v5 ) ( 1 0 ) +*> ( 0 1 v5 ) ( v1 1 0 ) +*> ( 0 1 ) ( v1 v2 a 0 ) +*> ( 0 ) ( v1 v2 a a 0 ) +*> +*> where a denotes an element of the original matrix that is unchanged, +*> and vi denotes an element of the vector defining H(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DLATRDK( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDW, N, NB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IW + DOUBLE PRECISION ALPHA +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DGEMV, DLARFG, DSCAL, DKYMV +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Reduce last NB columns of upper triangle +* + DO 10 I = N, N - NB + 1, -1 + IW = I - N + NB + IF( I.LT.N ) THEN +* +* Update A(1:i,i) +* + CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), + $ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, -ONE, W( 1, + $ IW+1 ), + $ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 ) + END IF + IF( I.GT.1 ) THEN +* +* Generate elementary reflector H(i) to annihilate +* A(1:i-2,i) +* + CALL DLARFG( I-1, A( I-1, I ), A( 1, I ), 1, + $ TAU( I-1 ) ) + E( I-1 ) = A( I-1, I ) + A( I-1, I ) = ONE +* +* Compute W(1:i-1,i) +* + CALL DKYMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1, + $ ZERO, W( 1, IW ), 1 ) + IF( I.LT.N ) THEN + CALL DGEMV( 'Transpose', I-1, N-I, ONE, W( 1, + $ IW+1 ), + $ LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, ONE, + $ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE, + $ W( 1, IW ), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, + $ I+1 ), + $ LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, -ONE, + $ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE, + $ W( 1, IW ), 1 ) + END IF + CALL DSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 ) + END IF +* + 10 CONTINUE + ELSE +* +* Reduce first NB columns of lower triangle +* + DO 20 I = 1, NB +* +* Update A(i:n,i) +* + CALL DGEMV( 'No transpose', N-I, I-1, ONE, A( I+1, 1 ), + $ LDA, W( I, 1 ), LDW, ONE, A( I+1, I ), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ), + $ LDW, A( I, 1 ), LDA, ONE, A( I+1, I ), 1 ) + IF( I.LT.N ) THEN +* +* Generate elementary reflector H(i) to annihilate +* A(i+2:n,i) +* + CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, + $ TAU( I ) ) + E( I ) = A( I+1, I ) + A( I+1, I ) = ONE +* +* Compute W(i+1:n,i) +* + CALL DKYMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA, + $ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, W( I+1, 1 ), + $ LDW, + $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, A( I+1, + $ 1 ), + $ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), + $ LDA, + $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, + $ 1 ), + $ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) + CALL DSCAL( N-I, TAU( I ), W( I+1, I ), 1 ) + END IF +* + 20 CONTINUE + END IF +* + RETURN +* +* End of DLATRDK +* + END diff --git a/SRC/ilaenv.f b/SRC/ilaenv.f index e74a2b35e..e47918126 100644 --- a/SRC/ilaenv.f +++ b/SRC/ilaenv.f @@ -390,6 +390,26 @@ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN NB = 64 END IF + ELSE IF( C2.EQ.'KY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( TWOSTAGE ) THEN + NB = 192 + ELSE + NB = 64 + END IF + ELSE + IF( TWOSTAGE ) THEN + NB = 192 + ELSE + NB = 64 + END IF + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN + NB = 64 + END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRF' ) THEN IF( TWOSTAGE ) THEN @@ -565,6 +585,16 @@ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN NBMIN = 2 END IF + ELSE IF( C2.EQ.'KY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NBMIN = 8 + ELSE + NBMIN = 8 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRD' ) THEN NBMIN = 2 @@ -642,6 +672,10 @@ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) IF( SNAME .AND. C3.EQ.'TRD' ) THEN NX = 32 END IF + ELSE IF( C2.EQ.'KY' ) THEN + IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NX = 32 + END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRD' ) THEN NX = 32 diff --git a/SRC/lapack_64.h b/SRC/lapack_64.h index 4d7318d97..792bfc0a1 100644 --- a/SRC/lapack_64.h +++ b/SRC/lapack_64.h @@ -9,9 +9,11 @@ #define BLAS_DGBMV_X BLAS_DGBMV_X_64 #define BLAS_DGEMV_X BLAS_DGEMV_X_64 #define BLAS_DSYMV_X BLAS_DSYMV_X_64 +#define BLAS_DKYMV_X BLAS_DKYMV_X_64 #define BLAS_SGBMV_X BLAS_SGBMV_X_64 #define BLAS_SGEMV_X BLAS_SGEMV_X_64 #define BLAS_SSYMV_X BLAS_SSYMV_X_64 +#define BLAS_SKYMV_X BLAS_SKYMV_X_64 #define BLAS_ZGBMV_X BLAS_ZGBMV_X_64 #define BLAS_ZGEMV_X BLAS_ZGEMV_X_64 #define BLAS_ZHEMV_X BLAS_ZHEMV_X_64 @@ -757,7 +759,9 @@ #define DLANSF DLANSF_64 #define DLANSP DLANSP_64 #define DLANST DLANST_64 +#define DLANKT DLANKT_64 #define DLANSY DLANSY_64 +#define DLANKY DLANKY_64 #define DLANTB DLANTB_64 #define DLANTP DLANTP_64 #define DLANTR DLANTR_64 @@ -858,6 +862,7 @@ #define DLASY2 DLASY2_64 #define DLA_SYAMV DLA_SYAMV_64 #define DLASYF DLASYF_64 +#define DLAKYF DLAKYF_64 #define DLASYF_AA DLASYF_AA_64 #define DLASYF_RK DLASYF_RK_64 #define DLASYF_ROOK DLASYF_ROOK_64 @@ -869,6 +874,7 @@ #define DLATDF DLATDF_64 #define DLATPS DLATPS_64 #define DLATRD DLATRD_64 +#define DLATRDK DLATRDK_64 #define DLATRS DLATRS_64 #define DLATRS3 DLATRS3_64 #define DLATRZ DLATRZ_64 @@ -1007,8 +1013,10 @@ #define DSTEIN DSTEIN_64 #define DSTEMR DSTEMR_64 #define DSTEQR DSTEQR_64 +#define DKTEQR DKTEQR_64 #define DSTERF DSTERF_64 #define DSTEV DSTEV_64 +#define DKTEV DKTEV_64 #define DSTEVD DSTEVD_64 #define DSTEVR DSTEVR_64 #define DSTEVX DSTEVX_64 @@ -1017,10 +1025,12 @@ #define DSYCON_3 DSYCON_3_64 #define DSYCON_ROOK DSYCON_ROOK_64 #define DSYCONV DSYCONV_64 +#define DKYCONV DKYCONV_64 #define DSYCONVF DSYCONVF_64 #define DSYCONVF_ROOK DSYCONVF_ROOK_64 #define DSYEQUB DSYEQUB_64 #define DSYEV DSYEV_64 +#define DKYEV DKYEV_64 #define DSYEV_2STAGE DSYEV_2STAGE_64 #define DSYEVD DSYEVD_64 #define DSYEVD_2STAGE DSYEVD_2STAGE_64 @@ -1029,20 +1039,28 @@ #define DSYEVX DSYEVX_64 #define DSYEVX_2STAGE DSYEVX_2STAGE_64 #define DSYGS2 DSYGS2_64 +#define DKYGS2 DKYGS2_64 #define DSYGST DSYGST_64 +#define DKYGST DKYGST_64 #define DSYGV DSYGV_64 +#define DKYGV DKYGV_64 #define DSYGV_2STAGE DSYGV_2STAGE_64 #define DSYGVD DSYGVD_64 #define DSYGVX DSYGVX_64 #define DSYMM DSYMM_64 +#define DKYMM DKYMM_64 #define DSYMV DSYMV_64 +#define DKYMV DKYMV_64 #define DSYR DSYR_64 #define DSYR2 DSYR2_64 +#define DKYR2 DKYR2_64 #define DSYR2K DSYR2K_64 +#define DKYR2K DKYR2K_64 #define DSYRFS DSYRFS_64 #define DSYRFSX DSYRFSX_64 #define DSYRK DSYRK_64 #define DSYSV DSYSV_64 +#define DKYSV DKYSV_64 #define DSYSV_AA DSYSV_AA_64 #define DSYSV_AA_2STAGE DSYSV_AA_2STAGE_64 #define DSYSV_RK DSYSV_RK_64 @@ -1050,27 +1068,37 @@ #define DSYSVX DSYSVX_64 #define DSYSVXX DSYSVXX_64 #define DSYSWAPR DSYSWAPR_64 +#define DKYSWAPR DKYSWAPR_64 #define DSYTD2 DSYTD2_64 +#define DKYTD2 DKYTD2_64 #define DSYTF2 DSYTF2_64 +#define DKYTF2 DKYTF2_64 #define DSYTF2_RK DSYTF2_RK_64 #define DSYTF2_ROOK DSYTF2_ROOK_64 #define DSYTRD DSYTRD_64 +#define DKYTRD DKYTRD_64 #define DSYTRD_2STAGE DSYTRD_2STAGE_64 #define DSYTRD_SB2ST DSYTRD_SB2ST_64 #define DSYTRD_SY2SB DSYTRD_SY2SB_64 #define DSYTRF DSYTRF_64 +#define DKYTRF DKYTRF_64 #define DSYTRF_AA DSYTRF_AA_64 #define DSYTRF_AA_2STAGE DSYTRF_AA_2STAGE_64 #define DSYTRF_RK DSYTRF_RK_64 #define DSYTRF_ROOK DSYTRF_ROOK_64 #define DSYTRI DSYTRI_64 +#define DKYTRI DKYTRI_64 #define DSYTRI2 DSYTRI2_64 +#define DKYTRI2 DKYTRI2_64 #define DSYTRI2X DSYTRI2X_64 +#define DKYTRI2X DKYTRI2X_64 #define DSYTRI_3 DSYTRI_3_64 #define DSYTRI_3X DSYTRI_3X_64 #define DSYTRI_ROOK DSYTRI_ROOK_64 #define DSYTRS DSYTRS_64 +#define DKYTRS DKYTRS_64 #define DSYTRS2 DSYTRS2_64 +#define DKYTRS2 DKYTRS2_64 #define DSYTRS_3 DSYTRS_3_64 #define DSYTRS_AA DSYTRS_AA_64 #define DSYTRS_AA_2STAGE DSYTRS_AA_2STAGE_64 @@ -1349,7 +1377,9 @@ #define SLANSF SLANSF_64 #define SLANSP SLANSP_64 #define SLANST SLANST_64 +#define SLANKT SLANKT_64 #define SLANSY SLANSY_64 +#define SLANKY SLANKY_64 #define SLANTB SLANTB_64 #define SLANTP SLANTP_64 #define SLANTR SLANTR_64 @@ -1450,6 +1480,7 @@ #define SLASY2 SLASY2_64 #define SLA_SYAMV SLA_SYAMV_64 #define SLASYF SLASYF_64 +#define SLAKYF SLAKYF_64 #define SLASYF_AA SLASYF_AA_64 #define SLASYF_RK SLASYF_RK_64 #define SLASYF_ROOK SLASYF_ROOK_64 @@ -1460,6 +1491,7 @@ #define SLATDF SLATDF_64 #define SLATPS SLATPS_64 #define SLATRD SLATRD_64 +#define SLATRDK SLATRDK_64 #define SLATRS SLATRS_64 #define SLATRS3 SLATRS3_64 #define SLATRZ SLATRZ_64 @@ -1595,8 +1627,10 @@ #define SSTEIN SSTEIN_64 #define SSTEMR SSTEMR_64 #define SSTEQR SSTEQR_64 +#define SKTEQR SKTEQR_64 #define SSTERF SSTERF_64 #define SSTEV SSTEV_64 +#define SKTEV SKTEV_64 #define SSTEVD SSTEVD_64 #define SSTEVR SSTEVR_64 #define SSTEVX SSTEVX_64 @@ -1605,10 +1639,12 @@ #define SSYCON_3 SSYCON_3_64 #define SSYCON_ROOK SSYCON_ROOK_64 #define SSYCONV SSYCONV_64 +#define SKYCONV SKYCONV_64 #define SSYCONVF SSYCONVF_64 #define SSYCONVF_ROOK SSYCONVF_ROOK_64 #define SSYEQUB SSYEQUB_64 #define SSYEV SSYEV_64 +#define SKYEV SKYEV_64 #define SSYEV_2STAGE SSYEV_2STAGE_64 #define SSYEVD SSYEVD_64 #define SSYEVD_2STAGE SSYEVD_2STAGE_64 @@ -1617,20 +1653,28 @@ #define SSYEVX SSYEVX_64 #define SSYEVX_2STAGE SSYEVX_2STAGE_64 #define SSYGS2 SSYGS2_64 +#define SKYGS2 SKYGS2_64 #define SSYGST SSYGST_64 +#define SKYGST SKYGST_64 #define SSYGV SSYGV_64 +#define SKYGV SKYGV_64 #define SSYGV_2STAGE SSYGV_2STAGE_64 #define SSYGVD SSYGVD_64 #define SSYGVX SSYGVX_64 #define SSYMM SSYMM_64 +#define SKYMM SKYMM_64 #define SSYMV SSYMV_64 +#define SKYMV SKYMV_64 #define SSYR SSYR_64 #define SSYR2 SSYR2_64 +#define SKYR2 SKYR2_64 #define SSYR2K SSYR2K_64 +#define SKYR2K SKYR2K_64 #define SSYRFS SSYRFS_64 #define SSYRFSX SSYRFSX_64 #define SSYRK SSYRK_64 #define SSYSV SSYSV_64 +#define SKYSV SKYSV_64 #define SSYSV_AA SSYSV_AA_64 #define SSYSV_AA_2STAGE SSYSV_AA_2STAGE_64 #define SSYSV_RK SSYSV_RK_64 @@ -1638,27 +1682,37 @@ #define SSYSVX SSYSVX_64 #define SSYSVXX SSYSVXX_64 #define SSYSWAPR SSYSWAPR_64 +#define SKYSWAPR SKYSWAPR_64 #define SSYTD2 SSYTD2_64 +#define SKYTD2 SKYTD2_64 #define SSYTF2 SSYTF2_64 +#define SKYTF2 SKYTF2_64 #define SSYTF2_RK SSYTF2_RK_64 #define SSYTF2_ROOK SSYTF2_ROOK_64 #define SSYTRD SSYTRD_64 +#define SKYTRD SKYTRD_64 #define SSYTRD_2STAGE SSYTRD_2STAGE_64 #define SSYTRD_SB2ST SSYTRD_SB2ST_64 #define SSYTRD_SY2SB SSYTRD_SY2SB_64 #define SSYTRF SSYTRF_64 +#define SKYTRF SKYTRF_64 #define SSYTRF_AA SSYTRF_AA_64 #define SSYTRF_AA_2STAGE SSYTRF_AA_2STAGE_64 #define SSYTRF_RK SSYTRF_RK_64 #define SSYTRF_ROOK SSYTRF_ROOK_64 #define SSYTRI SSYTRI_64 +#define SKYTRI SKYTRI_64 #define SSYTRI2 SSYTRI2_64 +#define SKYTRI2 SKYTRI2_64 #define SSYTRI2X SSYTRI2X_64 +#define SKYTRI2X SKYTRI2X_64 #define SSYTRI_3 SSYTRI_3_64 #define SSYTRI_3X SSYTRI_3X_64 #define SSYTRI_ROOK SSYTRI_ROOK_64 #define SSYTRS SSYTRS_64 +#define SKYTRS SKYTRS_64 #define SSYTRS2 SSYTRS2_64 +#define SKYTRS2 SKYTRS2_64 #define SSYTRS_3 SSYTRS_3_64 #define SSYTRS_AA SSYTRS_AA_64 #define SSYTRS_AA_2STAGE SSYTRS_AA_2STAGE_64 diff --git a/SRC/skteqr.f b/SRC/skteqr.f new file mode 100644 index 000000000..1a2e4e7ea --- /dev/null +++ b/SRC/skteqr.f @@ -0,0 +1,860 @@ +*> \brief \b SKTEQR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SKTEQR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SKTEQR( COMPZ, N, E, Z, LDZ, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER COMPZ +* INTEGER INFO, LDZ, N +* .. +* .. Array Arguments .. +* REAL E( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SKTEQR computes all eigenvalues and, optionally, eigenvectors of a +*> skew-symmetric tridiagonal matrix using the implicit double shift +*> QL or QR method. +*> The eigenvectors of a full skew-symmetric matrix can be found if +*> SKYTRD has been used to reduce this matrix to tridiagonal form. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] COMPZ +*> \verbatim +*> COMPZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only. +*> = 'V': Compute eigenvalues and eigenvectors of the original +*> skew-symmetric matrix. On entry, Z must contain the +*> orthogonal matrix used to reduce the original matrix +*> to tridiagonal form. +*> = 'I': Compute eigenvalues and eigenvectors of the +*> tridiagonal matrix. Z is initialized to the identity +*> matrix. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. N >= 0. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is REAL array, dimension (N-1) +*> On entry, the (n-1) lower subdiagonal elements of the +*> tridiagonal matrix. +*> On exit, the (n-1) lower subdiagonal elements of the +*> block diagonal matrix. If INFO = 0, the matrix consists +*> of 2-by-2 skew-symmetric blocks, and zeros. +*> The values in E, which represent blocks, are always +*> positive, and sorted in descending order. +*> The eigenvalues of each blocks can be evaluated directly. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is REAL array, dimension (LDZ, N) +*> On entry, if COMPZ = 'V', then Z contains the orthogonal +*> matrix used in the reduction to tridiagonal form. +*> On exit, if INFO = 0, then if COMPZ = 'V', Z is the +*> orthogonal matrix transforming the original skew-symmetric +*> matrix to the block diagonal matrix, and if COMPZ = 'I', +*> Z is the orthogonal matrix transforming the skew-symmetric +*> tridiagonal matrix to the block diagonal matrix. +*> The eigenvectors of corresponding matrix can be evaluated +*> directly. +*> If COMPZ = 'N', then Z is not referenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> eigenvectors are desired, then LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array. +*> WORK is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: the algorithm has failed to find all the eigenvalues in +*> a total of 30*N iterations; if INFO = i, then i +*> elements of E have not converged to zero; on exit +*> E contain the elements of a skew-symmetric tridiagonal +*> matrix which is orthogonally similar to the original +*> matrix. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kteqr +* +* ===================================================================== + SUBROUTINE SKTEQR( COMPZ, N, E, Z, LDZ, WORK, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER COMPZ + INTEGER INFO, LDZ, N +* .. +* .. Array Arguments .. + REAL E( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0, + $ THREE = 3.0E0 ) + INTEGER MAXIT + PARAMETER ( MAXIT = 30 ) +* .. +* .. Local Scalars .. + INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, + $ LENDM1, LENDP1, LENDSV, LM3, LSV, M, MM1, + $ NM1, NMAXIT + REAL ANORM, B, EPS, EPS2, P, R, VA, VB, E3, + $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SLAMCH, SLAPY2 + EXTERNAL LSAME, SLAMCH, SLAPY2 +* .. +* .. External Subroutines .. + EXTERNAL SLAE2, SLAEV2, SLARTG, SLASCL, SLASET, + $ SLASRT, SSWAP, SSCAL, SROT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SIGN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( LSAME( COMPZ, 'N' ) ) THEN + ICOMPZ = 0 + ELSE IF( LSAME( COMPZ, 'V' ) ) THEN + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ICOMPZ = 2 + ELSE + ICOMPZ = -1 + END IF + IF( ICOMPZ.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, + $ N ) ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SKTEQR', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0) + $ RETURN +* + IF( N.EQ.1) THEN + IF( ICOMPZ.EQ.2 ) + $ Z( 1, 1 ) = ONE + RETURN + END IF +* + IF( N.EQ.2) THEN + IF( ICOMPZ.EQ.2 ) THEN + Z( 1, 1 ) = ONE + Z( 1, 2 ) = ZERO + Z( 2, 1 ) = ZERO + Z( 2, 2 ) = ONE + END IF + IF( E(1).LT.ZERO ) THEN + E(1) = -E(1) + CALL SSWAP( N, Z( 1, 1 ), 1, Z( 1, 2 ), 1 ) + END IF + RETURN + END IF +* +* Determine the unit roundoff and over/underflow thresholds. +* + EPS = SLAMCH( 'E' ) + EPS2 = EPS**2 + SAFMIN = SLAMCH( 'S' ) + SAFMAX = ONE / SAFMIN + SSFMAX = SQRT( SAFMAX ) / THREE + SSFMIN = SQRT( SAFMIN ) / EPS2 +* +* Compute the eigenvalues and eigenvectors of the tridiagonal +* matrix. +* + IF( ICOMPZ.EQ.2 ) + $ CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +* + NMAXIT = N*MAXIT + JTOT = 0 +* +* Determine where the matrix splits and choose QL or QR iteration +* for each block, according to whether top or bottom diagonal +* element is smaller. +* + L1 = 1 + NM1 = N - 1 +* + 10 CONTINUE + IF( L1.GT.N ) + $ GO TO 160 + IF( L1.GT.1 ) + $ E( L1-1 ) = ZERO + IF( L1.LE.NM1 ) THEN + DO 20 M = L1, NM1 + TST = ABS( E( M ) ) + IF( TST.EQ.ZERO ) + $ GO TO 30 + IF( TST.LE.( ABS( E( M+ + $ 1 ) ) )*EPS .AND. M.EQ.L1 ) THEN + E( M ) = ZERO + GO TO 30 + ELSEIF( TST.LE.( ABS( E( M- + $ 1 ) ) )*EPS .AND. M.EQ.NM1 ) THEN + E( M ) = ZERO + GO TO 30 + ELSEIF( TST.LE.( SQRT( ABS( E( M-1 ) ) )* + $ SQRT( ABS( E( M+1 ) ) ) )*EPS ) THEN + E( M ) = ZERO + GO TO 30 + END IF + 20 CONTINUE + END IF + M = N +* + 30 CONTINUE + L = L1 + LSV = L + LEND = M + LENDSV = LEND + L1 = M + 1 + IF( LEND.EQ.L ) + $ GO TO 10 +* +* Scale submatrix in rows and columns L to LEND +* + ANORM = SLANKT( 'M', LEND-L+1, E( L ) ) + ISCALE = 0 + IF( ANORM.EQ.ZERO ) + $ GO TO 10 + IF( ANORM.GT.SSFMAX ) THEN + ISCALE = 1 + CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, + $ INFO ) + ELSE IF( ANORM.LT.SSFMIN ) THEN + ISCALE = 2 + CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, + $ INFO ) + END IF +* +* Choose between QL and QR iteration +* + IF( L.NE.LEND ) THEN + IF( ABS( E( LEND-1 ) ).LT.ABS( E( L ) ) ) THEN + LEND = LSV + L = LENDSV + END IF + END IF +* + IF( LEND.GT.L ) THEN +* +* QL Iteration +* +* Look for small subdiagonal element. +* + 40 CONTINUE + IF( L.NE.LEND .AND. L.NE.LEND-1 ) THEN + LENDM1 = LEND - 1 + DO 50 M = L, LENDM1 + TST = ABS( E( M ) )**2 + IF( TST.LE.( EPS2*ABS( E( M+1 ) ) )*ABS( E( M+1 ) )+ + $ SAFMIN .AND. M.EQ.L) THEN + GO TO 60 + ELSEIF( TST.LE.( EPS2*ABS( E( M-1 ) ) )*ABS( E( M-1 ) )+ + $ SAFMIN .AND. M.EQ.LENDM1 ) THEN + GO TO 60 + ELSEIF( TST.LE.( EPS2*ABS( E( M-1 ) ) )*ABS( E( M+1 ) )+ + $ SAFMIN ) THEN + GO TO 60 + END IF + 50 CONTINUE + END IF +* + M = LEND +* + 60 CONTINUE + IF( M.LT.LEND ) + $ E( M ) = ZERO +* + IF( M.EQ.L ) + $ GO TO 80 +* +* If remaining matrix is 2-by-2, get its eigensystem directly +* + IF( M.EQ.L+1 ) THEN + L = L + 2 + IF( L.LE.LEND ) + $ GO TO 40 + GO TO 140 + END IF +* +* Exit if all iteratives have been done +* + IF( JTOT.EQ.NMAXIT ) + $ GO TO 140 + JTOT = JTOT + 1 +* +* If remaining matrix is 3-by-3, get its eigensystem directly +* + IF( M.EQ.L+2 ) THEN + IF ( MOD( JTOT, 10 ).EQ.0 ) THEN + B = E(L)*E(L) * (ONE - MIN(ABS(E(L+1)/E(L)), ONE)) + ELSE + B = E(L)*E(L) + END IF + P = -E(M-1)*E(M-1) + B + R = E(M-1)*E(M-2) + S = SIGN(SLAPY2( P, R ), P) +* + IF(S.EQ.ZERO) THEN + VA = -ONE + VB = ZERO + ELSE + VA = -P/S + VB = -R/S + END IF +* +* Update E. +* + TEMP = E(M-1) + E(M-1) = VA*E(M-1) - VB*E(M-2) + E(M-2) = -VB*TEMP - VA*E(M-2) +* +* If eigenvectors are desired, then update Z initially. +* + IF( ICOMPZ.GT.0 ) THEN + CALL SROT(N, Z(1, M), 1, Z(1, M-2), 1, VA, VB) + CALL SSCAL(N, -ONE, Z(1, M-2), 1) + END IF +* + I = L + 1 +* +* Update E. +* + E(I) = -E(I) + E(I-1) = -E(I-1) +* +* If eigenvectors are desired, then update Z. +* + IF( ICOMPZ.GT.0 ) THEN + CALL SSCAL(N, -ONE, Z(1, I), 1) + END IF +* + GO TO 40 + END IF +* +* Form shift and set initial values. +* + IF ( MOD( JTOT, 10 ).EQ.0 ) THEN + B = E(L)*E(L) * (ONE - MIN(ABS(E(L+1)/E(L)), ONE)) + ELSE + B = E(L)*E(L) + END IF + P = -E(M-1)*E(M-1) + B + R = E(M-1)*E(M-2) + S = SIGN(SLAPY2( P, R ), P) +* + IF(S.EQ.ZERO) THEN + VA = -ONE + VB = ZERO + ELSE + VA = -P/S + VB = -R/S + END IF +* +* Update E. +* + TEMP = E(M-1) + E(M-1) = VA*E(M-1) - VB*E(M-2) + E(M-2) = -VB*TEMP - VA*E(M-2) + E3 = E(M-3) + E(M-3) = -VA*E(M-3) +* +* If eigenvectors are desired, then update Z initially. +* + IF( ICOMPZ.GT.0 ) THEN + CALL SROT(N, Z(1, M), 1, Z(1, M-2), 1, VA, VB) + CALL SSCAL(N, -ONE, Z(1, M-2), 1) + END IF +* +* Inner loop +* + MM1 = M - 1 + DO 70 I = MM1, L+3, -1 +* +* Set iterative values. +* + P = E(I) + R = VB*E3 + S = SIGN(SLAPY2( P, R ), P) + E(I) = -S +* + IF(S.EQ.ZERO) THEN + VA = -ONE + VB = ZERO + ELSE + VA = -P/S + VB = -R/S + END IF +* +* Update E. +* + TEMP = E(I-1) + E(I-1) = VA*E(I-1) - VB*E(I-2) + E(I-2) = -VB*TEMP - VA*E(I-2) + E3 = E(I-3) + E(I-3) = -VA*E(I-3) +* +* If eigenvectors are desired, then update Z. +* + IF( ICOMPZ.GT.0 ) THEN + CALL SROT(N, Z(1, I), 1, Z(1, I-2), 1, VA, VB) + CALL SSCAL(N, -ONE, Z(1, I-2), 1) + END IF +* + 70 CONTINUE +* + I = L + 2 +* +* Set iterative values. +* + P = E(I) + R = VB*E3 + S = SIGN(SLAPY2( P, R ), P) + E(I) = -S +* + IF(S.EQ.ZERO) THEN + VA = -ONE + VB = ZERO + ELSE + VA = -P/S + VB = -R/S + END IF +* +* Update E. +* + TEMP = E(I-1) + E(I-1) = VA*E(I-1) - VB*E(I-2) + E(I-2) = -VB*TEMP - VA*E(I-2) +* +* If eigenvectors are desired, then update Z. +* + IF( ICOMPZ.GT.0 ) THEN + CALL SROT(N, Z(1, I), 1, Z(1, I-2), 1, VA, VB) + CALL SSCAL(N, -ONE, Z(1, I-2), 1) + END IF +* + I = L + 1 +* +* Update E. +* + E(I) = -E(I) + E(I-1) = -E(I-1) +* +* If eigenvectors are desired, then update Z. +* + IF( ICOMPZ.GT.0 ) THEN + CALL SSCAL(N, -ONE, Z(1, I), 1) + END IF +* + GO TO 40 +* +* Eigenvalue found. +* + 80 CONTINUE + L = L + 1 + IF( L.LE.LEND ) + $ GO TO 40 + GO TO 140 +* + ELSE +* +* QR Iteration +* +* Look for small superdiagonal element. +* + 90 CONTINUE + IF( L.NE.LEND .AND. L.NE.LEND+1 ) THEN + LENDP1 = LEND + 1 + DO 100 M = L, LENDP1, -1 + TST = ABS( E( M-1 ) )**2 + IF( TST.LE.( EPS2*ABS( E( M-2 ) ) )*ABS( E( M-2 ) )+ + $ SAFMIN .AND. M.EQ.L) THEN + GO TO 110 + ELSEIF( TST.LE.( EPS2*ABS( E( M ) ) )*ABS( E( M ) )+ + $ SAFMIN .AND. M.EQ.LENDP1 ) THEN + GO TO 110 + ELSEIF( TST.LE.( EPS2*ABS( E( M-2 ) ) )*ABS( E( M ) )+ + $ SAFMIN ) THEN + GO TO 110 + END IF + 100 CONTINUE + END IF +* + M = LEND +* + 110 CONTINUE + IF( M.GT.LEND ) + $ E( M-1 ) = ZERO +* + IF( M.EQ.L ) + $ GO TO 130 +* +* If remaining matrix is 2-by-2, get its eigensystem directly +* + IF( M.EQ.L-1 ) THEN + L = L - 2 + IF( L.GE.LEND ) + $ GO TO 90 + GO TO 140 + END IF +* +* Exit if all iteratives have been done +* + IF( JTOT.EQ.NMAXIT ) + $ GO TO 140 + JTOT = JTOT + 1 +* +* If remaining matrix is 3-by-3, get its eigensystem directly +* + IF( M.EQ.L-2 ) THEN + IF ( MOD( JTOT, 10 ).EQ.0 ) THEN + B = E(L-1)*E(L-1) * (ONE - MIN(ABS(E(L-2)/E(L-1)), ONE)) + ELSE + B = E(L-1)*E(L-1) + END IF + P = -E(M)*E(M) + B + R = E(M)*E(M+1) + S = SIGN(SLAPY2( P, R ), P) +* + IF(S.EQ.ZERO) THEN + VA = -ONE + VB = ZERO + ELSE + VA = -P/S + VB = -R/S + END IF +* +* Update E. +* + TEMP = E(M) + E(M) = VA*E(M) - VB*E(M+1) + E(M+1) = -VB*TEMP - VA*E(M+1) +* +* If eigenvectors are desired, then update Z initially. +* + IF( ICOMPZ.GT.0 ) THEN + CALL SROT(N, Z(1, M), 1, Z(1, M+2), 1, VA, VB) + CALL SSCAL(N, -ONE, Z(1, M+2), 1) + END IF +* + I = L - 1 +* +* Update E. +* + E(I-1) = -E(I-1) + E(I) = -E(I) +* +* If eigenvectors are desired, then update Z. +* + IF( ICOMPZ.GT.0 ) THEN + CALL SSCAL(N, -ONE, Z(1, I), 1) + END IF +* + GO TO 90 + END IF +* +* Form shift and set initial values. +* + IF ( MOD( JTOT, 10 ).EQ.0 ) THEN + B = E(L-1)*E(L-1) * (ONE - MIN(ABS(E(L-2)/E(L-1)), ONE)) + ELSE + B = E(L-1)*E(L-1) + END IF + P = -E(M)*E(M) + B + R = E(M)*E(M+1) + S = SIGN(SLAPY2( P, R ), P) +* + IF(S.EQ.ZERO) THEN + VA = -ONE + VB = ZERO + ELSE + VA = -P/S + VB = -R/S + END IF +* +* Update E. +* + TEMP = E(M) + E(M) = VA*E(M) - VB*E(M+1) + E(M+1) = -VB*TEMP - VA*E(M+1) + E3 = E(M+2) + E(M+2) = -VA*E(M+2) +* +* If eigenvectors are desired, then update Z initially. +* + IF( ICOMPZ.GT.0 ) THEN + CALL SROT(N, Z(1, M), 1, Z(1, M+2), 1, VA, VB) + CALL SSCAL(N, -ONE, Z(1, M+2), 1) + END IF +* +* Inner loop +* + LM3 = L - 3 + DO 120 I = M + 1, LM3 +* +* Set iterative values. +* + P = E(I-1) + R = VB*E3 + S = SIGN(SLAPY2( P, R ), P) + E(I-1) = -S +* + IF(S.EQ.ZERO) THEN + VA = -ONE + VB = ZERO + ELSE + VA = -P/S + VB = -R/S + END IF +* +* Update E. +* + TEMP = E(I) + E(I) = VA*E(I) - VB*E(I+1) + E(I+1) = -VB*TEMP - VA*E(I+1) + E3 = E(I+2) + E(I+2) = -VA*E(I+2) +* +* If eigenvectors are desired, then update Z. +* + IF( ICOMPZ.GT.0 ) THEN + CALL SROT(N, Z(1, I), 1, Z(1, I+2), 1, VA, VB) + CALL SSCAL(N, -ONE, Z(1, I+2), 1) + END IF +* + 120 CONTINUE +* + I = L - 2 +* +* Set iterative values. +* + P = E(I-1) + R = VB*E3 + S = SIGN(SLAPY2( P, R ), P) + E(I-1) = -S +* + IF(S.EQ.ZERO) THEN + VA = -ONE + VB = ZERO + ELSE + VA = -P/S + VB = -R/S + END IF +* +* Update E. +* + TEMP = E(I) + E(I) = VA*E(I) - VB*E(I+1) + E(I+1) = -VB*TEMP - VA*E(I+1) +* +* If eigenvectors are desired, then update Z. +* + IF( ICOMPZ.GT.0 ) THEN + CALL SROT(N, Z(1, I), 1, Z(1, I+2), 1, VA, VB) + CALL SSCAL(N, -ONE, Z(1, I+2), 1) + END IF +* + I = L - 1 +* +* Update E. +* + E(I-1) = -E(I-1) + E(I) = -E(I) +* +* If eigenvectors are desired, then update Z. +* + IF( ICOMPZ.GT.0 ) THEN + CALL SSCAL(N, -ONE, Z(1, I), 1) + END IF +* + GO TO 90 +* +* Eigenvalue found. +* + 130 CONTINUE + L = L - 1 + IF( L.GE.LEND ) + $ GO TO 90 + GO TO 140 +* + END IF +* +* Undo scaling if necessary +* + 140 CONTINUE + IF( ISCALE.EQ.1 ) THEN + CALL SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E(LSV), + $ N, INFO ) + ELSE IF( ISCALE.EQ.2 ) THEN + CALL SLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E(LSV), + $ N, INFO ) + END IF +* +* Check for no convergence to an eigenvalue after a total +* of N*MAXIT iterations. +* + IF( JTOT.LT.NMAXIT ) + $ GO TO 10 + DO 150 I = 1, N - 1 + IF( E( I ).NE.ZERO ) + $ INFO = INFO + 1 + 150 CONTINUE + GO TO 190 +* +* Order blocks. +* Use Selection Sort to minimize swaps of eigenvectors +* + 160 CONTINUE + II = 1 + DO WHILE(II.LT.(N-1)) + IF(E(II).EQ.ZERO) THEN + DO K = II+1,N-1,2 + IF(E(K).EQ.ZERO) THEN + DO I = II, K-2 + E(I) = E(I+1) + IF( ICOMPZ.GT.0 ) THEN + CALL SSWAP( N, Z( 1, I ), 1, Z( 1, I+1 ), 1 ) + END IF + END DO + E(K-1) = ZERO + II = K+1 + EXIT + ELSEIF(MOD(N,2).EQ.1 .AND. K.EQ.(N-1)) THEN + DO I = II, K-1 + E(I) = E(I+1) + IF( ICOMPZ.GT.0 ) THEN + CALL SSWAP( N, Z( 1, I ), 1, Z( 1, I+1 ), 1 ) + END IF + END DO + IF( ICOMPZ.GT.0 ) THEN + CALL SSWAP( N, Z( 1, K ), 1, Z( 1, K+1 ), 1 ) + END IF + E(K) = ZERO + II = K+1 + EXIT + ELSEIF(MOD(N,2).EQ.0 .AND. K.EQ.(N-2)) THEN + DO I = II, K-1 + E(I) = E(I+1) + IF( ICOMPZ.GT.0 ) THEN + CALL SSWAP( N, Z( 1, I ), 1, Z( 1, I+1 ), 1 ) + END IF + END DO + IF( ICOMPZ.GT.0 ) THEN + CALL SSWAP( N, Z( 1, K ), 1, Z( 1, K+1 ), 1 ) + END IF + E(K) = ZERO + II = K+1 + EXIT + END IF + END DO + IF (II.LT.(N-1)) THEN + CYCLE + END IF + END IF + II = II+2 + END DO +* + DO 180 II = 1, N-1, 2 + I = II + P = ABS(E(II)) + DO 170 K = II+2, N-1, 2 + IF(ABS(E(K)).GT.P) THEN + I = K + P = ABS(E(K)) + END IF + 170 CONTINUE + IF(I.NE.II) THEN + CALL SSWAP( 1, E( I ), 1, E( II ), 1 ) + IF( ICOMPZ.GT.0 ) THEN + CALL SSWAP( N, Z( 1, I ), 1, Z( 1, II ), 1 ) + CALL SSWAP( N, Z( 1, I+1 ), 1, Z( 1, II+1 ), 1 ) + END IF + END IF + IF(E(II).LT.ZERO) THEN + E(II) = -E(II) + IF( ICOMPZ.GT.0 ) THEN + CALL SSWAP( N, Z( 1, II ), 1, Z( 1, II+1 ), 1 ) + END IF + END IF + 180 CONTINUE +* + 190 CONTINUE + RETURN +* +* End of SKTEQR +* + END diff --git a/SRC/sktev.f b/SRC/sktev.f new file mode 100644 index 000000000..545edefed --- /dev/null +++ b/SRC/sktev.f @@ -0,0 +1,238 @@ +*> \brief SKTEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SKTEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SKTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ +* INTEGER INFO, LDZ, N +* .. +* .. Array Arguments .. +* REAL D( * ), E( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SKTEV computes all eigenvalues and, optionally, eigenvectors of a +*> real skew-symmetric tridiagonal matrix A. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. N >= 0. +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is REAL array, dimension (N) +*> If INFO = 0, the (N-1) lower subdiagonal elements of the +*> block diagonal matrix at front, and zero at last. +*> The matrix consists of 2-by-2 skew-symmetric blocks, and zeros. +*> The values in D, which represent blocks, are always +*> positive, and sorted in descending order. +*> The eigenvalues of each blocks can be evaluated directly. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is REAL array, dimension (N-1) +*> On entry, the (n-1) subdiagonal elements of the tridiagonal +*> matrix A, stored in elements 1 to N-1 of E. +*> On exit, the contents of E are destroyed. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is REAL array, dimension (LDZ, N) +*> If JOBZ = 'V', then if INFO = 0, Z is the orthogonal matrix +*> transforming the skew-symmetric tridiagonal matrix to the +*> block diagonal matrix. The eigenvectors of corresponding matrix +*> can be evaluated directly. +*> If JOBZ = 'N', then Z is not referenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= 1, and if +*> JOBZ = 'V', LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array. +*> WORK is not referenced. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of E did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup ktev +* +* ===================================================================== + SUBROUTINE SKTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO ) +* +* -- LAPACK driver routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER JOBZ + INTEGER INFO, LDZ, N +* .. +* .. Array Arguments .. + REAL D( * ), E( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) +* .. +* .. Local Scalars .. + LOGICAL WANTZ + INTEGER IMAX, ISCALE + REAL BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM, + $ TNRM +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SLAMCH, SLANKT + EXTERNAL LSAME, SLAMCH, SLANKT +* .. +* .. External Subroutines .. + EXTERNAL SSCAL, SCOPY, SKTEQR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) +* + INFO = 0 + IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -6 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SKTEV ', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + D(1) = ZERO + IF( WANTZ ) + $ Z( 1, 1 ) = ONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = SLAMCH( 'Safe minimum' ) + EPS = SLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ISCALE = 0 + TNRM = SLANKT( 'M', N, E ) + IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / TNRM + ELSE IF( TNRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / TNRM + END IF + IF( ISCALE.EQ.1 ) THEN + CALL SSCAL( N-1, SIGMA, E( 1 ), 1 ) + END IF +* +* call SKTEQR. +* + IF( .NOT.WANTZ ) THEN + CALL SKTEQR( 'N', N, E, Z, LDZ, WORK, INFO ) + ELSE + CALL SKTEQR( 'I', N, E, Z, LDZ, WORK, INFO ) + END IF +* + CALL SCOPY(N-1, E, 1, D, 1) + D(N) = ZERO +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = N + ELSE + IMAX = INFO - 1 + END IF + CALL SSCAL( IMAX, ONE / SIGMA, D, 1 ) + END IF +* + RETURN +* +* End of SKTEV +* + END diff --git a/SRC/skyconv.f b/SRC/skyconv.f new file mode 100644 index 000000000..f985c00a5 --- /dev/null +++ b/SRC/skyconv.f @@ -0,0 +1,341 @@ +*> \brief \b SKYCONV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SKYCONV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SKYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO, WAY +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SKYCONV convert A given by TRF into L and D and vice-versa. +*> Get Non-diag elements of D (returned in workspace) and +*> apply or reverse permutation done in TRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] WAY +*> \verbatim +*> WAY is CHARACTER*1 +*> = 'C': Convert +*> = 'R': Revert +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by SKYTRF. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by SKYTRF. +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is REAL array, dimension (N) +*> E stores the supdiagonal/subdiagonal of the skew-symmetric +*> 2-by-2 block diagonal matrix D in LDLT. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kyconv +* +* ===================================================================== + SUBROUTINE SKYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO, WAY + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER ( ZERO = 0.0E+0 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Local Scalars .. + LOGICAL UPPER, CONVERT + INTEGER I, IP, J + REAL TEMP +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + CONVERT = LSAME( WAY, 'C' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.CONVERT .AND. .NOT.LSAME( WAY, 'R' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SKYCONV', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* A is UPPER +* +* Convert A (A is upper) +* +* Convert VALUE +* + IF ( CONVERT ) THEN + I=N + E(1)=ZERO + DO WHILE ( I .GT. 1 ) + E(I)=A(I-1,I) + A(I-1,I)=ZERO + I=I-2 + END DO +* +* Convert PERMUTATIONS +* + I=N-2 + DO WHILE ( I .GT. 1 ) + IF( IPIV(I) .GT. 0) THEN + IP=IPIV(I) + DO 12 J= I+1,N + TEMP=A(IP,J) + A(IP,J)=A(I-1,J) + A(I-1,J)=TEMP + 12 CONTINUE + ELSEIF( IPIV(I) .LT. 0) THEN + IP=-IPIV(I) + DO 13 J= I+1,N + TEMP=A(I,J) + A(I,J)=A(I-1,J) + A(I-1,J)=TEMP + + TEMP=A(IP,J) + A(IP,J)=A(I-1,J) + A(I-1,J)=TEMP + 13 CONTINUE + ENDIF + I=I-2 + END DO + + ELSE +* +* Revert A (A is upper) +* +* +* Revert PERMUTATIONS +* + I=2 + DO WHILE ( I .LT. N-1 ) + IF( IPIV(I) .GT. 0 ) THEN + IP=IPIV(I) + DO J= I+1,N + TEMP=A(IP,J) + A(IP,J)=A(I-1,J) + A(I-1,J)=TEMP + END DO + ELSEIF( IPIV(I) .LT. 0 ) THEN + IP=-IPIV(I) + DO J= I+1,N + TEMP=A(IP,J) + A(IP,J)=A(I-1,J) + A(I-1,J)=TEMP + + TEMP=A(I,J) + A(I,J)=A(I-1,J) + A(I-1,J)=TEMP + END DO + ENDIF + I=I+2 + END DO +* +* Revert VALUE +* + I=N + DO WHILE ( I .GT. 1 ) + A(I-1,I)=E(I) + I=I-2 + END DO + END IF + ELSE +* +* A is LOWER +* + IF ( CONVERT ) THEN +* +* Convert A (A is lower) +* +* +* Convert VALUE +* + I=1 + E(N)=ZERO + DO WHILE ( I .LT. N ) + E(I)=A(I+1,I) + A(I+1,I)=ZERO + I=I+2 + END DO +* +* Convert PERMUTATIONS +* + I=3 + DO WHILE ( I .LT. N ) + IF( IPIV(I) .GT. 0 ) THEN + IP=IPIV(I) + DO 22 J= 1,I-1 + TEMP=A(IP,J) + A(IP,J)=A(I+1,J) + A(I+1,J)=TEMP + 22 CONTINUE + ELSEIF( IPIV(I) .LT. 0 ) THEN + IP=-IPIV(I) + DO 23 J= 1,I-1 + TEMP=A(I,J) + A(I,J)=A(I+1,J) + A(I+1,J)=TEMP + + TEMP=A(IP,J) + A(IP,J)=A(I+1,J) + A(I+1,J)=TEMP + 23 CONTINUE + ENDIF + I=I+2 + END DO + ELSE +* +* Revert A (A is lower) +* +* +* Revert PERMUTATIONS +* + I=N-1 + DO WHILE ( I .GT. 2 ) + IF( IPIV(I) .GT. 0 ) THEN + IP=IPIV(I) + DO J= 1,I-1 + TEMP=A(I+1,J) + A(I+1,J)=A(IP,J) + A(IP,J)=TEMP + END DO + ELSEIF( IPIV(I) .LT. 0 ) THEN + IP=-IPIV(I) + DO J= 1,I-1 + TEMP=A(I+1,J) + A(I+1,J)=A(IP,J) + A(IP,J)=TEMP + + TEMP=A(I+1,J) + A(I+1,J)=A(I,J) + A(I,J)=TEMP + END DO + ENDIF + I=I-2 + END DO +* +* Revert VALUE +* + I=1 + DO WHILE ( I .LT. N ) + A(I+1,I)=E(I) + I=I+2 + END DO + END IF + END IF + + RETURN +* +* End of SKYCONV +* + END diff --git a/SRC/skyev.f b/SRC/skyev.f new file mode 100644 index 000000000..05a6d57a4 --- /dev/null +++ b/SRC/skyev.f @@ -0,0 +1,292 @@ +*> \brief SKYEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for KY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SKYEV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SKYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), W( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SKYEV computes all eigenvalues and, optionally, eigenvectors of a +*> real skew-symmetric matrix A. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA, N) +*> On entry, the skew-symmetric matrix A. If UPLO = 'U', the +*> strictly N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the strictly N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> On exit, if JOBZ = 'V', then if INFO = 0, A is the +*> orthogonal matrix transforming the original skew-symmetric +*> matrix to block skew-symmetric form in W. +*> The eigenvectors of the matrix can be evaluated directly. +*> If JOBZ = 'N', then on exit the strictly lower triangle +*> (if UPLO='L') or the upper triangle (if UPLO='U') of A, +*> is destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is REAL array, dimension (N) +*> If INFO = 0, the (N-1) lower subdiagonal elements of the +*> block diagonal matrix at front, and zero at last. +*> The matrix consists of 2-by-2 skew-symmetric blocks, and zeros. +*> The values in W, which represent blocks, are always +*> positive, and sorted in descending order. +*> The eigenvalues of each blocks can be evaluated directly. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= max(1,2*N-1). +*> For optimal efficiency, LWORK >= (NB+1)*N, +*> where NB is the blocksize for SKYTRD returned by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, the algorithm failed to converge; i +*> off-diagonal elements of an intermediate tridiagonal +*> form did not converge to zero. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kyev +* +* ===================================================================== + SUBROUTINE SKYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) +* +* -- LAPACK driver routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + REAL A( LDA, * ), W( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, LQUERY, WANTZ + INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, + $ LLWORK, LWKOPT, NB + REAL ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + REAL SLAMCH, SLANKY, SROUNDUP_LWORK + EXTERNAL ILAENV, LSAME, SLAMCH, SLANKY, + $ SROUNDUP_LWORK +* .. +* .. External Subroutines .. + EXTERNAL SLASCL, SORGTR, SSCAL, SKTEQR, SKYTRD, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF +* + IF( INFO.EQ.0 ) THEN + NB = ILAENV( 1, 'SKYTRD', UPLO, N, -1, -1, -1 ) + LWKOPT = MAX( 1, ( NB+1 )*N ) + WORK( 1 ) = SROUNDUP_LWORK(LWKOPT) +* + IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY ) + $ INFO = -8 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SKYEV ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + RETURN + END IF +* + IF( N.EQ.1 ) THEN + W( 1 ) = ZERO + WORK( 1 ) = 2 + IF( WANTZ ) + $ A( 1, 1 ) = ONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = SLAMCH( 'Safe minimum' ) + EPS = SLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ANRM = SLANKY( 'M', UPLO, N, A, LDA, WORK ) + ISCALE = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) + $ CALL SLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) +* +* Call SKYTRD to reduce skew-symmetric matrix to tridiagonal form. +* + INDE = 1 + INDTAU = 1 + INDWRK = INDTAU + N + LLWORK = LWORK - INDWRK + 1 + CALL SKYTRD( UPLO, N, A, LDA, W, WORK( INDTAU ), + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* For eigenvalues only, call SKTEQR, For eigenvectors, first call +* SORGTR to generate the orthogonal matrix, then call SKTEQR. +* + IF( WANTZ ) THEN + CALL SORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), + $ LLWORK, IINFO ) + END IF + IF(.NOT.LOWER) + $ CALL SSCAL(N-1, -ONE, W, 1) + CALL SKTEQR( JOBZ, N, W, A, LDA, WORK( INDTAU ), + $ INFO ) + W(N) = ZERO +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = N + ELSE + IMAX = INFO - 1 + END IF + CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = SROUNDUP_LWORK(LWKOPT) +* + RETURN +* +* End of SKYEV +* + END diff --git a/SRC/skygs2.f b/SRC/skygs2.f new file mode 100644 index 000000000..430f3a612 --- /dev/null +++ b/SRC/skygs2.f @@ -0,0 +1,257 @@ +*> \brief \b SKYGS2 reduces a skew-symmetric definite generalized eigenproblem to standard form, using the factorization results obtained from spotrf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SKYGS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SKYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, ITYPE, LDA, LDB, N +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SKYGS2 reduces a real skew-symmetric-definite generalized eigenproblem +*> to standard form. +*> +*> If ITYPE = 1, the problem is A*x = lambda*B*x, +*> and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) +*> +*> If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or +*> B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T *A*L. +*> +*> B must have been previously factorized as U**T *U or L*L**T by SPOTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is INTEGER +*> = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); +*> = 2 or 3: compute U*A*U**T or L**T *A*L. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> skew-symmetric matrix A is stored, and how B has been factorized. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the skew-symmetric matrix A. If UPLO = 'U', the +*> strictly n by n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the leading lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> strictly n by n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the leading upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, the transformed matrix, stored in the +*> same format as A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is REAL array, dimension (LDB,N) +*> The triangular factor from the Cholesky factorization of B, +*> as returned by SPOTRF. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kygs2 +* +* ===================================================================== + SUBROUTINE SKYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, ITYPE, LDA, LDB, N +* .. +* .. Array Arguments .. + REAL A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, HALF + PARAMETER ( ONE = 1.0, HALF = 0.5 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER K + REAL BKK +* .. +* .. External Subroutines .. + EXTERNAL SAXPY, SSCAL, SKYR2, STRMV, STRSV, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN + INFO = -1 + ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SKYGS2', -INFO ) + RETURN + END IF +* + IF( ITYPE.EQ.1 ) THEN + IF( UPPER ) THEN +* +* Compute inv(U**T)*A*inv(U) +* + DO 10 K = 1, N +* +* Update the upper triangle of A(k:n,k:n) +* + BKK = B( K, K ) + IF( K.LT.N ) THEN + CALL SSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA ) + CALL SKYR2( UPLO, N-K, -ONE, A( K, K+1 ), LDA, + $ B( K, K+1 ), LDB, A( K+1, K+1 ), LDA ) + CALL STRSV( UPLO, 'Transpose', 'Non-unit', N-K, + $ B( K+1, K+1 ), LDB, A( K, K+1 ), LDA ) + END IF + 10 CONTINUE + ELSE +* +* Compute inv(L)*A*inv(L**T) +* + DO 20 K = 1, N +* +* Update the lower triangle of A(k:n,k:n) +* + BKK = B( K, K ) + IF( K.LT.N ) THEN + CALL SSCAL( N-K, ONE / BKK, A( K+1, K ), 1 ) + CALL SKYR2( UPLO, N-K, ONE, A( K+1, K ), 1, + $ B( K+1, K ), 1, A( K+1, K+1 ), LDA ) + CALL STRSV( UPLO, 'No transpose', 'Non-unit', N-K, + $ B( K+1, K+1 ), LDB, A( K+1, K ), 1 ) + END IF + 20 CONTINUE + END IF + ELSE + IF( UPPER ) THEN +* +* Compute U*A*U**T +* + DO 30 K = 1, N +* +* Update the upper triangle of A(1:k,1:k) +* + BKK = B( K, K ) + CALL STRMV( UPLO, 'No transpose', 'Non-unit', K-1, B, + $ LDB, A( 1, K ), 1 ) + CALL SKYR2( UPLO, K-1, -ONE, A( 1, K ), 1, B( 1, K ), 1, + $ A, LDA ) + CALL SSCAL( K-1, BKK, A( 1, K ), 1 ) + 30 CONTINUE + ELSE +* +* Compute L**T *A*L +* + DO 40 K = 1, N +* +* Update the lower triangle of A(1:k,1:k) +* + BKK = B( K, K ) + CALL STRMV( UPLO, 'Transpose', 'Non-unit', K-1, B, LDB, + $ A( K, 1 ), LDA ) + CALL SKYR2( UPLO, K-1, ONE, A( K, 1 ), LDA, B( K, 1 ), + $ LDB, A, LDA ) + CALL SSCAL( K-1, BKK, A( K, 1 ), LDA ) + 40 CONTINUE + END IF + END IF + RETURN +* +* End of SKYGS2 +* + END diff --git a/SRC/skygst.f b/SRC/skygst.f new file mode 100644 index 000000000..9461f32ba --- /dev/null +++ b/SRC/skygst.f @@ -0,0 +1,319 @@ +*> \brief \b SKYGST +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SKYGST + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SKYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, ITYPE, LDA, LDB, N +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SKYGST reduces a real skew-symmetric-definite generalized eigenproblem +*> to standard form. +*> +*> If ITYPE = 1, the problem is A*x = lambda*B*x, +*> and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) +*> +*> If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or +*> B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L. +*> +*> B must have been previously factorized as U**T*U or L*L**T by SPOTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is INTEGER +*> = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); +*> = 2 or 3: compute U*A*U**T or L**T*A*L. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored and B is factored as +*> U**T*U; +*> = 'L': Lower triangle of A is stored and B is factored as +*> L*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the skew-symmetric matrix A. If UPLO = 'U', the +*> strictly N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the leading lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> strictly N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the leading upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, the transformed matrix, stored in the +*> same format as A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is REAL array, dimension (LDB,N) +*> The triangular factor from the Cholesky factorization of B, +*> as returned by SPOTRF. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kygst +* +* ===================================================================== + SUBROUTINE SKYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, ITYPE, LDA, LDB, N +* .. +* .. Array Arguments .. + REAL A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, HALF + PARAMETER ( ONE = 1.0, HALF = 0.5 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER K, KB, NB +* .. +* .. External Subroutines .. + EXTERNAL SKYGS2, SKYMM, SKYR2K, STRMM, STRSM, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN + INFO = -1 + ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SKYGST', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'SKYGST', UPLO, N, -1, -1, -1 ) +* + IF( NB.LE.1 .OR. NB.GE.N ) THEN +* +* Use unblocked code +* + CALL SKYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) + ELSE +* +* Use blocked code +* + IF( ITYPE.EQ.1 ) THEN + IF( UPPER ) THEN +* +* Compute inv(U**T)*A*inv(U) +* + DO 10 K = 1, N, NB + KB = MIN( N-K+1, NB ) +* +* Update the upper triangle of A(k:n,k:n) +* + CALL SKYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, + $ B( K, K ), LDB, INFO ) + IF( K+KB.LE.N ) THEN + CALL STRSM( 'Left', UPLO, 'Transpose', 'Non-unit', + $ KB, N-K-KB+1, ONE, B( K, K ), LDB, + $ A( K, K+KB ), LDA ) + CALL SKYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, + $ A( K, K ), LDA, B( K, K+KB ), LDB, ONE, + $ A( K, K+KB ), LDA ) + CALL SKYR2K( UPLO, 'Transpose', N-K-KB+1, KB, -ONE, + $ A( K, K+KB ), LDA, B( K, K+KB ), LDB, + $ ONE, A( K+KB, K+KB ), LDA ) + CALL SKYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, + $ A( K, K ), LDA, B( K, K+KB ), LDB, ONE, + $ A( K, K+KB ), LDA ) + CALL STRSM( 'Right', UPLO, 'No transpose', + $ 'Non-unit', KB, N-K-KB+1, ONE, + $ B( K+KB, K+KB ), LDB, A( K, K+KB ), + $ LDA ) + END IF + 10 CONTINUE + ELSE +* +* Compute inv(L)*A*inv(L**T) +* + DO 20 K = 1, N, NB + KB = MIN( N-K+1, NB ) +* +* Update the lower triangle of A(k:n,k:n) +* + CALL SKYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, + $ B( K, K ), LDB, INFO ) + IF( K+KB.LE.N ) THEN + CALL STRSM( 'Right', UPLO, 'Transpose', 'Non-unit', + $ N-K-KB+1, KB, ONE, B( K, K ), LDB, + $ A( K+KB, K ), LDA ) + CALL SKYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, + $ A( K, K ), LDA, B( K+KB, K ), LDB, ONE, + $ A( K+KB, K ), LDA ) + CALL SKYR2K( UPLO, 'No transpose', N-K-KB+1, KB, + $ ONE, A( K+KB, K ), LDA, B( K+KB, K ), + $ LDB, ONE, A( K+KB, K+KB ), LDA ) + CALL SKYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, + $ A( K, K ), LDA, B( K+KB, K ), LDB, ONE, + $ A( K+KB, K ), LDA ) + CALL STRSM( 'Left', UPLO, 'No transpose', + $ 'Non-unit', N-K-KB+1, KB, ONE, + $ B( K+KB, K+KB ), LDB, A( K+KB, K ), + $ LDA ) + END IF + 20 CONTINUE + END IF + ELSE + IF( UPPER ) THEN +* +* Compute U*A*U**T +* + DO 30 K = 1, N, NB + KB = MIN( N-K+1, NB ) +* +* Update the upper triangle of A(1:k+kb-1,1:k+kb-1) +* + CALL STRMM( 'Left', UPLO, 'No transpose', 'Non-unit', + $ K-1, KB, ONE, B, LDB, A( 1, K ), LDA ) + CALL SKYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), + $ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA ) + CALL SKYR2K( UPLO, 'No transpose', K-1, KB, -ONE, + $ A( 1, K ), LDA, B( 1, K ), LDB, ONE, A, + $ LDA ) + CALL SKYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), + $ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA ) + CALL STRMM( 'Right', UPLO, 'Transpose', 'Non-unit', + $ K-1, KB, ONE, B( K, K ), LDB, A( 1, K ), + $ LDA ) + CALL SKYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, + $ B( K, K ), LDB, INFO ) + 30 CONTINUE + ELSE +* +* Compute L**T*A*L +* + DO 40 K = 1, N, NB + KB = MIN( N-K+1, NB ) +* +* Update the lower triangle of A(1:k+kb-1,1:k+kb-1) +* + CALL STRMM( 'Right', UPLO, 'No transpose', 'Non-unit', + $ KB, K-1, ONE, B, LDB, A( K, 1 ), LDA ) + CALL SKYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), + $ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA ) + CALL SKYR2K( UPLO, 'Transpose', K-1, KB, ONE, + $ A( K, 1 ), LDA, B( K, 1 ), LDB, ONE, A, + $ LDA ) + CALL SKYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), + $ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA ) + CALL STRMM( 'Left', UPLO, 'Transpose', 'Non-unit', KB, + $ K-1, ONE, B( K, K ), LDB, A( K, 1 ), LDA ) + CALL SKYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, + $ B( K, K ), LDB, INFO ) + 40 CONTINUE + END IF + END IF + END IF + RETURN +* +* End of SKYGST +* + END diff --git a/SRC/skygv.f b/SRC/skygv.f new file mode 100644 index 000000000..61327bcf9 --- /dev/null +++ b/SRC/skygv.f @@ -0,0 +1,321 @@ +*> \brief \b SKYGV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SKYGV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SKYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER JOBZ, UPLO +* INTEGER INFO, ITYPE, LDA, LDB, LWORK, N +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SKYGV computes all the eigenvalues, and optionally, the eigenvectors +*> of a real generalized skew-symmetric-definite eigenproblem, of the form +*> A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. +*> Here A is assumed to be skew-symmetric and B is assumed to be symmetric +*> positive definite. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is INTEGER +*> Specifies the problem type to be solved: +*> = 1: A*x = (lambda)*B*x +*> = 2: A*B*x = (lambda)*x +*> = 3: B*A*x = (lambda)*x +*> \endverbatim +*> +*> \param[in] JOBZ +*> \verbatim +*> JOBZ is CHARACTER*1 +*> = 'N': Compute eigenvalues only; +*> = 'V': Compute eigenvalues and eigenvectors. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangles of A and B are stored; +*> = 'L': Lower triangles of A and B are stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrices A and B. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA, N) +*> On entry, the skew-symmetric matrix A. If UPLO = 'U', +*> the strictly N-by-N upper triangular part of A contains the +*> upper triangular part of the matrix A. If UPLO = 'L', +*> the strictly N-by-N lower triangular part of A contains +*> the lower triangular part of the matrix A. +*> +*> On exit, if JOBZ = 'V', then if INFO = 0, A contains the +*> matrix Z, which leads to the block diagonal form in W. +*> The matrix are normalized as follows: +*> if ITYPE = 1 or 2, Z**T*B*Z = I; +*> if ITYPE = 3, Z**T*inv(B)*Z = I. +*> The eigenvectors of the matrix can be evaluated directly. +*> If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') +*> or the lower triangle (if UPLO='L') of A, including the +*> diagonal, is destroyed. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB, N) +*> On entry, the symmetric positive definite matrix B. +*> If UPLO = 'U', the leading N-by-N upper triangular part of B +*> contains the upper triangular part of the matrix B. +*> If UPLO = 'L', the leading N-by-N lower triangular part of B +*> contains the lower triangular part of the matrix B. +*> +*> On exit, if INFO <= N, the part of B containing the matrix is +*> overwritten by the triangular factor U or L from the Cholesky +*> factorization B = U**T*U or B = L*L**T. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is REAL array, dimension (N) +*> If INFO = 0, the (N-1) lower subdiagonal elements of the +*> block diagonal matrix at front, and zero at last. +*> The matrix consists of 2-by-2 skew-symmetric blocks, and zeros. +*> The values in W, which represent blocks, are always +*> positive, and sorted in descending order. +*> The eigenvalues of each blocks can be evaluated directly. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of the array WORK. LWORK >= max(1,3*N-1). +*> For optimal efficiency, LWORK >= (NB+2)*N, +*> where NB is the blocksize for SSYTRD returned by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: SPOTRF or SKYEV returned an error code: +*> <= N: if INFO = i, SKYEV failed to converge; +*> i off-diagonal elements of an intermediate +*> tridiagonal form did not converge to zero; +*> > N: if INFO = N + i, for 1 <= i <= N, then the leading +*> minor of order i of B is not positive definite. +*> The factorization of B could not be completed and +*> no eigenvalues or eigenvectors were computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kygv +* +* ===================================================================== + SUBROUTINE SKYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, ITYPE, LDA, LDB, LWORK, N +* .. +* .. Array Arguments .. + REAL A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER, WANTZ + CHARACTER TRANS + INTEGER LWKMIN, LWKOPT, NB, NEIG +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + REAL SROUNDUP_LWORK + EXTERNAL ILAENV, LSAME, SROUNDUP_LWORK +* .. +* .. External Subroutines .. + EXTERNAL SPOTRF, SKYEV, SKYGST, STRMM, STRSM, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN + INFO = -1 + ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + LWKMIN = MAX( 1, 2*N - 1 ) + NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 ) + LWKOPT = MAX( LWKMIN, ( NB + 1 )*N ) + WORK( 1 ) = SROUNDUP_LWORK(LWKOPT) +* + IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN + INFO = -11 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SKYGV ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Form a Cholesky factorization of B. +* + CALL SPOTRF( UPLO, N, B, LDB, INFO ) + IF( INFO.NE.0 ) THEN + INFO = N + INFO + RETURN + END IF +* +* Transform problem to standard eigenvalue problem and solve. +* + CALL SKYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) + CALL SKYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) +* + IF( WANTZ ) THEN +* +* Backtransform eigenvectors to the original problem. +* + NEIG = N + IF( INFO.GT.0 ) + $ NEIG = INFO - 1 + IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN +* +* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; +* backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y +* + IF( UPPER ) THEN + TRANS = 'N' + ELSE + TRANS = 'T' + END IF +* + CALL STRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, + $ ONE, + $ B, LDB, A, LDA ) +* + ELSE IF( ITYPE.EQ.3 ) THEN +* +* For B*A*x=(lambda)*x; +* backtransform eigenvectors: x = L*y or U**T*y +* + IF( UPPER ) THEN + TRANS = 'T' + ELSE + TRANS = 'N' + END IF +* + CALL STRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, + $ ONE, + $ B, LDB, A, LDA ) + END IF + END IF +* + WORK( 1 ) = SROUNDUP_LWORK(LWKOPT) + RETURN +* +* End of SKYGV +* + END diff --git a/SRC/skysv.f b/SRC/skysv.f new file mode 100644 index 000000000..5650ae5ba --- /dev/null +++ b/SRC/skysv.f @@ -0,0 +1,283 @@ +*> \brief SKYSV computes the solution to system of linear equations A * X = B for KY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SKYSV + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SKYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SKYSV computes the solution to a real system of linear equations +*> A * X = B, +*> where A is an N-by-N skew-symmetric matrix and X and B are N-by-NRHS +*> matrices. +*> +*> The partial pivoting method is used to factor A as +*> A = U * D * U**T, if UPLO = 'U', or +*> A = L * D * L**T, if UPLO = 'L', +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and D is skew-symmetric and block diagonal with +*> 1-by-1 and 2-by-2 diagonal blocks. All 2-by-2 diagonal blocks are +*> nonsingular and all 1-by-1 diagonal blocks are 0. If N is odd, there +*> is at least one 1-by-1 diagonal block. The factored form of A is then +*> used to solve the system of equations A * X = B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of linear equations, i.e., the order of the +*> matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the skew-symmetric matrix A. If UPLO = 'U', the strictly +*> upper triangular part of A contains the upper +*> triangular part of the matrix A, and the leading N-by-N lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> strictly lower triangular part of A contains the lower +*> triangular part of the matrix A, and the leading N-by-N upper +*> triangular part of A is not referenced. +*> +*> On exit, if INFO = 0, the block diagonal matrix D and the +*> multipliers used to obtain the factor U or L from the +*> factorization A = U*D*U**T or A = L*D*L**T as computed by +*> SKYTRF. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges of D, as determined by SKYTRF. +*> +*> The elements of array IPIV are combined in pair, and the first +*> (if UPLO = 'U') or the second (if UPLO = 'L') element in +*> the pair always keeps the value 0. If N is odd, the first +*> (if UPLO = 'U') or the last (if UPLO = 'L') element of IPIV is +*> 0, which is the only element not in pair. So we only use the +*> first (if UPLO = 'L') or the second (if UPLO = 'U') element in +*> the pair to determine the interchanges. +*> +*> If IPIV(k) +*> = 0: there was no interchange. +*> > 0: rows and columns k-1 and IPIV(k) were interchanged, if +*> UPLO = 'U', and rows and columns k+1 and IPIV(k) were +*> interchanged, if UPLO = 'L'. +*> < 0: rows and columns k and k-1 were interchanged, +*> then rows and columns k-1 and -IPIV(k) were interchanged, if +*> UPLO = 'U', and rows and columns k and k+1 were interchanged, +*> then rows and columns k+1 and -IPIV(k) were interchanged, if +*> UPLO = 'L'. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB,NRHS) +*> On entry, the N-by-NRHS right hand side matrix B. +*> On exit, if INFO = 0, the N-by-NRHS solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >= 1, and for best performance +*> LWORK >= max(1,N*NB), where NB is the optimal blocksize for +*> SKYTRF. +*> for LWORK < N, TRS will be done with Level BLAS 2 +*> for LWORK >= N, TRS will be done with Level BLAS 3 +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i-1,i) (if UPLO = 'U') or D(i+1,i) (if UPLO = 'L') +*> is exactly zero. The factorization has been completed, +*> but the block diagonal matrix D is exactly singular, +*> so the solution could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kysv +* +* ===================================================================== + SUBROUTINE SKYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SROUNDUP_LWORK + EXTERNAL LSAME, SROUNDUP_LWORK +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SKYTRF, SKYTRS, SKYTRS2 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.LSAME( UPLO, 'U' ) .AND. + $ .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + CALL SKYTRF( UPLO, N, A, LDA, IPIV, WORK, -1, INFO ) + LWKOPT = INT( WORK( 1 ) ) + END IF + WORK( 1 ) = SROUNDUP_LWORK(LWKOPT) + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SKYSV ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = U*D*U**T or A = L*D*L**T. +* + CALL SKYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* + IF ( LWORK.LT.N ) THEN +* +* Solve with TRS ( Use Level BLAS 2) +* + CALL SKYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* + ELSE +* +* Solve with TRS2 ( Use Level BLAS 3) +* + CALL SKYTRS2( UPLO,N,NRHS,A,LDA,IPIV,B,LDB,WORK,INFO ) +* + END IF +* + END IF +* + WORK( 1 ) = SROUNDUP_LWORK(LWKOPT) +* + RETURN +* +* End of SKYSV +* + END diff --git a/SRC/skyswapr.f b/SRC/skyswapr.f new file mode 100644 index 000000000..9904ced4a --- /dev/null +++ b/SRC/skyswapr.f @@ -0,0 +1,172 @@ +*> \brief \b SKYSWAPR applies an elementary permutation on the rows and columns of a skew-symmetric matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SKYSWAPR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SKYSWAPR( UPLO, N, A, LDA, I1, I2) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER I1, I2, LDA, N +* .. +* .. Array Arguments .. +* REAL A( LDA, N ) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SKYSWAPR applies an elementary permutation on the rows and the columns of +*> a skew-symmetric matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,*) +*> On entry, the N-by-N matrix A. On exit, the permuted matrix +*> where the rows I1 and I2 and columns I1 and I2 are interchanged. +*> If UPLO = 'U', the interchanges are applied to the upper +*> triangular part and the strictly lower triangular part of A is +*> not referenced; if UPLO = 'L', the interchanges are applied to +*> the lower triangular part and the part of A above the diagonal +*> is not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] I1 +*> \verbatim +*> I1 is INTEGER +*> Index of the first row to swap +*> \endverbatim +*> +*> \param[in] I2 +*> \verbatim +*> I2 is INTEGER +*> Index of the second row to swap +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kyswapr +* +* ===================================================================== + SUBROUTINE SKYSWAPR( UPLO, N, A, LDA, I1, I2) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER I1, I2, LDA, N +* .. +* .. Array Arguments .. + REAL A( LDA, * ) +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL UPPER + REAL TMP +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SSWAP, SSCAL +* .. +* .. Executable Statements .. +* + UPPER = LSAME( UPLO, 'U' ) + IF (UPPER) THEN +* +* UPPER +* first swap +* - swap column I1 and I2 from I1 to I1-1 + CALL SSWAP( I1-1, A(1,I1), 1, A(1,I2), 1 ) +* +* second swap : +* - swap row I1 from I1+1 to I2-1 with col I2 from I1+1 to I2-1 +* + CALL SSWAP( I2-I1-1, A(I1,I1+1), LDA, A(I1+1,I2), 1 ) + CALL SSCAL( I2-I1, -ONE, A(I1,I2), 1) + CALL SSCAL( I2-I1-1, -ONE, A(I1,I1+1), LDA ) +* +* third swap +* - swap row I1 and I2 from I2+1 to N + IF ( I2.LT.N ) + $ CALL SSWAP( N-I2, A(I1,I2+1), LDA, A(I2,I2+1), LDA ) +* + ELSE +* +* LOWER +* first swap +* - swap row I1 and I2 from I1 to I1-1 + CALL SSWAP( I1-1, A(I1,1), LDA, A(I2,1), LDA ) +* +* second swap : +* - swap col I1 from I1+1 to I2-1 with row I2 from I1+1 to I2-1 +* + CALL SSWAP( I2-I1-1, A(I1+1,I1), 1, A(I2,I1+1), LDA ) + CALL SSCAL( I2-I1, -ONE, A(I1+1,I1), 1) + CALL SSCAL( I2-I1-1, -ONE, A(I2,I1+1), LDA ) +* +* third swap +* - swap col I1 and I2 from I2+1 to N + IF ( I2.LT.N ) + $ CALL SSWAP( N-I2, A(I2+1,I1), 1, A(I2+1,I2), 1 ) +* + ENDIF + END SUBROUTINE SKYSWAPR + diff --git a/SRC/skytd2.f b/SRC/skytd2.f new file mode 100644 index 000000000..b451b2298 --- /dev/null +++ b/SRC/skytd2.f @@ -0,0 +1,299 @@ +*> \brief \b SKYTD2 reduces a skew-symmetric matrix to real skew-symmetric tridiagonal form by an orthogonal similarity transformation (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SKYTD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SKYTD2( UPLO, N, A, LDA, E, TAU, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), E( * ), TAU( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SKYTD2 reduces a real skew-symmetric matrix A to skew-symmetric tridiagonal +*> form T by an orthogonal similarity transformation: Q**T * A * Q = T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> skew-symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the skew-symmetric matrix A. If UPLO = 'U', the strictly +*> n-by-n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the leading lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> strictly n-by-n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the leading upper +*> triangular part of A is not referenced. +*> On exit, if UPLO = 'U', the diagonal and first superdiagonal +*> of A are overwritten by the corresponding elements of the +*> tridiagonal matrix T, and the elements above the first +*> superdiagonal, with the array TAU, represent the orthogonal +*> matrix Q as a product of elementary reflectors; if UPLO +*> = 'L', the diagonal and first subdiagonal of A are over- +*> written by the corresponding elements of the tridiagonal +*> matrix T, and the elements below the first subdiagonal, with +*> the array TAU, represent the orthogonal matrix Q as a product +*> of elementary reflectors. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is REAL array, dimension (N-1) +*> The off-diagonal elements of the tridiagonal matrix T: +*> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is REAL array, dimension (N-1) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kytd2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', the matrix Q is represented as a product of elementary +*> reflectors +*> +*> Q = H(n-1) . . . H(2) H(1). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in +*> A(1:i-1,i+1), and tau in TAU(i). +*> +*> If UPLO = 'L', the matrix Q is represented as a product of elementary +*> reflectors +*> +*> Q = H(1) H(2) . . . H(n-1). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), +*> and tau in TAU(i). +*> +*> The contents of A on exit are illustrated by the following examples +*> with n = 5: +*> +*> if UPLO = 'U': if UPLO = 'L': +*> +*> ( 0 e v2 v3 v4 ) ( 0 ) +*> ( 0 e v3 v4 ) ( e 0 ) +*> ( 0 e v4 ) ( v1 e 0 ) +*> ( 0 e ) ( v1 v2 e 0 ) +*> ( 0 ) ( v1 v2 v3 e 0 ) +*> +*> where d and e denote diagonal and off-diagonal elements of T, and vi +*> denotes an element of the vector defining H(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SKYTD2( UPLO, N, A, LDA, E, TAU, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + REAL A( LDA, * ), E( * ), TAU( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO, HALF + PARAMETER ( ONE = 1.0, ZERO = 0.0, HALF = 1.0 / 2.0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I + REAL ALPHA, TAUI +* .. +* .. External Subroutines .. + EXTERNAL SAXPY, SLARFG, SKYMV, SKYR2, XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SDOT + EXTERNAL LSAME, SDOT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .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 = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SKYTD2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Reduce the upper triangle of A +* + DO 10 I = N - 1, 1, -1 +* +* Generate elementary reflector H(i) = I - tau * v * v**T +* to annihilate A(1:i-1,i+1) +* + CALL SLARFG( I, A( I, I+1 ), A( 1, I+1 ), 1, TAUI ) + E( I ) = A( I, I+1 ) +* + IF( TAUI.NE.ZERO ) THEN +* +* Apply H(i) from both sides to A(1:i,1:i) +* + A( I, I+1 ) = ONE +* +* Compute x := tau * A * v storing x in TAU(1:i) +* + CALL SKYMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, + $ ZERO, + $ TAU, 1 ) +* +* Apply the transformation as a rank-2 update: +* A := A + v * x**T - x * v**T +* + CALL SKYR2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A, + $ LDA ) +* + A( I, I+1 ) = E( I ) + END IF + TAU( I ) = TAUI + 10 CONTINUE + ELSE +* +* Reduce the lower triangle of A +* + DO 20 I = 1, N - 1 +* +* Generate elementary reflector H(i) = I - tau * v * v**T +* to annihilate A(i+2:n,i) +* + CALL SLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, + $ TAUI ) + E( I ) = A( I+1, I ) +* + IF( TAUI.NE.ZERO ) THEN +* +* Apply H(i) from both sides to A(i+1:n,i+1:n) +* + A( I+1, I ) = ONE +* +* Compute x := tau * A * v storing y in TAU(i:n-1) +* + CALL SKYMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA, + $ A( I+1, I ), 1, ZERO, TAU( I ), 1 ) +* +* Apply the transformation as a rank-2 update: +* A := A + v * x**T - x * v**T +* + CALL SKYR2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), + $ 1, + $ A( I+1, I+1 ), LDA ) +* + A( I+1, I ) = E( I ) + END IF + TAU( I ) = TAUI + 20 CONTINUE + END IF +* + RETURN +* +* End of SKYTD2 +* + END diff --git a/SRC/skytf2.f b/SRC/skytf2.f new file mode 100644 index 000000000..0cc68f55a --- /dev/null +++ b/SRC/skytf2.f @@ -0,0 +1,586 @@ +*> \brief \b SKYTF2 computes the factorization of a real skew-symmetric matrix, using the Bunch partial pivoting method (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SKYTF2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SKYTF2( UPLO, N, A, LDA, IPIV, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SKYTF2 computes the factorization of a real skew-symmetric matrix A using +*> the Bunch block diagonal pivoting method: +*> +*> A = U*D*U**T or A = L*D*L**T +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, U**T is the transpose of U, and D is skew-symmetric +*> and block diagonal with 1-by-1 and 2-by-2 diagonal blocks. All 2-by-2 +*> diagonal blocks are nonsingular and all 1-by-1 diagonal blocks are 0. +*> If N is odd, there is at least one 1-by-1 diagonal block. +*> +*> This is the unblocked version of the algorithm, calling Level 2 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> skew-symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the skew-symmetric matrix A. If UPLO = 'U', the +*> strictly upper triangular part of A contains the upper +*> triangular part of the matrix A, and the leading N-by-N lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> strictly lower triangular part of A contains the lower +*> triangular part of the matrix A, and the leading N-by-N upper +*> triangular part of A is not referenced. +*> +*> On exit, the block diagonal matrix D and the multipliers used +*> to obtain the factor U or L (see below for further details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> The elements of array IPIV are combined in pair, and the first +*> element in the pair always keeps the value 0. If N is odd, the +*> first element of IPIV is 0, which is the only element not in pair. +*> So we only use the second element in the pair to determine the +*> interchanges. +*> +*> If IPIV(k) +*> = 0: there was no interchange. +*> > 0: rows and columns k-1 and IPIV(k) were interchanged. +*> < 0: rows and columns k and k-1 were interchanged, +*> then rows and columns k-1 and -IPIV(k) were interchanged. +*> +*> If UPLO = 'L': +*> The elements of array IPIV are combined in pair, and the second +*> element in the pair always keeps the value 0. If N is odd, the +*> last element of IPIV is 0, which is the only element not in pair. +*> So we only use the first element in the pair to determine the +*> interchanges. +*> +*> If IPIV(k) +*> = 0: there was no interchange. +*> > 0: rows and columns k+1 and IPIV(k) were interchanged。 +*> < 0: rows and columns k and k+1 were interchanged, +*> then rows and columns k+1 and -IPIV(k) were interchanged. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i-1,i) (if UPLO = 'U') or D(i+1,i) (if UPLO = 'L') +*> is exactly zero. The factorization has been completed, +*> but the block diagonal matrix D is exactly singular, +*> so the solution could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kytf2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', then A = U*D*U**T, where +*> U = P(n)*U(n)* ... *P(k)U(k)* ..., +*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to +*> 1 in steps of 2, and D is a block diagonal matrix with 2-by-2 +*> diagonal blocks D(k). P(k) is a permutation matrix as defined by +*> IPIV(k), and U(k) is a unit upper triangular matrix, such that if +*> the diagonal block D(k) is of order 2, namely s = 2, then +*> +*> ( I v 0 ) k-s +*> U(k) = ( 0 I 0 ) s +*> ( 0 0 I ) n-k +*> k-s s n-k +*> +*> The strictly upper triangle of D(k) overwrites A(k-1,k), and v overwrites +*> A(1:k-2,k-1:k). +*> +*> If UPLO = 'L', then A = L*D*L**T, where +*> L = P(1)*L(1)* ... *P(k)*L(k)* ..., +*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to +*> n in steps of 2, and D is a block diagonal matrix with 2-by-2 +*> diagonal blocks D(k). P(k) is a permutation matrix as defined by +*> IPIV(k), and L(k) is a unit lower triangular matrix, such that if +*> the diagonal block D(k) is of order 2, namely s = 2, then +*> +*> ( I 0 0 ) k-1 +*> L(k) = ( 0 I 0 ) s +*> ( 0 v I ) n-k-s+1 +*> k-1 s n-k-s+1 +*> +*> The strictly lower triangle of D(k) overwrites A(k+1,k), and v overwrites +*> A(k+2:n,k:k+1). +*> +*> Remind that if n is odd, A is always singular. +*> \endverbatim +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> 09-29-06 - patch from +*> Bobby Cheng, MathWorks +*> +*> Replace l.204 and l.372 +*> IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +*> by +*> IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN +*> +*> 01-01-96 - Based on modifications by +*> J. Lewis, Boeing Computer Services Company +*> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA +*> 1-96 - Based on modifications by J. Lewis, Boeing Computer Services +*> Company +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SKYTF2( UPLO, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, IMAX1, IMAX2, J,KSTEP + REAL ABSAKP1K, COLMAX1, COLMAX2, + $ D21, T, WK, WKM1, WKP1 +* .. +* .. External Functions .. + LOGICAL LSAME, SISNAN + INTEGER ISAMAX + EXTERNAL LSAME, ISAMAX, SISNAN +* .. +* .. External Subroutines .. + EXTERNAL SSCAL, SSWAP, SSYR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .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 = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SKYTF2', -INFO ) + RETURN + END IF + + IF( UPPER ) THEN +* +* Factorize A as U*D*U**T using the upper triangle of A +* K is the main loop index, decreasing from N to 1 in steps +* of 2 +* + K = N + 10 CONTINUE +* +* If K <= 1, exit from loop +* + IF( K.EQ.1 ) THEN + IF( INFO.EQ.0 ) + $ INFO = K + KP = 0 + IPIV( K ) = KP + GO TO 70 + END IF + + IF( K.LT.1 ) + $ GO TO 70 + KSTEP = 2 +* +* Determine rows and columns to be interchanged +* + ABSAKP1K = ABS( A( K-1, K ) ) +* +* IMAX1 is the row-index of the absolute value largest element in +* row 1 to K-2, column K. +* IMAX2 is the row-index of the absolute value largest element in +* row 1 to K-2 column K-1. +* COLMAX1 and COLMAX2 are their absolute values. +* + IF(K.GT.2) THEN + IMAX1 = ISAMAX( K-2, A( 1, K ), 1 ) + COLMAX1 = ABS( A( IMAX1, K ) ) + IMAX2 = ISAMAX( K-2, A( 1, K-1 ), 1 ) + COLMAX2 = ABS( A( IMAX2, K-1 ) ) + ELSE + IMAX1 = 0 + COLMAX1 = ZERO + IMAX2 = 0 + COLMAX2 = ZERO + ENDIF +* + IF( MAX(MAX( ABSAKP1K, COLMAX1 ), COLMAX2).EQ.ZERO ) THEN +* +* Column K and K+1 is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = 0 + IPIV( K ) = KP + ELSE + IF( ABSAKP1K.GE.MAX( COLMAX1, COLMAX2 ) ) THEN +* +* No interchange +* + KP = 0 + IPIV( K ) = KP + ELSE + IF( COLMAX1.GE.COLMAX2 ) THEN + +* +* Absolute value largest element is in column K +* Interchange rows and columns K-1 and IMAX1 +* + KP = IMAX1 + IPIV( K ) = KP + + CALL SSWAP( K-IMAX1-2, A( IMAX1, IMAX1+1 ), LDA, + $ A( IMAX1+1, K-1 ), 1 ) + + CALL SSCAL( K-IMAX1-2, -ONE, A( IMAX1, IMAX1+1 ), + $ LDA ) + + CALL SSCAL( K-IMAX1-2, -ONE, A( IMAX1+1, K-1 ), + $ 1 ) + + CALL SSWAP( IMAX1-1, A( 1, IMAX1 ), 1, + $ A( 1, K-1 ), 1 ) + + A( IMAX1, K-1 ) = -A( IMAX1, K-1 ) + +* +* Interchange rows K-1 and IMAX1 in column K of A +* + T = A( K-1, K ) + A( K-1, K ) = A( IMAX1, K ) + A( IMAX1, K ) = T + ELSE +* +* Absolute value largest element is in column K-1 +* Interchange rows and columns K and K-1, then Interchange K-1 and IMAX2 +* + KP = -IMAX2 + IPIV( K ) = KP + + CALL SSWAP( K-2, A( 1, K ), 1, A( 1, K-1 ), + $ 1 ) + + A( K-1, K ) = -A( K-1, K ) + + CALL SSWAP( K-IMAX2-2, A( IMAX2, IMAX2+1 ), LDA, + $ A( IMAX2+1, K-1 ), 1 ) + + CALL SSCAL( K-IMAX2-2, -ONE, A( IMAX2, IMAX2+1 ), + $ LDA ) + + CALL SSCAL( K-IMAX2-2, -ONE, A( IMAX2+1, K-1 ), + $ 1 ) + + CALL SSWAP( IMAX2-1, A( 1, IMAX2 ), 1, + $ A( 1, K-1 ), 1 ) + + A( IMAX2, K-1 ) = -A( IMAX2, K-1 ) +* +* Interchange rows K-1 and IMAX2 in column K of A +* + T = A( K-1, K ) + A( K-1, K ) = A( IMAX2, K ) + A( IMAX2, K ) = T +* + END IF + END IF +* +* Update the lower triangle of A11 (= A(1:k-2,1:k-2)) +* + D21 = ONE/A( K-1, K ) + + DO 20 J = 1, K-2 +* + WK = -A( J, K-1 )*D21 + WKM1 = A( J, K )*D21 +* + DO 30 I = J+1, K-2 + A( J, I ) = A( J, I ) + A( I, K )*WK + + $ A( I, K-1 )*WKM1 + 30 CONTINUE + + 20 CONTINUE + +* +* Update C*S^-1 +* + DO 80 J = 1, K-2 + T = A( J, K-1 ) + A( J, K-1 ) = A( J, K )*D21 + A( J, K ) = -T*D21 + 80 CONTINUE + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + GO TO 10 +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* K is the main loop index, increasing from 1 to N in steps +* of 2 +* + K = 1 + 40 CONTINUE +* +* If K >= N, exit from loop +* + IF( K.EQ.N ) THEN + IF( INFO.EQ.0 ) + $ INFO = K + KP = 0 + IPIV( K ) = KP + GO TO 70 + END IF + + IF( K.GT.N ) + $ GO TO 70 + KSTEP = 2 +* +* Determine rows and columns to be interchanged +* + ABSAKP1K = ABS( A( K+1, K ) ) +* +* IMAX1 is the row-index of the absolute value largest element in +* row K+2 to N, column K. +* IMAX2 is the row-index of the absolute value largest element in +* row K+2 to N, column K+1. +* COLMAX1 and COLMAX2 are their absolute values. +* + IF(K.LT.N-1) THEN + IMAX1 = K+1 + ISAMAX( N-K-1, A( K+2, K ), 1 ) + COLMAX1 = ABS( A( IMAX1, K ) ) + IMAX2 = K+1 + ISAMAX( N-K-1, A( K+2, K+1 ), 1 ) + COLMAX2 = ABS( A( IMAX2, K+1 ) ) + ELSE + IMAX1 = 0 + COLMAX1 = ZERO + IMAX2 = 0 + COLMAX2 = ZERO + ENDIF +* + IF( MAX(MAX( ABSAKP1K, COLMAX1 ), COLMAX2).EQ.ZERO ) THEN +* +* Column K and K+1 is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = 0 + IPIV( K ) = KP + + ELSE + IF( ABSAKP1K.GE.MAX( COLMAX1, COLMAX2 ) ) THEN +* +* no interchange +* + KP = 0 + IPIV( K ) = KP + + ELSE + IF( COLMAX1.GE.COLMAX2 ) THEN +* +* Absolute value largest element is in column K +* Interchange rows and columns K+1 and IMAX1 +* + KP = IMAX1 + IPIV( K ) = KP + + CALL SSWAP( IMAX1-K-2, A( IMAX1, K+2 ), LDA, + $ A( K+2, K+1 ), 1 ) + + CALL SSCAL( IMAX1-K-2, -ONE, A( IMAX1, K+2 ), + $ LDA ) + + CALL SSCAL( IMAX1-K-2, -ONE, A( K+2, K+1 ), + $ 1 ) + + CALL SSWAP( N-IMAX1, A( IMAX1+1, IMAX1 ), 1, + $ A( IMAX1+1, K+1 ), 1 ) + + A( IMAX1, K+1 ) = -A( IMAX1, K+1 ) +* +* Interchange rows K+1 and IMAX1 in column K of A +* + T = A( K+1, K ) + A( K+1, K ) = A( IMAX1, K ) + A( IMAX1, K ) = T +* + ELSE +* +* Absolute value largest element is in column K+1 +* Interchange rows and columns K and K+1, then Interchange K+1 and IMAX2 +* + KP = -IMAX2 + IPIV( K ) = KP + + CALL SSWAP( N-K-1, A( K+2, K ), 1, A( K+2, K+1 ), + $ 1 ) + + A( K+1, K ) = -A( K+1, K ) + + CALL SSWAP( IMAX2-K-2, A( IMAX2, K+2 ), LDA, + $ A( K+2, K+1 ), 1 ) + + CALL SSCAL( IMAX2-K-2, -ONE, A( IMAX2, K+2 ), + $ LDA ) + + CALL SSCAL( IMAX2-K-2, -ONE, A( K+2, K+1 ), + $ 1 ) + + CALL SSWAP( N-IMAX2, A( IMAX2+1, IMAX2 ), 1, + $ A( IMAX2+1, K+1 ), 1 ) + + A( IMAX2, K+1 ) = -A( IMAX2, K+1 ) +* +* Interchange rows K+1 and IMAX2 in column K of A +* + T = A( K+1, K ) + A( K+1, K ) = A( IMAX2, K ) + A( IMAX2, K ) = T +* + END If + END If + +* +* Update the lower triangle of A22 (= A(k+2:n,k+2:n)) +* + D21 = ONE/A( K+1, K ) + + DO 60 J = K+2, N +* + WK = -A( J, K+1 )*D21 + WKP1 = A( J, K )*D21 +* + DO 50 I = K+2, J-1 + A( J, I ) = A( J, I ) + A( I, K )*WK + + $ A( I, K+1 )*WKP1 + 50 CONTINUE + + 60 CONTINUE + +* +* Update C*S^-1 +* + DO 90 J = K+2, N + T = A( J, K ) + A( J, K ) = -A( J, K+1 )*D21 + A( J, K+1 ) = T*D21 + 90 CONTINUE + END IF + + K = K + KSTEP + GO TO 40 +* + END IF +* + 70 CONTINUE +* + RETURN +* +* End of SKYTF2 +* + END diff --git a/SRC/skytrd.f b/SRC/skytrd.f new file mode 100644 index 000000000..89b7c8c7c --- /dev/null +++ b/SRC/skytrd.f @@ -0,0 +1,363 @@ +*> \brief \b SKYTRD +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SKYTRD + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SKYTRD( UPLO, N, A, LDA, E, TAU, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), E( * ), TAU( * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SKYTRD reduces a real skew-symmetric matrix A to real skew-symmetric +*> tridiagonal form T by an orthogonal similarity transformation: +*> Q**T * A * Q = T. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the skew-symmetric matrix A. If UPLO = 'U', the strictly +*> N-by-N upper triangular part of A contains the upper +*> triangular part of the matrix A, and the leading lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> strictly N-by-N lower triangular part of A contains the lower +*> triangular part of the matrix A, and the leading upper +*> triangular part of A is not referenced. +*> On exit, if UPLO = 'U', the first superdiagonal of A are +*> overwritten by the corresponding elements of the tridiagonal +*> matrix T, and the elements above the first superdiagonal, with +*> the array TAU, represent the orthogonal matrix Q as a product +*> of elementary reflectors; if UPLO = 'L', the first subdiagonal +*> of A are overwritten by the corresponding elements of the +*> tridiagonal matrix T, and the elements below the first subdiagonal, +*> with the array TAU, represent the orthogonal matrix Q as a product +*> of elementary reflectors. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is REAL array, dimension (N-1) +*> The off-diagonal elements of the tridiagonal matrix T: +*> E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is REAL array, dimension (N-1) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 1. +*> For optimum performance LWORK >= N*NB, where NB is the +*> optimal blocksize. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kytrd +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', the matrix Q is represented as a product of elementary +*> reflectors +*> +*> Q = H(n-1) . . . H(2) H(1). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in +*> A(1:i-1,i+1), and tau in TAU(i). +*> +*> If UPLO = 'L', the matrix Q is represented as a product of elementary +*> reflectors +*> +*> Q = H(1) H(2) . . . H(n-1). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), +*> and tau in TAU(i). +*> +*> The contents of A on exit are illustrated by the following examples +*> with n = 5: +*> +*> if UPLO = 'U': if UPLO = 'L': +*> +*> ( 0 e v2 v3 v4 ) ( 0 ) +*> ( 0 e v3 v4 ) ( e 0 ) +*> ( 0 e v4 ) ( v1 e 0 ) +*> ( 0 e ) ( v1 v2 e 0 ) +*> ( 0 ) ( v1 v2 v3 e 0 ) +*> +*> where d and e denote diagonal and off-diagonal elements of T, and vi +*> denotes an element of the vector defining H(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SKYTRD( UPLO, N, A, LDA, E, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + REAL A( LDA, * ), E( * ), TAU( * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB, + $ NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL SLATRD, SKYR2K, SKYTD2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + REAL SROUNDUP_LWORK + EXTERNAL LSAME, ILAENV, SROUNDUP_LWORK +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .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 = -4 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size. +* + NB = ILAENV( 1, 'SKYTRD', UPLO, N, -1, -1, -1 ) + LWKOPT = MAX( 1, N*NB ) + WORK( 1 ) = SROUNDUP_LWORK(LWKOPT) + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SKYTRD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NX = N + IWS = 1 + IF( NB.GT.1 .AND. NB.LT.N ) THEN +* +* Determine when to cross over from blocked to unblocked code +* (last block is always handled by unblocked code). +* + NX = MAX( NB, ILAENV( 3, 'SKYTRD', UPLO, N, -1, -1, -1 ) ) + IF( NX.LT.N ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: determine the +* minimum value of NB, and reduce NB or force use of +* unblocked code by setting NX = N. +* + NB = MAX( LWORK / LDWORK, 1 ) + NBMIN = ILAENV( 2, 'SKYTRD', UPLO, N, -1, -1, -1 ) + IF( NB.LT.NBMIN ) + $ NX = N + END IF + ELSE + NX = N + END IF + ELSE + NB = 1 + END IF +* + IF( UPPER ) THEN +* +* Reduce the upper triangle of A. +* Columns 1:kk are handled by the unblocked method. +* + KK = N - ( ( N-NX+NB-1 ) / NB )*NB + DO 20 I = N - NB + 1, KK + 1, -NB +* +* Reduce columns i:i+nb-1 to tridiagonal form and form the +* matrix W which is needed to update the unreduced part of +* the matrix +* + CALL SLATRDK( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK, + $ LDWORK ) +* +* Update the unreduced submatrix A(1:i-1,1:i-1), using an +* update of the form: A := A + V*X**T - X*V**T +* + CALL SKYR2K( UPLO, 'No transpose', I-1, NB, -ONE, A( 1, + $ I ), + $ LDA, WORK, LDWORK, ONE, A, LDA ) +* +* Copy superdiagonal elements back into A +* + DO 10 J = I, I + NB - 1 + A( J-1, J ) = E( J-1 ) + 10 CONTINUE + 20 CONTINUE +* +* Use unblocked code to reduce the last or only block +* + CALL SKYTD2( UPLO, KK, A, LDA, E, TAU, IINFO ) + ELSE +* +* Reduce the lower triangle of A +* + DO 40 I = 1, N - NX, NB +* +* Reduce columns i:i+nb-1 to tridiagonal form and form the +* matrix W which is needed to update the unreduced part of +* the matrix +* + CALL SLATRDK( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ), + $ TAU( I ), WORK, LDWORK ) +* +* Update the unreduced submatrix A(i+ib:n,i+ib:n), using +* an update of the form: A := A + V*X**T - X*V**T +* + CALL SKYR2K( UPLO, 'No transpose', N-I-NB+1, NB, -ONE, + $ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, + $ ONE, A( I+NB, I+NB ), LDA ) +* +* Copy subdiagonal elements back into A +* + DO 30 J = I, I + NB - 1 + A( J+1, J ) = E( J ) + 30 CONTINUE + 40 CONTINUE +* +* Use unblocked code to reduce the last or only block +* + CALL SKYTD2( UPLO, N-I+1, A( I, I ), LDA, E( I ), + $ TAU( I ), IINFO ) + END IF +* + WORK( 1 ) = SROUNDUP_LWORK(LWKOPT) + RETURN +* +* End of SKYTRD +* + END diff --git a/SRC/skytrf.f b/SRC/skytrf.f new file mode 100644 index 000000000..61dd3fef6 --- /dev/null +++ b/SRC/skytrf.f @@ -0,0 +1,379 @@ +*> \brief \b SKYTRF +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SKYTRF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SKYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SKYTRF computes the factorization of a real skew-symmetric matrix A using +*> the Bunch partial pivoting method. The form of the +*> factorization is +*> +*> A = U**T*D*U or A = L*D*L**T +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and D is skew-symmetric and block diagonal with +*> 1-by-1 and 2-by-2 diagonal blocks. All 2-by-2 diagonal blocks are +*> nonsingular and all 1-by-1 diagonal blocks are 0. If N is odd, there +*> is at least one 1-by-1 diagonal block. +*> +*> This is the blocked version of the algorithm, calling Level 3 BLAS. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangle of A is stored; +*> = 'L': Lower triangle of A is stored. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the skew-symmetric matrix A. If UPLO = 'U', the +*> strictly upper triangular part of A contains the upper +*> triangular part of the matrix A, and the leading N-by-N lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> strictly lower triangular part of A contains the lower +*> triangular part of the matrix A, and the leading N-by-N upper +*> triangular part of A is not referenced. +*> +*> On exit, the block diagonal matrix D and the multipliers used +*> to obtain the factor U or L (see below for further details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges of D, as determined by SKYTRF. +*> +*> The elements of array IPIV are combined in pair, and the first +*> (if UPLO = 'U') or the second (if UPLO = 'L') element in +*> the pair always keeps the value 0. If N is odd, the first +*> (if UPLO = 'U') or the last (if UPLO = 'L') element of IPIV is +*> 0, which is the only element not in pair. So we only use the +*> first (if UPLO = 'L') or the second (if UPLO = 'U') element in +*> the pair to determine the interchanges. +*> +*> If IPIV(k) +*> = 0: there was no interchange. +*> > 0: rows and columns k-1 and IPIV(k) were interchanged, if +*> UPLO = 'U', and rows and columns k+1 and IPIV(k) were +*> interchanged, if UPLO = 'L'. +*> < 0: rows and columns k and k-1 were interchanged, +*> then rows and columns k-1 and -IPIV(k) were interchanged, if +*> UPLO = 'U', and rows and columns k and k+1 were interchanged, +*> then rows and columns k+1 and -IPIV(k) were interchanged, if +*> UPLO = 'L'. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The length of WORK. LWORK >=1. For best performance +*> LWORK >= N*NB, where NB is the block size returned by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i-1,i) (if UPLO = 'U') or D(i+1,i) (if UPLO = 'L') +*> is exactly zero. The factorization has been completed, +*> but the block diagonal matrix D is exactly singular, +*> so the solution could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kytrf +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', then A = U**T*D*U, where +*> U = P(n)*U(n)* ... *P(k)U(k)* ..., +*> i.e., U is a product of terms P(k)*U(k), where k decreases from n to +*> 1 in steps of 2, and D is a block diagonal matrix with 2-by-2 +*> diagonal blocks D(k). P(k) is a permutation matrix as defined by +*> IPIV(k), and U(k) is a unit upper triangular matrix, such that if +*> the diagonal block D(k) is of order 2, namely s = 2, then +*> +*> ( I v 0 ) k-s +*> U(k) = ( 0 I 0 ) s +*> ( 0 0 I ) n-k +*> k-s s n-k +*> +*> The strictly upper triangle of D(k) overwrites A(k-1,k), and v overwrites +*> A(1:k-2,k-1:k). +*> +*> If UPLO = 'L', then A = L*D*L**T, where +*> L = P(1)*L(1)* ... *P(k)*L(k)* ..., +*> i.e., L is a product of terms P(k)*L(k), where k increases from 1 to +*> n in steps of 2, and D is a block diagonal matrix with 2-by-2 +*> diagonal blocks D(k). P(k) is a permutation matrix as defined by +*> IPIV(k), and L(k) is a unit lower triangular matrix, such that if +*> the diagonal block D(k) is of order 2, namely s = 2, then +*> +*> ( I 0 0 ) k-1 +*> L(k) = ( 0 I 0 ) s +*> ( 0 v I ) n-k-s+1 +*> k-1 s n-k-s+1 +*> +*> The strictly lower triangle of D(k) overwrites A(k+1,k), and v overwrites +*> A(k+2:n,k:k+1). +*> +*> Remind that if n is odd, A is always singular. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SKYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + REAL SROUNDUP_LWORK + EXTERNAL LSAME, ILAENV, SROUNDUP_LWORK +* .. +* .. External Subroutines .. + EXTERNAL SLAKYF, SKYTF2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .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 = -4 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size +* + NB = ILAENV( 1, 'SKYTRF', UPLO, N, -1, -1, -1 ) + LWKOPT = MAX( 1, N*NB ) + WORK( 1 ) = SROUNDUP_LWORK( LWKOPT ) + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SKYTRF', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* + NBMIN = 2 + LDWORK = N + IF( NB.GT.1 .AND. NB.LT.N ) THEN + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN + NB = MAX( LWORK / LDWORK, 1 ) + NBMIN = MAX( 2, ILAENV( 2, 'SKYTRF', UPLO, N, -1, -1, + $ -1 ) ) + END IF + ELSE + IWS = 1 + END IF + IF( NB.LT.NBMIN ) + $ NB = N +* + IF( UPPER ) THEN +* +* Factorize A as U**T*D*U using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* KB, where KB is the number of columns factorized by SLAKYF; +* KB is either NB or NB-1, or K for the last block +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 40 +* + IF( K.GT.NB ) THEN +* +* Factorize columns k-kb+1:k of A and use blocked code to +* update columns 1:k-kb +* + CALL SLAKYF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, LDWORK, + $ IINFO ) + ELSE +* +* Use unblocked code to factorize columns 1:k of A +* + CALL SKYTF2( UPLO, K, A, LDA, IPIV, IINFO ) + KB = K + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO +* +* Decrease K and return to the start of the main loop +* + K = K - KB + GO TO 10 +* + ELSE +* +* Factorize A as L*D*L**T using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* KB, where KB is the number of columns factorized by SLAKYF; +* KB is either NB or NB-1, or N-K+1 for the last block +* + K = 1 + 20 CONTINUE +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 40 +* + IF( K.LE.N-NB ) THEN +* +* Factorize columns k:k+kb-1 of A and use blocked code to +* update columns k+kb:n +* + CALL SLAKYF( UPLO, N-K+1, NB, KB, A( K, K ), LDA, + $ IPIV( K ), + $ WORK, LDWORK, IINFO ) + ELSE +* +* Use unblocked code to factorize columns k:n of A +* + CALL SKYTF2( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), + $ IINFO ) + KB = N - K + 1 + END IF +* +* Set INFO on the first occurrence of a zero pivot +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + K - 1 +* +* Adjust IPIV +* + DO 30 J = K, K + KB - 1 + IF( IPIV( J ).GT.0 ) THEN + IPIV( J ) = IPIV( J ) + K - 1 + ELSEIF( IPIV( J ).LT.0 ) THEN + IPIV( J ) = IPIV( J ) - K + 1 + END IF + 30 CONTINUE +* +* Increase K and return to the start of the main loop +* + K = K + KB + GO TO 20 +* + END IF +* + 40 CONTINUE +* + WORK( 1 ) = SROUNDUP_LWORK( LWKOPT ) + RETURN +* +* End of SKYTRF +* + END diff --git a/SRC/skytri.f b/SRC/skytri.f new file mode 100644 index 000000000..4ffa88053 --- /dev/null +++ b/SRC/skytri.f @@ -0,0 +1,333 @@ +*> \brief \b SKYTRI +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SKYTRI + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SKYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SKYTRI computes the inverse of a real skew-symmetric indefinite matrix +*> A using the factorization A = U*D*U**T or A = L*D*L**T computed by +*> SSYTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the block diagonal matrix D and the multipliers +*> used to obtain the factor U or L as computed by SKYTRF. +*> +*> On exit, if INFO = 0, the (skew-symmetric) inverse of the original +*> matrix. If UPLO = 'U', the upper triangular part of the +*> inverse is formed and the part of A below the diagonal is not +*> referenced; if UPLO = 'L' the lower triangular part of the +*> inverse is formed and the part of A above the diagonal is +*> not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by SSYTRF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kytri +* +* ===================================================================== + SUBROUTINE SKYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER K, KP, KSTEP + REAL TEMP +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SDOT + EXTERNAL LSAME, SDOT +* .. +* .. External Subroutines .. + EXTERNAL SCOPY, SSWAP, SKYMV, SSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .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 = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SKYTRI', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. MOD(N,2).NE.0 ) + $ RETURN +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO 10 INFO = N, 2, -2 + IF( A( INFO - 1, INFO ).EQ.ZERO ) + $ RETURN + 10 CONTINUE + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO 20 INFO = 1, N-1, 2 + IF( A( INFO + 1, INFO ).EQ.ZERO ) + $ RETURN + 20 CONTINUE + END IF + INFO = 0 +* + IF( UPPER ) THEN +* +* Compute inv(A) from the factorization A = U*D*U**T. +* +* K is the main loop index, increasing from 1 to N in steps of 2 +* + K = 1 + 30 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GE.N ) + $ GO TO 40 +* +* +* 2 x 2 diagonal block +* +* Invert the diagonal block. +* + A( K, K+1 ) = -ONE / A( K, K+1 ) +* +* Compute columns K and K+1 of the inverse. +* + IF( K.GT.1 ) THEN + CALL SCOPY( K-1, A( 1, K ), 1, WORK, 1 ) + CALL SKYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, + $ A( 1, K ), 1 ) + A( K, K+1 ) = A( K, K+1 ) + + $ SDOT( K-1, A( 1, K ), 1, A( 1, K+1 ), + $ 1 ) + CALL SCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 ) + CALL SKYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, + $ A( 1, K+1 ), 1 ) + END IF + KSTEP = 2 +* + KP = IPIV( K+1 ) +* +* Interchange rows and columns K and KP in the leading +* submatrix A(1:k+1,1:k+1) +* + IF( KP.GT.0 ) THEN + CALL SSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) + CALL SSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) + CALL SSCAL( K-KP, -ONE, A( KP, K ), 1) + CALL SSCAL( K-KP-1, -ONE, A( KP, KP+1 ), LDA ) + TEMP = A( K, K+1 ) + A( K, K+1 ) = A( KP, K+1 ) + A( KP, K+1 ) = TEMP + ELSEIF( KP.LT.0 ) THEN + KP = -KP + CALL SSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) + CALL SSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) + CALL SSCAL( K-KP, -ONE, A( KP, K ), 1) + CALL SSCAL( K-KP-1, -ONE, A( KP, KP+1 ), LDA ) + TEMP = A( K, K+1 ) + A( K, K+1 ) = A( KP, K+1 ) + A( KP, K+1 ) = TEMP + CALL SSWAP( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 ) + A( K, K+1 ) = -A( K, K+1 ) + END IF +* + K = K + KSTEP + GO TO 30 + 40 CONTINUE +* + ELSE +* +* Compute inv(A) from the factorization A = L*D*L**T. +* +* K is the main loop index, increasing from 1 to N in steps of 2 +* + K = N + 50 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LE.1 ) + $ GO TO 60 +* +* +* 2 x 2 diagonal block +* +* Invert the diagonal block. +* + A( K, K-1 ) = -ONE / A( K, K-1 ) +* +* Compute columns K-1 and K of the inverse. +* + IF( K.LT.N ) THEN + CALL SCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) + CALL SKYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, + $ 1, ZERO, A( K+1, K ), 1 ) + A( K, K-1 ) = A( K, K-1 ) + + $ SDOT( N-K, A( K+1, K ), 1, A( K+1, K-1 ), + $ 1 ) + CALL SCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 ) + CALL SKYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, + $ 1, ZERO, A( K+1, K-1 ), 1 ) + END IF + KSTEP = 2 +* + KP = IPIV( K-1 ) +* +* Interchange rows and columns K and KP in the trailing +* submatrix A(k-1:n,k-1:n) +* + IF( KP.GT.0 ) THEN + IF( KP.LT.N ) + $ CALL SSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) + CALL SSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA ) + CALL SSCAL( KP-K, -ONE, A( K+1, K ), 1) + CALL SSCAL( KP-K-1, -ONE, A( KP, K+1 ), LDA ) + TEMP = A( K, K-1 ) + A( K, K-1 ) = A( KP, K-1 ) + A( KP, K-1 ) = TEMP + ELSEIF( KP.LT.0 ) THEN + KP = -KP + IF( KP.LT.N ) + $ CALL SSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) + CALL SSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA ) + CALL SSCAL( KP-K, -ONE, A( K+1, K ), 1) + CALL SSCAL( KP-K-1, -ONE, A( KP, K+1 ), LDA ) + TEMP = A( K, K-1 ) + A( K, K-1 ) = A( KP, K-1 ) + A( KP, K-1 ) = TEMP + CALL SSWAP( N-K, A( K+1, K ), 1, A( K+1, K-1 ), 1 ) + A( K, K-1 ) = -A( K, K-1 ) + END IF +* + K = K - KSTEP + GO TO 50 + 60 CONTINUE + END IF +* + RETURN +* +* End of SKYTRI +* + END diff --git a/SRC/skytri2.f b/SRC/skytri2.f new file mode 100644 index 000000000..1cfb3ff57 --- /dev/null +++ b/SRC/skytri2.f @@ -0,0 +1,208 @@ +*> \brief \b SKYTRI2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SKYTRI2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SKYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SKYTRI2 computes the inverse of a REAL skew-symmetric indefinite matrix +*> A using the factorization A = U*D*U**T or A = L*D*L**T computed by +*> SKYTRF. SKYTRI2 sets the LEADING DIMENSION of the workspace +*> before calling SKYTRI2X that actually computes the inverse. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the block diagonal matrix D and the multipliers +*> used to obtain the factor U or L as computed by SKYTRF. +*> +*> On exit, if INFO = 0, the (skew-symmetric) inverse of the original +*> matrix. If UPLO = 'U', the upper triangular part of the +*> inverse is formed and the part of A below the diagonal is not +*> referenced; if UPLO = 'L' the lower triangular part of the +*> inverse is formed and the part of A above the diagonal is +*> not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by SKYTRF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (N+NB+1)*(NB+3) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> WORK is size >= (N+NB+1)*(NB+3) +*> If LWORK = -1, then a workspace query is assumed; the routine +*> calculates: +*> - the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, +*> - and no error message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kytri2 +* +* ===================================================================== + SUBROUTINE SKYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL UPPER, LQUERY + INTEGER MINSIZE, NBMAX +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + REAL SROUNDUP_LWORK + EXTERNAL LSAME, ILAENV, SROUNDUP_LWORK +* .. +* .. External Subroutines .. + EXTERNAL SKYTRI, SKYTRI2X, XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* Get blocksize +* + NBMAX = ILAENV( 1, 'SKYTRF', UPLO, N, -1, -1, -1 ) + IF( N.EQ.0 ) THEN + MINSIZE = 1 + ELSE IF ( NBMAX .GE. N ) THEN + MINSIZE = N + ELSE + MINSIZE = (N+NBMAX+1)*(NBMAX+3) + END IF +* + IF( .NOT.UPPER .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 = -4 + ELSE IF (LWORK .LT. MINSIZE .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* +* Quick return if possible +* +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SKYTRI2', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + WORK( 1 ) = SROUNDUP_LWORK( MINSIZE ) + RETURN + END IF + IF( N.EQ.0 ) + $ RETURN + + IF( NBMAX .GE. N ) THEN + CALL SKYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) + ELSE + CALL SKYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NBMAX, INFO ) + END IF +* + RETURN +* +* End of SKYTRI2 +* + END diff --git a/SRC/skytri2x.f b/SRC/skytri2x.f new file mode 100644 index 000000000..73ae2aa94 --- /dev/null +++ b/SRC/skytri2x.f @@ -0,0 +1,541 @@ +*> \brief \b SKYTRI2X +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SKYTRI2X + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SKYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), WORK( N+NB+1,* ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SKYTRI2X computes the inverse of a real skew-symmetric indefinite matrix +*> A using the factorization A = U*D*U**T or A = L*D*L**T computed by +*> SKYTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the NNB diagonal matrix D and the multipliers +*> used to obtain the factor U or L as computed by SKYTRF. +*> +*> On exit, if INFO = 0, the (skew-symmetric) inverse of the original +*> matrix. If UPLO = 'U', the upper triangular part of the +*> inverse is formed and the part of A below the diagonal is not +*> referenced; if UPLO = 'L' the lower triangular part of the +*> inverse is formed and the part of A above the diagonal is +*> not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the NNB structure of D +*> as determined by SKYTRF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (N+NB+1,NB+3) +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Block size +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +*> inverse could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kytri2x +* +* ===================================================================== + SUBROUTINE SKYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), WORK( N+NB+1,* ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, IINFO, IP, K, CUT, NNB + INTEGER COUNT + INTEGER J, U11, INVD + + REAL T + REAL U01_I_J, U01_IP1_J + REAL U11_I_J, U11_IP1_J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SKYCONV, XERBLA, STRTRI + EXTERNAL SGEMM, STRMM, SKYSWAPR +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .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 = -4 + END IF +* +* Quick return if possible +* +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SKYTRI2X', -INFO ) + RETURN + END IF + IF( N.EQ.0 .OR. MOD(N,2).NE.0 ) + $ RETURN +* +* Convert A +* Workspace got Non-diag elements of D +* + CALL SKYCONV( UPLO, 'C', N, A, LDA, IPIV, WORK, IINFO ) +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + DO INFO = N, 2, -2 + IF( WORK( INFO, 1 ).EQ.ZERO ) + $ RETURN + END DO + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + DO INFO = 1, N-1, 2 + IF( WORK( INFO, 1 ).EQ.ZERO ) + $ RETURN + END DO + END IF + INFO = 0 +* +* Splitting Workspace +* U01 is a block (N,NB+1) +* The first element of U01 is in WORK(1,1) +* U11 is a block (NB+1,NB+1) +* The first element of U11 is in WORK(N+1,1) + U11 = N +* INVD is a block (N,2) +* The first element of INVD is in WORK(1,INVD) + INVD = NB+2 + + IF( UPPER ) THEN +* +* invA = P * inv(U**T)*inv(D)*inv(U)*P**T. +* + CALL STRTRI( UPLO, 'U', N, A, LDA, INFO ) +* +* inv(D) and inv(D)*inv(U) +* + K=1 + DO WHILE ( K .LE. N ) +* 2 x 2 diagonal NNB + T = WORK(K+1,1) + WORK(K,INVD) = ZERO + WORK(K+1,INVD+1) = ZERO + WORK(K,INVD+1) = -ONE / T + WORK(K+1,INVD) = ONE / T + K=K+2 + END DO +* +* inv(U**T) = (inv(U))**T +* +* inv(U**T)*inv(D)*inv(U) +* + CUT=N + DO WHILE (CUT .GT. 0) + NNB=NB + IF (CUT .LE. NNB) THEN + NNB=CUT + ELSE +* need a even number for a clear cut + IF (MOD(NNB,2) .EQ. 1) NNB=NNB+1 + END IF + + CUT=CUT-NNB +* +* U01 Block +* + DO I=1,CUT + DO J=1,NNB + WORK(I,J)=A(I,CUT+J) + END DO + END DO +* +* U11 Block +* + DO I=1,NNB + WORK(U11+I,I)=ONE + DO J=1,I-1 + WORK(U11+I,J)=ZERO + END DO + DO J=I+1,NNB + WORK(U11+I,J)=A(CUT+I,CUT+J) + END DO + END DO +* +* invD*U01 +* + I=1 + DO WHILE (I .LE. CUT) + DO J=1,NNB + U01_I_J = WORK(I,J) + U01_IP1_J = WORK(I+1,J) + WORK(I,J)=WORK(I,INVD)*U01_I_J+ + $ WORK(I,INVD+1)*U01_IP1_J + WORK(I+1,J)=WORK(I+1,INVD)*U01_I_J+ + $ WORK(I+1,INVD+1)*U01_IP1_J + END DO + I=I+2 + END DO +* +* invD1*U11 +* + I=1 + DO WHILE (I .LE. NNB) + DO J=I,NNB + U11_I_J = WORK(U11+I,J) + U11_IP1_J = WORK(U11+I+1,J) + WORK(U11+I,J)=WORK(CUT+I,INVD)*WORK(U11+I,J) + + $ WORK(CUT+I,INVD+1)*WORK(U11+I+1,J) + WORK(U11+I+1,J)=WORK(CUT+I+1,INVD)*U11_I_J+ + $ WORK(CUT+I+1,INVD+1)*U11_IP1_J + END DO + I=I+2 + END DO +* +* U11**T*invD1*U11->U11 +* + CALL STRMM('L','U','T','U',NNB, NNB, + $ ONE,A(CUT+1,CUT+1),LDA,WORK(U11+1,1),N+NB+1) +* + DO I=1,NNB + DO J=I,NNB + A(CUT+I,CUT+J)=WORK(U11+I,J) + END DO + END DO +* +* U01**T*invD*U01->A(CUT+I,CUT+J) +* + CALL SGEMM('T','N',NNB,NNB,CUT,ONE,A(1,CUT+1),LDA, + $ WORK,N+NB+1, ZERO, WORK(U11+1,1), N+NB+1) +* +* U11 = U11**T*invD1*U11 + U01**T*invD*U01 +* + DO I=1,NNB + DO J=I,NNB + A(CUT+I,CUT+J)=A(CUT+I,CUT+J)+WORK(U11+I,J) + END DO + END DO +* +* U01 = U00**T*invD0*U01 +* + CALL STRMM('L',UPLO,'T','U',CUT, NNB, + $ ONE,A,LDA,WORK,N+NB+1) + +* +* Update U01 +* + DO I=1,CUT + DO J=1,NNB + A(I,CUT+J)=WORK(I,J) + END DO + END DO +* +* Next Block +* + END DO +* +* Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T +* + I=1 + DO WHILE ( I .LT. N ) + IF( IPIV(I+1) .GT. 0 ) THEN + IP=IPIV(I+1) + I=I+1 + IF ( (I-1) .LT. IP) + $ CALL SKYSWAPR( UPLO, N, A, LDA, I-1 ,IP ) + IF ( (I-1) .GT. IP) + $ CALL SKYSWAPR( UPLO, N, A, LDA, IP ,I-1 ) + ELSEIF( IPIV(I+1) .LT. 0 ) THEN + IP=-IPIV(I+1) + I=I+1 + IF ( (I-1) .LT. IP) + $ CALL SKYSWAPR( UPLO, N, A, LDA, I-1 ,IP ) + IF ( (I-1) .GT. IP) + $ CALL SKYSWAPR( UPLO, N, A, LDA, IP ,I-1 ) + CALL SKYSWAPR( UPLO, N, A, LDA, I-1 ,I ) + ELSE + I=I+1 + ENDIF + I=I+1 + END DO + ELSE +* +* LOWER... +* +* invA = P * inv(U**T)*inv(D)*inv(U)*P**T. +* + CALL STRTRI( UPLO, 'U', N, A, LDA, INFO ) +* +* inv(D) and inv(D)*inv(U) +* + K=N + DO WHILE ( K .GE. 1 ) +* 2 x 2 diagonal NNB + T = WORK(K-1,1) + WORK(K-1,INVD) = ZERO + WORK(K,INVD) = ZERO + WORK(K,INVD+1) = -ONE / T + WORK(K-1,INVD+1) = ONE / T + K=K-2 + END DO +* +* inv(U**T) = (inv(U))**T +* +* inv(U**T)*inv(D)*inv(U) +* + CUT=0 + DO WHILE (CUT .LT. N) + NNB=NB + IF (CUT + NNB .GT. N) THEN + NNB=N-CUT + ELSE +* need a even number for a clear cut + IF (MOD(NNB,2) .EQ. 1) NNB=NNB+1 + END IF +* L21 Block + DO I=1,N-CUT-NNB + DO J=1,NNB + WORK(I,J)=A(CUT+NNB+I,CUT+J) + END DO + END DO +* L11 Block + DO I=1,NNB + WORK(U11+I,I)=ONE + DO J=I+1,NNB + WORK(U11+I,J)=ZERO + END DO + DO J=1,I-1 + WORK(U11+I,J)=A(CUT+I,CUT+J) + END DO + END DO +* +* invD*L21 +* + I=N-CUT-NNB + DO WHILE (I .GE. 1) + DO J=1,NNB + U01_I_J = WORK(I,J) + U01_IP1_J = WORK(I-1,J) + WORK(I,J)=WORK(CUT+NNB+I,INVD)*U01_I_J+ + $ WORK(CUT+NNB+I,INVD+1)*U01_IP1_J + WORK(I-1,J)=WORK(CUT+NNB+I-1,INVD+1)*U01_I_J+ + $ WORK(CUT+NNB+I-1,INVD)*U01_IP1_J + END DO + I=I-2 + END DO +* +* invD1*L11 +* + I=NNB + DO WHILE (I .GE. 1) + DO J=1,NNB + U11_I_J = WORK(U11+I,J) + U11_IP1_J = WORK(U11+I-1,J) + WORK(U11+I,J)=WORK(CUT+I,INVD)*WORK(U11+I,J) + + $ WORK(CUT+I,INVD+1)*U11_IP1_J + WORK(U11+I-1,J)=WORK(CUT+I-1,INVD+1)*U11_I_J+ + $ WORK(CUT+I-1,INVD)*U11_IP1_J + END DO + I=I-2 + END DO +* +* L11**T*invD1*L11->L11 +* + CALL STRMM('L',UPLO,'T','U',NNB, NNB, + $ ONE,A(CUT+1,CUT+1),LDA,WORK(U11+1,1),N+NB+1) + +* + DO I=1,NNB + DO J=1,I + A(CUT+I,CUT+J)=WORK(U11+I,J) + END DO + END DO +* + IF ( (CUT+NNB) .LT. N ) THEN +* +* L21**T*invD2*L21->A(CUT+I,CUT+J) +* + CALL SGEMM('T','N',NNB,NNB,N-NNB-CUT,ONE,A(CUT+NNB+1,CUT+1) + $ ,LDA,WORK,N+NB+1, ZERO, WORK(U11+1,1), N+NB+1) + +* +* L11 = L11**T*invD1*L11 + U01**T*invD*U01 +* + DO I=1,NNB + DO J=1,I + A(CUT+I,CUT+J)=A(CUT+I,CUT+J)+WORK(U11+I,J) + END DO + END DO +* +* L01 = L22**T*invD2*L21 +* + CALL STRMM('L',UPLO,'T','U', N-NNB-CUT, NNB, + $ ONE,A(CUT+NNB+1,CUT+NNB+1),LDA,WORK,N+NB+1) +* +* Update L21 +* + DO I=1,N-CUT-NNB + DO J=1,NNB + A(CUT+NNB+I,CUT+J)=WORK(I,J) + END DO + END DO + + ELSE +* +* L11 = L11**T*invD1*L11 +* + DO I=1,NNB + DO J=1,I + A(CUT+I,CUT+J)=WORK(U11+I,J) + END DO + END DO + END IF +* +* Next Block +* + CUT=CUT+NNB + END DO +* +* Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T +* + I=N + DO WHILE ( I .GT. 1 ) + IF( IPIV(I-1) .GT. 0 ) THEN + IP=IPIV(I-1) + IF ( I .LT. IP) CALL SKYSWAPR( UPLO, N, A, LDA, I , + $ IP ) + IF ( I .GT. IP) CALL SKYSWAPR( UPLO, N, A, LDA, IP , + $ I ) + I=I-1 + ELSEIF( IPIV(I-1) .LT. 0 ) THEN + IP=-IPIV(I-1) + IF ( I .LT. IP) CALL SKYSWAPR( UPLO, N, A, LDA, I , + $ IP ) + IF ( I .GT. IP) CALL SKYSWAPR( UPLO, N, A, LDA, IP , + $ I ) + CALL SKYSWAPR( UPLO, N, A, LDA, I-1 ,I ) + I=I-1 + ELSE + I=I-1 + ENDIF + I=I-1 + END DO + END IF +* + RETURN +* +* End of SKYTRI2X +* + END + diff --git a/SRC/skytrs.f b/SRC/skytrs.f new file mode 100644 index 000000000..8e73d4083 --- /dev/null +++ b/SRC/skytrs.f @@ -0,0 +1,527 @@ +*> \brief \b SKYTRS +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SKYTRS + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SKYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SKYTRS solves a system of linear equations A*X = B with a real +*> skew-symmetric matrix A using the factorization A = U*D*U**T or +*> A = L*D*L**T computed by SKYTRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by SKYTRF. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by SKYTRF. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kytrs +* +* ===================================================================== + SUBROUTINE SKYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J, K, KP + REAL AK, AKM1, AKM1K, BK, BKM1, DENOM +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SGEMV, SGER, SSCAL, SSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( (N.LT.0) .OR. (MOD(N,2).NE.0) ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SKYTRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Solve A*X = B, where A = U*D*U**T. +* +* First solve U*D*X = B, overwriting B with X. +* +* K is the main loop index, decreasing from N to 1 +* in steps of 2. +* + K = N + 10 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 30 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 2 x 2 diagonal block +* +* Interchange rows K-1 and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K-1 ) THEN + CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) + END IF +* +* Multiply by inv(U(K)), where U(K) is the transformation +* stored in columns K-1 and K of A. +* + CALL SGER( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, + $ B( 1, 1 ), LDB ) + CALL SGER( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ), + $ LDB, B( 1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + CALL SSCAL( NRHS, -ONE / A( K-1, K ), B( K, 1 ), LDB ) + CALL SSCAL( NRHS, ONE / A( K-1, K ), B( K-1, 1 ), LDB ) + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( K-1, 1 ), LDB ) +* + K = K - 2 + ELSEIF( IPIV( K ).LT.0 ) THEN +* +* 2 x 2 diagonal block +* +* Interchange rows K and K-1, then K-1 and -IPIV(K). +* + KP = -IPIV( K ) + IF( KP.NE.K-1 ) THEN + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( K-1, 1 ), LDB ) + CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) + END IF +* +* Multiply by inv(U(K)), where U(K) is the transformation +* stored in columns K-1 and K of A. +* + CALL SGER( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, + $ B( 1, 1 ), LDB ) + CALL SGER( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ), + $ LDB, B( 1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + CALL SSCAL( NRHS, -ONE / A( K-1, K ), B( K, 1 ), LDB ) + CALL SSCAL( NRHS, ONE / A( K-1, K ), B( K-1, 1 ), LDB ) + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( K-1, 1 ), LDB ) +* + K = K - 2 + ELSE +* +* 2 x 2 diagonal block +* +* Multiply by inv(U(K)), where U(K) is the transformation +* stored in columns K-1 and K of A. +* + CALL SGER( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, + $ B( 1, 1 ), LDB ) + CALL SGER( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ), + $ LDB, B( 1, 1 ), LDB ) +* +* Multiply by the inverse of the diagonal block. +* + CALL SSCAL( NRHS, -ONE / A( K-1, K ), B( K, 1 ), LDB ) + CALL SSCAL( NRHS, ONE / A( K-1, K ), B( K-1, 1 ), LDB ) + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( K-1, 1 ), LDB ) +* + K = K - 2 + END IF +* + GO TO 10 + 30 CONTINUE +* +* Next solve U**T *X = B, overwriting B with X. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + 40 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 50 +* + IF( IPIV( K+1 ).GT.0 ) THEN +* +* 2 x 2 diagonal block +* +* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation +* stored in columns K and K+1 of A. +* + CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, + $ K ), + $ 1, ONE, B( K, 1 ), LDB ) + CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, + $ A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB ) +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K+1 ) + IF( KP.NE.K ) THEN + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + K = K + 2 + ELSEIF( IPIV( K+1 ).LT.0 ) THEN +* +* 2 x 2 diagonal block +* +* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation +* stored in columns K and K+1 of A. +* + CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, + $ K ), + $ 1, ONE, B( K, 1 ), LDB ) + CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, + $ A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB ) +* +* Interchange rows K and -IPIV(K), then K and K+1. +* + KP = -IPIV( K+1 ) + IF( KP.NE.K ) THEN + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( K, 1 ), LDB ) + END IF + K = K + 2 + ELSE +* +* 2 x 2 diagonal block +* +* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation +* stored in columns K and K+1 of A. +* + CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, + $ A( 1, K ), 1, ONE, B( K, 1 ), LDB ) + CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, + $ A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB ) + K = K + 2 + END IF +* + GO TO 40 + 50 CONTINUE +* + ELSE +* +* Solve A*X = B, where A = L*D*L**T. +* +* First solve L*D*X = B, overwriting B with X. +* +* K is the main loop index, increasing from 1 to N +* in steps of 2. +* + K = 1 + 60 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 80 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 2 x 2 diagonal block +* +* Interchange rows K+1 and IPIV(K). +* + KP = IPIV( K ) + IF( KP.NE.K+1 ) THEN + CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) + END IF +* +* Multiply by inv(L(K)), where L(K) is the transformation +* stored in columns K and K+1 of A. +* + IF( K.LT.N-1 ) THEN + CALL SGER( N-K-1, NRHS, -ONE, A( K+2, K ), 1, + $ B( K, 1 ), LDB, B( K+2, 1 ), LDB ) + CALL SGER( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1, + $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) + END IF +* +* Multiply by the inverse of the diagonal block. +* + CALL SSCAL( NRHS, -ONE / A( K+1, K ), B( K, 1 ), LDB ) + CALL SSCAL( NRHS, ONE / A( K+1, K ), B( K+1, 1 ), LDB ) + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( K+1, 1 ), LDB ) +* + K = K + 2 + ELSEIF( IPIV( K ).LT.0 ) THEN +* +* 2 x 2 diagonal block +* +* Interchange rows K and K+1, then K+1 and -IPIV(K). +* + KP = -IPIV( K ) + IF( KP.NE.K+1 ) THEN + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( K+1, 1 ), LDB ) + CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) + END IF +* +* Multiply by inv(L(K)), where L(K) is the transformation +* stored in columns K and K+1 of A. +* + IF( K.LT.N-1 ) THEN + CALL SGER( N-K-1, NRHS, -ONE, A( K+2, K ), 1, + $ B( K, 1 ), LDB, B( K+2, 1 ), LDB ) + CALL SGER( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1, + $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) + END IF +* +* Multiply by the inverse of the diagonal block. +* + CALL SSCAL( NRHS, -ONE / A( K+1, K ), B( K, 1 ), LDB ) + CALL SSCAL( NRHS, ONE / A( K+1, K ), B( K+1, 1 ), LDB ) + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( K+1, 1 ), LDB ) +* + K = K + 2 + ELSE +* +* 2 x 2 diagonal block +* +* Multiply by inv(L(K)), where L(K) is the transformation +* stored in columns K and K+1 of A. +* + IF( K.LT.N-1 ) THEN + CALL SGER( N-K-1, NRHS, -ONE, A( K+2, K ), 1, + $ B( K, 1 ), LDB, B( K+2, 1 ), LDB ) + CALL SGER( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1, + $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) + END IF +* +* Multiply by the inverse of the diagonal block. + CALL SSCAL( NRHS, -ONE / A( K+1, K ), B( K, 1 ), LDB ) + CALL SSCAL( NRHS, ONE / A( K+1, K ), B( K+1, 1 ), LDB ) + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( K+1, 1 ), LDB ) +* + K = K + 2 + END IF +* + GO TO 60 + 80 CONTINUE +* +* Next solve L**T *X = B, overwriting B with X. +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = N + 90 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 100 +* + IF( IPIV( K-1 ).GT.0 ) THEN +* +* 2 x 2 diagonal block +* +* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation +* stored in columns K-1 and K of A. +* + IF( K.LT.N ) THEN + CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), + $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) + CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), + $ LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ), + $ LDB ) + END IF +* +* Interchange rows K and IPIV(K). +* + KP = IPIV( K-1 ) + IF( KP.NE.K ) THEN + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + K = K - 2 + ELSEIF( IPIV( K-1 ).LT.0 ) THEN +* +* 2 x 2 diagonal block +* +* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation +* stored in columns K-1 and K of A. +* + IF( K.LT.N ) THEN + CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), + $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) + CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), + $ LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ), + $ LDB ) + END IF +* +* Interchange rows K and -IPIV(K), then K and K-1. +* + KP = -IPIV( K-1 ) + IF( KP.NE.K ) THEN + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( K, 1 ), LDB ) + END IF + K = K - 2 + ELSE +* +* 2 x 2 diagonal block +* +* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation +* stored in columns K-1 and K of A. +* + IF( K.LT.N ) THEN + CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), + $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) + CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), + $ LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ), + $ LDB ) + END IF + K = K - 2 + END IF +* + GO TO 90 + 100 CONTINUE + END IF +* + RETURN +* +* End of SKYTRS +* + END diff --git a/SRC/skytrs2.f b/SRC/skytrs2.f new file mode 100644 index 000000000..6e2473685 --- /dev/null +++ b/SRC/skytrs2.f @@ -0,0 +1,324 @@ +*> \brief \b SKYTRS2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SKYTRS2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SKYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, +* WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SKYTRS2 solves a system of linear equations A*X = B with a real +*> skew-symmetric matrix A using the factorization A = U*D*U**T or +*> A = L*D*L**T computed by SKYTRF and converted by SKYCONV. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the details of the factorization are stored +*> as an upper or lower triangular matrix. +*> = 'U': Upper triangular, form is A = U*D*U**T; +*> = 'L': Lower triangular, form is A = L*D*L**T. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of columns +*> of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by SKYTRF. +*> Note that A is input / output. This might be counter-intuitive, +*> and one may think that A is input only. A is input / output. This +*> is because, at the start of the subroutine, we permute A in a +*> "better" form and then we permute A back to its original form at +*> the end. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D +*> as determined by SKYTRF. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB,NRHS) +*> On entry, the right hand side matrix B. +*> On exit, the solution matrix X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup kytrs2 +* +* ===================================================================== + SUBROUTINE SKYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + $ WORK, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, IINFO, K, KP +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SSCAL, SKYCONV, SSWAP, STRSM, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SKYTRS2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* +* Convert A +* + CALL SKYCONV( UPLO, 'C', N, A, LDA, IPIV, WORK, IINFO ) +* + IF( UPPER ) THEN +* +* Solve A*X = B, where A = U*D*U**T. +* +* P**T * B + K=N + DO WHILE ( K .GE. 2 ) + IF( IPIV( K ).GT.0 ) THEN +* 2 x 2 diagonal block +* Interchange rows K-1 and IPIV(K). + KP = IPIV( K ) + CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) + ELSEIF ( IPIV( K ).LT.0) THEN +* 2 x 2 diagonal block +* Interchange rows K-1 and -IPIV(K), then K and K-1. + KP = -IPIV( K ) + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( K-1, 1 ), LDB ) + CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) + END IF + K=K-2 + END DO +* +* Compute (U \P**T * B) -> B [ (U \P**T * B) ] +* + CALL STRSM('L','U','N','U',N,NRHS,ONE,A,LDA,B,LDB) +* +* Compute D \ B -> B [ D \ (U \P**T * B) ] +* + I=N + DO WHILE ( I .GE. 2 ) + CALL SSCAL( NRHS, -ONE / WORK( I ), B( I, 1 ), LDB ) + CALL SSCAL( NRHS, ONE / WORK( I ), B( I-1, 1 ), LDB ) + CALL SSWAP( NRHS, B( I, 1 ), LDB, B( I-1, 1 ), LDB ) + I = I - 2 + END DO +* +* Compute (U**T \ B) -> B [ U**T \ (D \ (U \P**T * B) ) ] +* + CALL STRSM('L','U','T','U',N,NRHS,ONE,A,LDA,B,LDB) +* +* P * B [ P * (U**T \ (D \ (U \P**T * B) )) ] +* + K=2 + DO WHILE ( K .LE. N ) + IF( IPIV( K ).GT.0 ) THEN +* 2 x 2 diagonal block +* Interchange rows K-1 and IPIV(K). + KP = IPIV( K ) + CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) + ELSEIF ( IPIV( K ).LT.0) THEN +* 2 x 2 diagonal block +* Interchange rows K and K-1, then K-1 and -IPIV(K). + KP = -IPIV( K ) + CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( K-1, 1 ), LDB ) + ENDIF + K=K+2 + END DO +* + ELSE +* +* Solve A*X = B, where A = L*D*L**T. +* +* P**T * B + K=1 + DO WHILE ( K .LE. N-1 ) + IF( IPIV( K ).GT.0 ) THEN +* 2 x 2 diagonal block +* Interchange rows K+1 and IPIV(K). + KP = IPIV( K ) + CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) + ELSEIF ( IPIV( K ).LT.0) THEN +* 2 x 2 diagonal block +* Interchange rows K+1 and -IPIV(K), then K and K+1. + KP = -IPIV( K ) + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( K+1, 1 ), LDB ) + CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) + ENDIF + K=K+2 + END DO +* +* Compute (L \P**T * B) -> B [ (L \P**T * B) ] +* + CALL STRSM('L','L','N','U',N,NRHS,ONE,A,LDA,B,LDB) +* +* Compute D \ B -> B [ D \ (L \P**T * B) ] +* + I=1 + DO WHILE ( I .LE. N-1 ) + CALL SSCAL( NRHS, -ONE / WORK( I ), B( I, 1 ), LDB ) + CALL SSCAL( NRHS, ONE / WORK( I ), B( I+1, 1 ), LDB ) + CALL SSWAP( NRHS, B( I, 1 ), LDB, B( I+1, 1 ), LDB ) + I = I + 2 + END DO +* +* Compute (L**T \ B) -> B [ L**T \ (D \ (L \P**T * B) ) ] +* + CALL STRSM('L','L','T','U',N,NRHS,ONE,A,LDA,B,LDB) +* +* P * B [ P * (L**T \ (D \ (L \P**T * B) )) ] +* + K=N-1 + DO WHILE ( K .GE. 1 ) + IF( IPIV( K ).GT.0 ) THEN +* 2 x 2 diagonal block +* Interchange rows K+1 and IPIV(K). + KP = IPIV( K ) + CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) + ELSEIF ( IPIV( K ).LT.0) THEN +* 2 x 2 diagonal block +* Interchange rows K and K+1, then K+1 and -IPIV(K). + KP = -IPIV( K ) + CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( K+1, 1 ), LDB ) + ENDIF + K=K-2 + END DO +* + END IF +* +* Revert A +* + CALL SKYCONV( UPLO, 'R', N, A, LDA, IPIV, WORK, IINFO ) +* + RETURN +* +* End of SKYTRS2 +* + END diff --git a/SRC/slakyf.f b/SRC/slakyf.f new file mode 100644 index 000000000..96c03121c --- /dev/null +++ b/SRC/slakyf.f @@ -0,0 +1,849 @@ +*> \brief \b SLAKYF computes a partial factorization of a real skew-symmetric matrix using the Bunch partial pivoting method. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SLASYF + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SLAKYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), W( LDW, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLAKYF computes a partial factorization of a real skew-symmetric matrix A +*> using the Bunch partial pivoting method. The partial factorization has +*> the form: +*> +*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: +*> ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) +*> +*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L' +*> ( L21 I ) ( 0 A22 ) ( 0 I ) +*> +*> where the order of D is at most NB. The actual order is returned in the +*> argument KB, and is either NB or NB-1, or N if N <= NB. +*> +*> SLAKYF is an auxiliary routine called by SKYTRF. It uses blocked code +*> (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or +*> A22 (if UPLO = 'L'). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> skew-symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The maximum number of columns of the matrix A that should be +*> factored. NB should be at least 2 to allow for 2-by-2 pivot +*> blocks. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> The number of columns of A that were actually factored. +*> KB is either NB-1 or NB, or N if N <= NB. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the skew-symmetric matrix A. If UPLO = 'U', the +*> strictly upper triangular part of A contains the upper +*> triangular part of the matrix A, and the leading N-by-N lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> strictly lower triangular part of A contains the lower +*> triangular part of the matrix A, and the leading N-by-N upper +*> triangular part of A is not referenced. +*> On exit, A contains details of the partial factorization. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D. +*> +*> If UPLO = 'U': +*> Only the last KB elements of IPIV are set. +*> +*> The elements of array IPIV are combined in pair, and the first +*> element in the pair always keeps the value 0. If N is odd, the +*> first element of IPIV is 0, which is the only element not in pair. +*> So we only use the second element in the pair to determine the +*> interchanges. +*> +*> If IPIV(k) +*> = 0: there was no interchange. +*> > 0: rows and columns k-1 and IPIV(k) were interchanged. +*> < 0: rows and columns k and k-1 were interchanged, +*> then rows and columns k-1 and -IPIV(k) were interchanged. +*> +*> If UPLO = 'L': +*> Only the first KB elements of IPIV are set. +*> +*> The elements of array IPIV are combined in pair, and the second +*> element in the pair always keeps the value 0. If N is odd, the +*> last element of IPIV is 0, which is the only element not in pair. +*> So we only use the first element in the pair to determine the +*> interchanges. +*> +*> If IPIV(k) +*> = 0: there was no interchange. +*> > 0: rows and columns k+1 and IPIV(k) were interchanged。 +*> < 0: rows and columns k and k+1 were interchanged, +*> then rows and columns k+1 and -IPIV(k) were interchanged. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is REAL array, dimension (LDW,NB) +*> \endverbatim +*> +*> \param[in] LDW +*> \verbatim +*> LDW is INTEGER +*> The leading dimension of the array W. LDW >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> > 0: if INFO = i, D(i-1,i) (if UPLO = 'U') or D(i+1,i) (if UPLO = 'L') +*> is exactly zero. The factorization has been completed, +*> but the block diagonal matrix D is exactly singular, +*> so the solution could not be computed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup lakyf +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2013, Igor Kozachenko, +*> Computer Science Division, +*> University of California, Berkeley +*> December 2023, Shuo Zheng +*> \endverbatim +* +* ===================================================================== + SUBROUTINE SLAKYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), W( LDW, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER IMAX1, IMAX2, J, JB, JJ, JMAX, JP, K, + $ KP, KW, KADJ + REAL ABSAKP1K, COLMAX1, COLMAX2 +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ISAMAX + EXTERNAL LSAME, ISAMAX +* .. +* .. External Subroutines .. + EXTERNAL SCOPY, SGEMM, SGEMV, SSCAL, SSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + KADJ = 0 + +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Factorize the leading columns of A using the upper triangle +* of A and working forwards, and compute the matrix W = U12*D +* for use in updating A11 +* +* K is the main loop index, decreasing from N in steps of 2 +* + K = N + 10 CONTINUE + KW = NB + K - N +* +* Exit from loop +* + IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LE.2 ) THEN + IF ( NB.GE.N .AND. K.EQ.2 ) THEN + CALL SCOPY( K-1, A( 1, K ), 1, W( 1, KW ), 1 ) + W( K, KW ) = ZERO + IF( K.LT.N ) THEN + CALL SGEMV( 'No transpose', K, N-K, ONE, + $ A( 1, K+1 ), LDA, W( K, KW+1 ), LDW, + $ ONE, W( 1, KW ), 1 ) + END IF + A( K-1, K ) = W( K-1, KW ) + IF ( ABS( A( K-1, K ) ) .EQ. ZERO) THEN + IF( INFO.EQ.0 ) + $ INFO = K + END IF + IPIV( K ) = 0 + K = K-2 + ELSEIF ( NB.GE.N .AND. K.EQ.1 ) THEN + IF( INFO.EQ.0 ) + $ INFO = K +* K = K-1 + KADJ = 1 + END IF + GO TO 30 + END IF +* +* Copy column K and K-1 of A to column K and K-1 of W and update them +* + CALL SCOPY( K-1, A( 1, K ), 1, W( 1, KW ), 1 ) + CALL SCOPY( K-2, A( 1, K-1 ), 1, W( 1, KW-1 ), 1 ) + W( K, KW ) = ZERO + W( K-1, KW-1 ) = ZERO + IF( K.LT.N ) THEN + CALL SGEMV( 'No transpose', K, N-K, ONE, A( 1, K+1 ), + $ LDA, W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 ) + CALL SGEMV( 'No transpose', K-1, N-K, ONE, A( 1, K+1 ), + $ LDA, W( K-1, KW+1 ), LDW, ONE, W( 1, KW-1 ), 1 ) + END IF + + W( K, KW-1 ) = -W( K-1, KW ) +* +* Determine rows and columns to be interchanged +* + ABSAKP1K = ABS( W( K-1, KW ) ) +* +* IMAX1 is the row-index of the absolute value largest element in +* row 1 to K-2, column K. +* IMAX2 is the row-index of the absolute value largest element in +* row 1 to K-2 column K-1. +* COLMAX1 and COLMAX2 are their absolute values. +* + IF(K.GT.2) THEN + IMAX1 = ISAMAX( K-2, W( 1, KW ), 1 ) + COLMAX1 = ABS( W( IMAX1, KW ) ) + IMAX2 = ISAMAX( K-2, W( 1, KW-1 ), 1 ) + COLMAX2 = ABS( W( IMAX2, KW-1 ) ) + ELSE + IMAX1 = 0 + COLMAX1 = ZERO + IMAX2 = 0 + COLMAX2 = ZERO + ENDIF +* + IF( MAX(MAX( ABSAKP1K, COLMAX1 ), COLMAX2).EQ.ZERO ) THEN +* +* Column K and K+1 is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = 0 + IPIV( K ) = KP + ELSE + IF( ABSAKP1K.GE.MAX( COLMAX1, COLMAX2 ) ) THEN +* +* No interchange +* + KP = 0 + IPIV( K ) = KP + ELSE + + IF( COLMAX1.GE.COLMAX2 ) THEN + +* +* Absolute value largest element is in column K +* Interchange rows and columns K-1 and IMAX1 +* + KP = IMAX1 + IPIV( K ) = KP + +* +* Write the column KW-1 of W with elements in column IMAX1 +* + CALL SCOPY( IMAX1-1, A( 1, IMAX1 ), 1, + $ W( 1, KW-1 ), 1 ) + + W( IMAX1, KW-1 ) = ZERO + + CALL SCOPY( K-IMAX1, A( IMAX1, IMAX1+1 ), LDA, + $ W( IMAX1+1, KW-1 ), 1 ) + + CALL SSCAL( K-IMAX1, -ONE, W( IMAX1+1, KW-1 ), 1) + +* +* Update the column KW-1 of W +* + IF( K.LT.N ) THEN + CALL SGEMV( 'No transpose', K, N-K, ONE, + $ A( 1, K+1 ), LDA, W( IMAX1, KW+1 ), LDW, + $ ONE, W( 1, KW-1 ), 1 ) + END IF + +* W( K, KW-1 ) = -W( K-1, KW ) + +* +* Write the column IMAX1 of A with elements in column K-1 of A +* + CALL SCOPY( IMAX1-1, A( 1, K-1 ), 1, + $ A( 1, IMAX1 ), 1 ) + + CALL SCOPY( K-IMAX1-2, A( IMAX1+1, K-1 ), 1, + $ A( IMAX1, IMAX1+1 ), LDA ) + + CALL SSCAL( K-IMAX1-2, -ONE, A( IMAX1, IMAX1+1 ), + $ LDA) +* +* Interchange rows K-1 and IMAX1 in last K-1 columns of A +* + IF( K.LT.N ) THEN + CALL SSWAP( N-K, A( K-1, K+1 ), LDA, + $ A( IMAX1, K+1 ), LDA ) + END IF + +* +* Interchange rows K-1 and IMAX1 in last KW-1 columns of W +* + CALL SSWAP( N-K+2, W( K-1, KW-1 ), LDW, + $ W( IMAX1, KW-1 ), LDW ) + + ELSE + +* +* Absolute value largest element is in column K-1 +* Interchange rows and columns K and K-1, then Interchange K-1 and IMAX2 +* + KP = -IMAX2 + IPIV( K ) = KP + +* +* Interchange columns KW and KW-1, then write the column KW-1 of W with elements in column IMAX2 +* + CALL SSWAP( K, W( 1, KW ), 1, W( 1, KW-1 ), + $ 1 ) + + CALL SCOPY( IMAX2-1, A( 1, IMAX2 ), 1, + $ W( 1, KW-1 ), 1 ) + + W( IMAX2, KW-1 ) = ZERO + + CALL SCOPY( K-IMAX2, A( IMAX2, IMAX2+1 ), LDA, + $ W( IMAX2+1, KW-1 ), 1 ) + + CALL SSCAL( K-IMAX2, -ONE, W( IMAX2+1, KW-1 ), 1) + +* +* Update the column KW-1 of W +* + IF( K.LT.N ) THEN + CALL SGEMV( 'No transpose', K, N-K, ONE, + $ A( 1, K+1 ), LDA, W( IMAX2, KW+1 ), LDW, + $ ONE, W( 1, KW-1 ), 1 ) + END IF + +* W( K, KW-1 ) = -W( K-1, KW ) + +* Interchange rows K and K-1 columns of A +* + CALL SSWAP( K-2, A( 1, K ), 1, A( 1, K-1 ), + $ 1 ) + + A( K-1, K ) = -A( K-1, K ) + +* +* Write the column IMAX2 of A with elements in column K-1 of A +* + CALL SCOPY( IMAX2-1, A( 1, K-1 ), 1, + $ A( 1, IMAX2 ), 1 ) + + CALL SCOPY( K-IMAX2-2, A( IMAX2+1, K-1 ), 1, + $ A( IMAX2, IMAX2+1 ), LDA ) + + CALL SSCAL( K-IMAX2-2, -ONE, A( IMAX2, IMAX2+1 ), + $ LDA) +* +* Interchange rows K and K-1, then K-1 and IMAX2 in last K+1 columns of A +* + IF( K.LT.N ) THEN + CALL SSWAP( N-K, A( K, K+1 ), LDA, A( K-1, K+1 ), + $ LDA ) + + CALL SSWAP( N-K, A( K-1, K+1 ), LDA, + $ A( IMAX2, K+1 ), LDA ) + END IF + +* +* Interchange rows K and K-1, then K-1 and IMAX2 in last K-1 columns of W +* + CALL SSWAP( N-K+2, W( K, KW-1 ), LDW, + $ W( K-1, KW-1 ), LDW ) + + CALL SSWAP( N-K+2, W( K-1, KW-1 ), LDW, + $ W( IMAX2, KW-1 ), LDW ) + + END IF + END IF + +* +* Write back C*S^-1 to A +* + DO 20 J = 1, K-2 + A( J, K-1 ) = W( J, KW )/W( K-1, KW ) + A( J, K ) = -W( J, KW-1 )/W( K-1, KW ) +20 CONTINUE + + A( K-1, K ) = W( K-1, KW ) + + END IF + + K = K-2 + + GO TO 10 +* +30 CONTINUE + + KW = NB + K - N +* +* Update the upper triangle of A11 (= A(1:k,1:k)) as +* +* A11 := A11 + U12*D*U12**T = A11 + U12*W**T +* +* computing blocks of NB columns at a time +* + DO 50 J = 1, K, NB + JB = MIN( NB, K-J+1 ) + +* +* Update the rectangular subdiagonal block +* + IF( J+JB.LE.K ) + $ CALL SGEMM( 'No transpose', 'Transpose', K-J-JB+1, + $ JB, N-K, ONE, A( 1, K+1 ), LDA, + $ W( K-J-JB+2, KW+1 ), LDW, ONE, + $ A( 1, K-J-JB+2 ), LDA ) +* +* Update the upper triangle of the diagonal block +* + DO 40 JJ = 1, JB - 1 + CALL SGEMV( 'No transpose', JJ, N-K, ONE, + $ A( K-J-JB+2, K+1 ), LDA, + $ W( K+JJ-J-JB+2, KW+1 ), LDW, ONE, + $ A( K-J-JB+2, K+JJ-J-JB+2 ), 1 ) + 40 CONTINUE + + 50 CONTINUE +* +* Put U12 in standard form by partially undoing the interchanges +* of rows in columns 1:k-1 looping backwards from k-1 to 1 +* + J = N - K - 1 + 60 CONTINUE +* +* Undo the interchanges (if any) of rows JJ and JP at each +* step J +* +* (Here, J is a diagonal index) + + IF( J.GT.1 ) THEN + JJ = N-J+1 + JP = IPIV( N-J+1 ) + + IF( JP.LT.0 ) THEN + JP = -JP +* (Here, J is a diagonal index) + CALL SSWAP( J-1, A( JP, N-J+2 ), LDA, + $ A( JJ-1, N-J+2 ), LDA ) + CALL SSWAP( J-1, A( JJ-1, N-J+2 ), LDA, + $ A( JJ, N-J+2 ), LDA ) + ELSEIF( JP.GT.0 ) THEN + CALL SSWAP( J-1, A( JP, N-J+2 ), LDA, + $ A( JJ-1, N-J+2 ), LDA ) + END IF + + END IF +* (NOTE: Here, J is used to determine row length. Length J +* of the rows to swap back doesn't include diagonal element) + + J = J - 2 + IF( J.GT.1 ) + $ GO TO 60 +* +* Set KB to the number of columns factorized +* + KB = N - K + KADJ +* + ELSE +* +* Factorize the leading columns of A using the lower triangle +* of A and working forwards, and compute the matrix W = L21*D +* for use in updating A22 +* +* K is the main loop index, increasing from 1 in steps 2 +* + K = 1 + 70 CONTINUE +* +* Exit from loop +* + IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GE.N-1 ) THEN + IF( NB.GE.N .AND. K.EQ.N-1 ) THEN + CALL SCOPY( N-K, A( K+1, K ), 1, W( K+1, K ), 1 ) + W( K, K ) = ZERO + CALL SGEMV( 'No transpose', N-K+1, K-1, ONE, + $ A( K, 1 ), LDA, W( K, 1 ), LDW, ONE, + $ W( K, K ), 1 ) + A( K+1, K ) = W( K+1, K ) + IF ( ABS( A( K+1, K ) ) .EQ. ZERO) THEN + IF( INFO.EQ.0 ) + $ INFO = K + END IF + IPIV( K ) = 0 + K = K+2 + ELSEIF( NB.GE.N .AND. K.EQ.N ) THEN + IF( INFO.EQ.0 ) + $ INFO = K +* K = K+1 + KADJ = 1 + END IF + GO TO 90 + END IF +* +* Copy column K and K+1 of A to column K and K+1 of W and update them +* + CALL SCOPY( N-K, A( K+1, K ), 1, W( K+1, K ), 1 ) + CALL SCOPY( N-K-1, A( K+2, K+1 ), 1, W( K+2, K+1 ), 1 ) + W( K, K ) = ZERO + W( K+1, K+1 ) = ZERO + CALL SGEMV( 'No transpose', N-K+1, K-1, ONE, A( K, 1 ), + $ LDA, W( K, 1 ), LDW, ONE, W( K, K ), 1 ) + CALL SGEMV( 'No transpose', N-K, K-1, ONE, A( K+1, 1 ), + $ LDA, W( K+1, 1 ), LDW, ONE, W( K+1, K+1 ), 1 ) + + W( K, K+1 ) = -W( K+1, K ) +* +* Determine rows and columns to be interchanged +* + ABSAKP1K = ABS( W( K+1, K ) ) +* +* IMAX1 is the row-index of the absolute value largest element in +* row K+2 to N, column K. +* IMAX2 is the row-index of the absolute value largest element in +* row K+2 to N, column K+1. +* COLMAX1 and COLMAX2 are their absolute values. +* + IF(K.LT.N-1) THEN + IMAX1 = K+1 + ISAMAX( N-K-1, W( K+2, K ), 1 ) + COLMAX1 = ABS( W( IMAX1, K ) ) + IMAX2 = K+1 + ISAMAX( N-K-1, W( K+2, K+1 ), 1 ) + COLMAX2 = ABS( W( IMAX2, K+1 ) ) + ELSE + IMAX1 = 0 + COLMAX1 = ZERO + IMAX2 = 0 + COLMAX2 = ZERO + ENDIF +* + IF( MAX(MAX( ABSAKP1K, COLMAX1 ), COLMAX2).EQ.ZERO ) THEN +* +* Column K and K+1 is zero or underflow: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = 0 + IPIV( K ) = KP + ELSE + IF( ABSAKP1K.GE.MAX( COLMAX1, COLMAX2 ) ) THEN +* +* No interchange +* + KP = 0 + IPIV( K ) = KP + ELSE + + IF( COLMAX1.GE.COLMAX2 ) THEN + +* +* Absolute value largest element is in column K +* Interchange rows and columns K+1 and IMAX1 +* + KP = IMAX1 + IPIV( K ) = KP + +* +* Write the column K+1 of W with elements in column IMAX1 +* + CALL SCOPY( IMAX1-K, A( IMAX1, K ), LDA, + $ W( K, K+1 ), 1 ) + + CALL SSCAL( IMAX1-K, -ONE, W( K, K+1 ), 1) + + W( IMAX1, K+1 ) = ZERO + + CALL SCOPY( N-IMAX1, A( IMAX1+1, IMAX1 ), 1, + $ W( IMAX1+1, K+1 ), 1 ) + +* +* Update the column K+1 of W +* + CALL SGEMV( 'No transpose', N-K+1, K-1, ONE, + $ A( K, 1 ), LDA, W( IMAX1, 1 ), LDW, ONE, + $ W( K, K+1 ), 1 ) + +* W( K, K+1 ) = -W( K+1, K ) + +* +* Write the column IMAX1 of A with elements in column K+1 of A +* + CALL SCOPY( IMAX1-K-2, A( K+2, K+1 ), 1, + $ A( IMAX1, K+2 ), LDA ) + + CALL SSCAL( IMAX1-K-2, -ONE, A( IMAX1, K+2 ), LDA) + + CALL SCOPY( N-IMAX1, A( IMAX1+1, K+1 ), 1, + $ A( IMAX1+1, IMAX1 ), 1 ) + +* +* Interchange rows K+1 and IMAX1 in first K-1 columns of A +* + CALL SSWAP( K-1, A( K+1, 1 ), LDA, A( IMAX1, 1 ), + $ LDA ) + +* +* Interchange rows K+1 and IMAX1 in first K-1 columns of W +* + CALL SSWAP( K+1, W( K+1, 1 ), LDW, W( IMAX1, 1 ), + $ LDW ) + + ELSE + +* +* Absolute value largest element is in column K+1 +* Interchange rows and columns K and K+1, then Interchange K+1 and IMAX2 +* + KP = -IMAX2 + IPIV( K ) = KP + +* +* Interchange columns K and K+1, then write the column K+1 of W with elements in column IMAX2 +* + CALL SSWAP( N-K+1, W( K, K ), 1, W( K, K+1 ), + $ 1 ) + + CALL SCOPY( IMAX2-K, A( IMAX2, K ), LDA, + $ W( K, K+1 ), 1 ) + + CALL SSCAL( IMAX2-K, -ONE, W( K, K+1 ), 1) + + W( IMAX2, K+1 ) = ZERO + + CALL SCOPY( N-IMAX2, A( IMAX2+1, IMAX2 ), 1, + $ W( IMAX2+1, K+1 ), 1 ) + +* +* Update the column K+1 of W +* + CALL SGEMV( 'No transpose', N-K+1, K-1, ONE, + $ A( K, 1 ), LDA, W( IMAX2, 1 ), LDW, ONE, + $ W( K, K+1 ), 1 ) + +* W( K, K+1 ) = -W( K+1, K ) + +* Interchange rows K and K+1 columns of A +* + CALL SSWAP( N-K-1, A( K+2, K ), 1, A( K+2, K+1 ), + $ 1 ) + + A( K+1, K ) = -A( K+1, K ) + +* +* Write the column IMAX2 of A with elements in column K+1 of A +* + CALL SCOPY( IMAX2-K-2, A( K+2, K+1 ), 1, + $ A( IMAX2, K+2 ), LDA ) + + CALL SSCAL( IMAX2-K-2, -ONE, A( IMAX2, K+2 ), LDA) + + CALL SCOPY( N-IMAX2, A( IMAX2+1, K+1 ), 1, + $ A( IMAX2+1, IMAX2 ), 1 ) + +* +* Interchange rows K and K+1, then K+1 and IMAX2 in first K-1 columns of A +* + CALL SSWAP( K-1, A( K, 1 ), LDA, A( K+1, 1 ), + $ LDA ) + + CALL SSWAP( K-1, A( K+1, 1 ), LDA, A( IMAX2, 1 ), + $ LDA ) + +* +* Interchange rows K and K+1, then K+1 and IMAX2 in first K-1 columns of W +* + CALL SSWAP( K+1, W( K, 1 ), LDW, W( K+1, 1 ), + $ LDW ) + + CALL SSWAP( K+1, W( K+1, 1 ), LDW, W( IMAX2, 1 ), + $ LDW ) + + END IF + END IF + +* +* Write back C*S^-1 to A +* + DO 80 J = K+2, N + A( J, K ) = -W( J, K+1 )/W( K+1, K ) + A( J, K+1 ) = W( J, K )/W( K+1, K ) +80 CONTINUE + + A( K+1, K ) = W( K+1, K ) + + END IF + + K = K+2 + + GO TO 70 +* +90 CONTINUE +* +* Update the lower triangle of A22 (= A(k:n,k:n)) as +* +* A22 := A22 + L21*D*L21**T = A22 + L21*W**T +* +* computing blocks of NB columns at a time +* + DO 110 J = K, N, NB + JB = MIN( NB, N-J+1 ) +* +* Update the lower triangle of the diagonal block +* + DO 100 JJ = J, J + JB - 2 + CALL SGEMV( 'No transpose', J+JB-JJ-1, K-1, ONE, + $ A( JJ+1, 1 ), LDA, W( JJ, 1 ), LDW, + $ ONE, A( JJ+1, JJ ), 1 ) + 100 CONTINUE +* +* Update the rectangular subdiagonal block +* + IF( J+JB.LE.N ) + $ CALL SGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, + $ K-1, ONE, A( J+JB, 1 ), LDA, W( J, 1 ), + $ LDW, ONE, A( J+JB, J ), LDA ) + 110 CONTINUE +* +* Put L21 in standard form by partially undoing the interchanges +* of rows in columns 1:k-1 looping backwards from k-1 to 1 +* + J = K - 2 + 120 CONTINUE +* +* Undo the interchanges (if any) of rows JJ and JP at each +* step J +* +* (Here, J is a diagonal index) + + IF( J.GT.1 ) THEN + JJ = J + JP = IPIV( J ) + + IF( JP.LT.0 ) THEN + JP = -JP +* (Here, J is a diagonal index) + CALL SSWAP( J-1, A( JP, 1 ), LDA, A( JJ+1, 1 ), + $ LDA ) + CALL SSWAP( J-1, A( JJ+1, 1 ), LDA, A( JJ, 1 ), + $ LDA ) + ELSEIF( JP.GT.0 ) THEN + CALL SSWAP( J-1, A( JP, 1 ), LDA, A( JJ+1, 1 ), + $ LDA ) + END IF + + END IF +* (NOTE: Here, J is used to determine row length. Length J +* of the rows to swap back doesn't include diagonal element) + + J = J - 2 + IF( J.GT.1 ) + $ GO TO 120 +* +* Set KB to the number of columns factorized +* + KB = K - 1 + KADJ +* + END IF + RETURN +* +* End of SLASYF +* + END diff --git a/SRC/slankt.f b/SRC/slankt.f new file mode 100644 index 000000000..55b5aae34 --- /dev/null +++ b/SRC/slankt.f @@ -0,0 +1,175 @@ +*> \brief \b SLANKT returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real skew-symmetric tridiagonal matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SLANKT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* REAL FUNCTION SLANKT( NORM, N, E ) +* +* .. Scalar Arguments .. +* CHARACTER NORM +* INTEGER N +* .. +* .. Array Arguments .. +* REAL E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLANKT returns the value of the one norm, or the Frobenius norm, or +*> the infinity norm, or the element of largest absolute value of a +*> real skew-symmetric tridiagonal matrix A. +*> \endverbatim +*> +*> \return SLANKT +*> \verbatim +*> +*> SLANKT = ( max(abs(A(i,j))), NORM = 'M' or 'm' +*> ( +*> ( norm1(A), NORM = '1', 'O' or 'o' +*> ( +*> ( normI(A), NORM = 'I' or 'i' +*> ( +*> ( normF(A), NORM = 'F', 'f', 'E' or 'e' +*> +*> where norm1 denotes the one norm of a matrix (maximum column sum), +*> normI denotes the infinity norm of a matrix (maximum row sum) and +*> normF denotes the Frobenius norm of a matrix (square root of sum of +*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is CHARACTER*1 +*> Specifies the value to be returned in SLANKT as described +*> above. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. When N = 0, SLANKT is +*> set to zero. +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is REAL array, dimension (N-1) +*> The (n-1) sub-diagonal or super-diagonal elements of A. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup lankt +* +* ===================================================================== + REAL FUNCTION SLANKT( NORM, N, E ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER N +* .. +* .. Array Arguments .. + REAL E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER I + REAL ANORM, SCALE, SUM +* .. +* .. External Functions .. + LOGICAL LSAME, SISNAN + EXTERNAL LSAME, SISNAN +* .. +* .. External Subroutines .. + EXTERNAL SLASSQ +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +* .. +* .. Executable Statements .. +* + IF( N.LE.0 ) THEN + ANORM = ZERO + ELSE IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + ANORM = ABS( E( N-1 ) ) + DO 10 I = 1, N - 2 + SUM = ABS( E( I ) ) + IF( ANORM .LT. SUM .OR. SISNAN( SUM ) ) ANORM = SUM + 10 CONTINUE + ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR. + $ LSAME( NORM, 'I' ) ) THEN +* +* Find norm1(A). +* + IF( N.EQ.1 ) THEN + ANORM = ZERO + ELSE + ANORM = ABS( E( 1 ) ) + SUM = ABS( E( N-1 ) ) + IF( ANORM .LT. SUM .OR. SISNAN( SUM ) ) ANORM = SUM + DO 20 I = 2, N - 1 + SUM = ABS( E( I ) )+ABS( E( I-1 ) ) + IF( ANORM .LT. SUM .OR. SISNAN( SUM ) ) ANORM = SUM + 20 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. + $ ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + IF( N.GT.1 ) THEN + CALL SLASSQ( N-1, E, 1, SCALE, SUM ) + SUM = 2*SUM + END IF + ANORM = SCALE*SQRT( SUM ) + END IF +* + SLANKT = ANORM + RETURN +* +* End of SLANKT +* + END diff --git a/SRC/slanky.f b/SRC/slanky.f new file mode 100644 index 000000000..2a3c51c64 --- /dev/null +++ b/SRC/slanky.f @@ -0,0 +1,239 @@ +*> \brief \b SLANKY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real skew-symmetric matrix. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SLANKY + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* REAL FUNCTION SLANKY( NORM, UPLO, N, A, LDA, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER NORM, UPLO +* INTEGER LDA, N +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLANKY returns the value of the one norm, or the Frobenius norm, or +*> the infinity norm, or the element of largest absolute value of a +*> real skew-symmetric matrix A. +*> \endverbatim +*> +*> \return SLANKY +*> \verbatim +*> +*> SLANKY = ( max(abs(A(i,j))), NORM = 'M' or 'm' +*> ( +*> ( norm1(A), NORM = '1', 'O' or 'o' +*> ( +*> ( normI(A), NORM = 'I' or 'i' +*> ( +*> ( normF(A), NORM = 'F', 'f', 'E' or 'e' +*> +*> where norm1 denotes the one norm of a matrix (maximum column sum), +*> normI denotes the infinity norm of a matrix (maximum row sum) and +*> normF denotes the Frobenius norm of a matrix (square root of sum of +*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NORM +*> \verbatim +*> NORM is CHARACTER*1 +*> Specifies the value to be returned in SLANKY as described +*> above. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> skew-symmetric matrix A is to be referenced. +*> = 'U': Upper triangular part of A is referenced +*> = 'L': Lower triangular part of A is referenced +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. When N = 0, SLANKY is +*> set to zero. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> The skew-symmetric matrix A. If UPLO = 'U', the leading n by n +*> upper triangular part of A contains the upper triangular part +*> of the matrix A, and the strictly lower triangular part of A +*> is not referenced. If UPLO = 'L', the leading n by n lower +*> triangular part of A contains the lower triangular part of +*> the matrix A, and the strictly upper triangular part of A is +*> not referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(N,1). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MAX(1,LWORK)), +*> where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, +*> WORK is not referenced. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup lanke +* +* ===================================================================== + REAL FUNCTION SLANKY( NORM, UPLO, N, A, LDA, WORK ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER NORM, UPLO + INTEGER LDA, N +* .. +* .. Array Arguments .. + REAL A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + REAL ABSA, SCALE, SUM, VALUE +* .. +* .. External Subroutines .. + EXTERNAL SLASSQ +* .. +* .. External Functions .. + LOGICAL LSAME, SISNAN + EXTERNAL LSAME, SISNAN +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +* .. +* .. Executable Statements .. +* + IF( N.EQ.0 ) THEN + VALUE = ZERO + ELSE IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + VALUE = ZERO + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, J - 1 + SUM = ABS( A( I, J ) ) + IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = J + 1, N + SUM = ABS( A( I, J ) ) + IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM + 30 CONTINUE + 40 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. + $ ( LSAME( NORM, 'O' ) ) .OR. + $ ( NORM.EQ.'1' ) ) THEN +* +* Find normI(A) ( = norm1(A), since A is skew-symmetric). +* + VALUE = ZERO + IF( LSAME( UPLO, 'U' ) ) THEN + DO 60 J = 1, N + SUM = ZERO + DO 50 I = 1, J - 1 + ABSA = ABS( A( I, J ) ) + SUM = SUM + ABSA + WORK( I ) = WORK( I ) + ABSA + 50 CONTINUE + WORK( J ) = SUM + 60 CONTINUE + DO 70 I = 1, N + SUM = WORK( I ) + IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM + 70 CONTINUE + ELSE + DO 80 I = 1, N + WORK( I ) = ZERO + 80 CONTINUE + DO 100 J = 1, N + SUM = WORK( J ) + DO 90 I = J + 1, N + ABSA = ABS( A( I, J ) ) + SUM = SUM + ABSA + WORK( I ) = WORK( I ) + ABSA + 90 CONTINUE + IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM + 100 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. + $ ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + IF( LSAME( UPLO, 'U' ) ) THEN + DO 110 J = 2, N + CALL SLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) + 110 CONTINUE + ELSE + DO 120 J = 1, N - 1 + CALL SLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) + 120 CONTINUE + END IF + SUM = 2*SUM + VALUE = SCALE*SQRT( SUM ) + END IF +* + SLANKY = VALUE + RETURN +* +* End of SLANKY +* + END diff --git a/SRC/slatrdk.f b/SRC/slatrdk.f new file mode 100644 index 000000000..a1e6e2b9c --- /dev/null +++ b/SRC/slatrdk.f @@ -0,0 +1,332 @@ +*> \brief \b SLATRDK reduces the first nb rows and columns of a skew-symmetric/Hermitian matrix A to real tridiagonal form by an orthogonal similarity transformation. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SLATRDK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SLATRDK( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDW, N, NB +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLATRDK reduces NB rows and columns of a real skew-symmetric matrix A to +*> skew-symmetric tridiagonal form by an orthogonal similarity +*> transformation Q**T * A * Q, and returns the matrices V and W which are +*> needed to apply the transformation to the unreduced part of A. +*> +*> If UPLO = 'U', SLATRDK reduces the last NB rows and columns of a +*> matrix, of which the upper triangle is supplied; +*> if UPLO = 'L', SLATRDK reduces the first NB rows and columns of a +*> matrix, of which the lower triangle is supplied. +*> +*> This is an auxiliary routine called by SSYTRD. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> skew-symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The number of rows and columns to be reduced. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> On entry, the skew-symmetric matrix A. If UPLO = 'U', the strictly +*> n-by-n upper triangular part of A contains the upper +*> triangular part of the matrix A, and the leading lower +*> triangular part of A is not referenced. If UPLO = 'L', the +*> strictly n-by-n lower triangular part of A contains the lower +*> triangular part of the matrix A, and the leading upper +*> triangular part of A is not referenced. +*> On exit: +*> if UPLO = 'U', the last NB columns have been reduced to +*> tridiagonal form, with the elements above the diagonal +*> with the array TAU, represent the orthogonal matrix Q as a +*> product of elementary reflectors; +*> if UPLO = 'L', the first NB columns have been reduced to +*> tridiagonal form, with the elements below the diagonal +*> with the array TAU, represent the orthogonal matrix Q as a +*> product of elementary reflectors. +*> See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= (1,N). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is REAL array, dimension (N-1) +*> If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal +*> elements of the last NB columns of the reduced matrix; +*> if UPLO = 'L', E(1:nb) contains the subdiagonal elements of +*> the first NB columns of the reduced matrix. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is REAL array, dimension (N-1) +*> The scalar factors of the elementary reflectors, stored in +*> TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. +*> See Further Details. +*> \endverbatim +*> +*> \param[out] W +*> \verbatim +*> W is REAL array, dimension (LDW,NB) +*> The n-by-nb matrix W required to update the unreduced part +*> of A. +*> \endverbatim +*> +*> \param[in] LDW +*> \verbatim +*> LDW is INTEGER +*> The leading dimension of the array W. LDW >= max(1,N). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup latrdk +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> If UPLO = 'U', the matrix Q is represented as a product of elementary +*> reflectors +*> +*> Q = H(n) H(n-1) . . . H(n-nb+1). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), +*> and tau in TAU(i-1). +*> +*> If UPLO = 'L', the matrix Q is represented as a product of elementary +*> reflectors +*> +*> Q = H(1) H(2) . . . H(nb). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), +*> and tau in TAU(i). +*> +*> The elements of the vectors v together form the n-by-nb matrix V +*> which is needed, with W, to apply the transformation to the unreduced +*> part of the matrix, using a skew-symmetric rank-2k update of the form: +*> A := A - V*W**T + W*V**T. +*> +*> The contents of A on exit are illustrated by the following examples +*> with n = 5 and nb = 2: +*> +*> if UPLO = 'U': if UPLO = 'L': +*> +*> ( 0 a a v4 v5 ) ( 0 ) +*> ( 0 a v4 v5 ) ( 1 0 ) +*> ( 0 1 v5 ) ( v1 1 0 ) +*> ( 0 1 ) ( v1 v2 a 0 ) +*> ( 0 ) ( v1 v2 a a 0 ) +*> +*> where a denotes an element of the original matrix that is unchanged, +*> and vi denotes an element of the vector defining H(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SLATRDK( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDW, N, NB +* .. +* .. Array Arguments .. + REAL A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, HALF = 0.5E+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IW + REAL ALPHA +* .. +* .. External Subroutines .. + EXTERNAL SAXPY, SGEMV, SLARFG, SSCAL, SSYMV +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SDOT + EXTERNAL LSAME, SDOT +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Reduce last NB columns of upper triangle +* + DO 10 I = N, N - NB + 1, -1 + IW = I - N + NB + IF( I.LT.N ) THEN +* +* Update A(1:i,i) +* + CALL SGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), + $ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 ) + CALL SGEMV( 'No transpose', I-1, N-I, -ONE, W( 1, + $ IW+1 ), + $ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 ) + END IF + IF( I.GT.1 ) THEN +* +* Generate elementary reflector H(i) to annihilate +* A(1:i-2,i) +* + CALL SLARFG( I-1, A( I-1, I ), A( 1, I ), 1, + $ TAU( I-1 ) ) + E( I-1 ) = A( I-1, I ) + A( I-1, I ) = ONE +* +* Compute W(1:i-1,i) +* + CALL SKYMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1, + $ ZERO, W( 1, IW ), 1 ) + IF( I.LT.N ) THEN + CALL SGEMV( 'Transpose', I-1, N-I, ONE, W( 1, + $ IW+1 ), + $ LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) + CALL SGEMV( 'No transpose', I-1, N-I, ONE, + $ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE, + $ W( 1, IW ), 1 ) + CALL SGEMV( 'Transpose', I-1, N-I, ONE, A( 1, + $ I+1 ), + $ LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) + CALL SGEMV( 'No transpose', I-1, N-I, -ONE, + $ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE, + $ W( 1, IW ), 1 ) + END IF + CALL SSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 ) + END IF +* + 10 CONTINUE + ELSE +* +* Reduce first NB columns of lower triangle +* + DO 20 I = 1, NB +* +* Update A(i:n,i) +* + CALL SGEMV( 'No transpose', N-I, I-1, ONE, A( I+1, 1 ), + $ LDA, W( I, 1 ), LDW, ONE, A( I+1, I ), 1 ) + CALL SGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ), + $ LDW, A( I, 1 ), LDA, ONE, A( I+1, I ), 1 ) + IF( I.LT.N ) THEN +* +* Generate elementary reflector H(i) to annihilate +* A(i+2:n,i) +* + CALL SLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, + $ TAU( I ) ) + E( I ) = A( I+1, I ) + A( I+1, I ) = ONE +* +* Compute W(i+1:n,i) +* + CALL SKYMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA, + $ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 ) + CALL SGEMV( 'Transpose', N-I, I-1, ONE, W( I+1, 1 ), + $ LDW, + $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) + CALL SGEMV( 'No transpose', N-I, I-1, ONE, A( I+1, + $ 1 ), + $ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) + CALL SGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), + $ LDA, + $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) + CALL SGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, + $ 1 ), + $ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) + CALL SSCAL( N-I, TAU( I ), W( I+1, I ), 1 ) + END IF +* + 20 CONTINUE + END IF +* + RETURN +* +* End of SLATRDK +* + END diff --git a/TESTING/CMakeLists.txt b/TESTING/CMakeLists.txt index f9c2482fc..1c2408d2e 100644 --- a/TESTING/CMakeLists.txt +++ b/TESTING/CMakeLists.txt @@ -56,6 +56,7 @@ add_lapack_test(stest_rfp.out stest_rfp.in xlintstrfs) # ======== SINGLE EIG TESTS =========================== add_lapack_test(snep.out nep.in xeigtsts) add_lapack_test(ssep.out sep.in xeigtsts) +add_lapack_test(skep.out kep.in xeigtsts) add_lapack_test(sse2.out se2.in xeigtsts) add_lapack_test(ssvd.out svd.in xeigtsts) add_lapack_test(sec.out sec.in xeigtsts) @@ -64,6 +65,7 @@ add_lapack_test(sgg.out sgg.in xeigtsts) add_lapack_test(sgd.out sgd.in xeigtsts) add_lapack_test(ssb.out ssb.in xeigtsts) add_lapack_test(ssg.out ssg.in xeigtsts) +add_lapack_test(skg.out skg.in xeigtsts) add_lapack_test(sbal.out sbal.in xeigtsts) add_lapack_test(sbak.out sbak.in xeigtsts) add_lapack_test(sgbal.out sgbal.in xeigtsts) @@ -90,6 +92,7 @@ add_lapack_test(dtest_rfp.out dtest_rfp.in xlintstrfd) # ======== DOUBLE EIG TESTS =========================== add_lapack_test(dnep.out nep.in xeigtstd) add_lapack_test(dsep.out sep.in xeigtstd) +add_lapack_test(dkep.out kep.in xeigtstd) add_lapack_test(dse2.out se2.in xeigtstd) add_lapack_test(dsvd.out svd.in xeigtstd) add_lapack_test(dec.out dec.in xeigtstd) @@ -98,6 +101,7 @@ add_lapack_test(dgg.out dgg.in xeigtstd) add_lapack_test(dgd.out dgd.in xeigtstd) add_lapack_test(dsb.out dsb.in xeigtstd) add_lapack_test(dsg.out dsg.in xeigtstd) +add_lapack_test(dkg.out dkg.in xeigtstd) add_lapack_test(dbal.out dbal.in xeigtstd) add_lapack_test(dbak.out dbak.in xeigtstd) add_lapack_test(dgbal.out dgbal.in xeigtstd) diff --git a/TESTING/EIG/CMakeLists.txt b/TESTING/EIG/CMakeLists.txt index d99762d43..99517bd58 100644 --- a/TESTING/EIG/CMakeLists.txt +++ b/TESTING/EIG/CMakeLists.txt @@ -28,19 +28,19 @@ set(SCIGTST slafts.f slahd2.f slasum.f slatb9.f sstech.f sstect.f set(SEIGTST schkee.F sbdt01.f sbdt02.f sbdt03.f sbdt04.f sbdt05.f schkbb.f schkbd.f schkbk.f schkbl.f schkec.f - schkgg.f schkgk.f schkgl.f schkhs.f schksb.f schkst.f schkst2stg.f schksb2stg.f + schkgg.f schkgk.f schkgl.f schkhs.f schksb.f schkst.f schkkt.f schkst2stg.f schksb2stg.f sckcsd.f sckglm.f sckgqr.f sckgsv.f scklse.f scsdts.f sdrges.f sdrgev.f sdrges3.f sdrgev3.f sdrgsx.f sdrgvx.f - sdrvbd.f sdrves.f sdrvev.f sdrvsg.f sdrvsg2stg.f - sdrvst.f sdrvst2stg.f sdrvsx.f sdrvvx.f - serrbd.f serrec.f serred.f serrgg.f serrhs.f serrst.f + sdrvbd.f sdrves.f sdrvev.f sdrvsg.f sdrvsg2stg.f sdrvkg2stg.f + sdrvst.f sdrvkt.f sdrvst2stg.f sdrvsx.f sdrvvx.f + serrbd.f serrec.f serred.f serrgg.f serrhs.f serrst.f serrkt.f sget02.f sget10.f sget22.f sget23.f sget24.f sget31.f sget32.f sget33.f sget34.f sget35.f sget36.f sget37.f sget38.f sget39.f sget40.f sget51.f sget52.f sget53.f sget54.f sglmts.f sgqrts.f sgrqts.f sgsvts3.f - shst01.f slarfy.f slarhs.f slatm4.f slctes.f slctsx.f slsets.f sort01.f - sort03.f ssbt21.f ssgt01.f sslect.f sspt21.f sstt21.f - sstt22.f ssyl01.f ssyt21.f ssyt22.f) + shst01.f slarfy.f slarfyk.f slarhs.f slatm4.f slctes.f slctsx.f slsets.f sort01.f + sort03.f ssbt21.f ssgt01.f skgt01.f sslect.f sspt21.f sstt21.f sktt21.f + sstt22.f ssyl01.f ssyt21.f skyt21.f ssyt22.f) set(SDMDEIGTST schkdmd.f90) @@ -69,19 +69,19 @@ set(DZIGTST dlafts.f dlahd2.f dlasum.f dlatb9.f dstech.f dstect.f set(DEIGTST dchkee.F dbdt01.f dbdt02.f dbdt03.f dbdt04.f dbdt05.f dchkbb.f dchkbd.f dchkbk.f dchkbl.f dchkec.f - dchkgg.f dchkgk.f dchkgl.f dchkhs.f dchksb.f dchkst.f dchkst2stg.f dchksb2stg.f + dchkgg.f dchkgk.f dchkgl.f dchkhs.f dchksb.f dchkst.f dchkkt.f dchkst2stg.f dchksb2stg.f dckcsd.f dckglm.f dckgqr.f dckgsv.f dcklse.f dcsdts.f ddrges.f ddrgev.f ddrges3.f ddrgev3.f ddrgsx.f ddrgvx.f - ddrvbd.f ddrves.f ddrvev.f ddrvsg.f ddrvsg2stg.f - ddrvst.f ddrvst2stg.f ddrvsx.f ddrvvx.f - derrbd.f derrec.f derred.f derrgg.f derrhs.f derrst.f + ddrvbd.f ddrves.f ddrvev.f ddrvsg.f ddrvsg2stg.f ddrvkg2stg.f + ddrvst.f ddrvkt.f ddrvst2stg.f ddrvsx.f ddrvvx.f + derrbd.f derrec.f derred.f derrgg.f derrhs.f derrst.f derrkt.f dget02.f dget10.f dget22.f dget23.f dget24.f dget31.f dget32.f dget33.f dget34.f dget35.f dget36.f dget37.f dget38.f dget39.f dget40.f dget51.f dget52.f dget53.f dget54.f dglmts.f dgqrts.f dgrqts.f dgsvts3.f - dhst01.f dlarfy.f dlarhs.f dlatm4.f dlctes.f dlctsx.f dlsets.f dort01.f - dort03.f dsbt21.f dsgt01.f dslect.f dspt21.f dstt21.f - dstt22.f dsyl01.f dsyt21.f dsyt22.f) + dhst01.f dlarfy.f dlarfyk.f dlarhs.f dlatm4.f dlctes.f dlctsx.f dlsets.f dort01.f + dort03.f dsbt21.f dsgt01.f dkgt01.f dslect.f dspt21.f dstt21.f dktt21.f + dstt22.f dsyl01.f dsyt21.f dkyt21.f dsyt22.f) set(DDMDEIGTST dchkdmd.f90) diff --git a/TESTING/EIG/Makefile b/TESTING/EIG/Makefile index 5de315b6e..954de45b6 100644 --- a/TESTING/EIG/Makefile +++ b/TESTING/EIG/Makefile @@ -50,19 +50,19 @@ SCIGTST = slafts.o slahd2.o slasum.o slatb9.o sstech.o sstect.o \ SEIGTST = schkee.o \ sbdt01.o sbdt02.o sbdt03.o sbdt04.o sbdt05.o \ schkbb.o schkbd.o schkbk.o schkbl.o schkec.o \ - schkgg.o schkgk.o schkgl.o schkhs.o schksb.o schkst.o schkst2stg.o schksb2stg.o \ + schkgg.o schkgk.o schkgl.o schkhs.o schksb.o schkst.o schkkt.o schkst2stg.o schksb2stg.o \ sckcsd.o sckglm.o sckgqr.o sckgsv.o scklse.o scsdts.o \ sdrges.o sdrgev.o sdrges3.o sdrgev3.o sdrgsx.o sdrgvx.o \ - sdrvbd.o sdrves.o sdrvev.o sdrvsg.o sdrvsg2stg.o \ - sdrvst.o sdrvst2stg.o sdrvsx.o sdrvvx.o \ - serrbd.o serrec.o serred.o serrgg.o serrhs.o serrst.o \ + sdrvbd.o sdrves.o sdrvev.o sdrvsg.o sdrvsg2stg.o sdrvkg2stg.o \ + sdrvst.o sdrvkt.o sdrvst2stg.o sdrvsx.o sdrvvx.o \ + serrbd.o serrec.o serred.o serrgg.o serrhs.o serrst.o serrkt.o \ sget02.o sget10.o sget22.o sget23.o sget24.o sget31.o \ sget32.o sget33.o sget34.o sget35.o sget36.o \ sget37.o sget38.o sget39.o sget40.o sget51.o sget52.o sget53.o \ sget54.o sglmts.o sgqrts.o sgrqts.o sgsvts3.o \ - shst01.o slarfy.o slarhs.o slatm4.o slctes.o slctsx.o slsets.o sort01.o \ - sort03.o ssbt21.o ssgt01.o sslect.o sspt21.o sstt21.o \ - sstt22.o ssyl01.o ssyt21.o ssyt22.o + shst01.o slarfy.o slarfyk.o slarhs.o slatm4.o slctes.o slctsx.o slsets.o sort01.o \ + sort03.o ssbt21.o ssgt01.o skgt01.o sslect.o sspt21.o sstt21.o sktt21.o \ + sstt22.o ssyl01.o ssyt21.o skyt21.o ssyt22.o SDMDEIGTST = schkdmd.o @@ -91,19 +91,19 @@ DZIGTST = dlafts.o dlahd2.o dlasum.o dlatb9.o dstech.o dstect.o \ DEIGTST = dchkee.o \ dbdt01.o dbdt02.o dbdt03.o dbdt04.o dbdt05.o \ dchkbb.o dchkbd.o dchkbk.o dchkbl.o dchkec.o \ - dchkgg.o dchkgk.o dchkgl.o dchkhs.o dchksb.o dchkst.o dchkst2stg.o dchksb2stg.o \ + dchkgg.o dchkgk.o dchkgl.o dchkhs.o dchksb.o dchkst.o dchkkt.o dchkst2stg.o dchksb2stg.o \ dckcsd.o dckglm.o dckgqr.o dckgsv.o dcklse.o dcsdts.o \ ddrges.o ddrgev.o ddrges3.o ddrgev3.o ddrgsx.o ddrgvx.o \ - ddrvbd.o ddrves.o ddrvev.o ddrvsg.o ddrvsg2stg.o \ - ddrvst.o ddrvst2stg.o ddrvsx.o ddrvvx.o \ - derrbd.o derrec.o derred.o derrgg.o derrhs.o derrst.o \ + ddrvbd.o ddrves.o ddrvev.o ddrvsg.o ddrvsg2stg.o ddrvkg2stg.o \ + ddrvst.o ddrvkt.o ddrvst2stg.o ddrvsx.o ddrvvx.o \ + derrbd.o derrec.o derred.o derrgg.o derrhs.o derrst.o derrkt.o \ dget02.o dget10.o dget22.o dget23.o dget24.o dget31.o \ dget32.o dget33.o dget34.o dget35.o dget36.o \ dget37.o dget38.o dget39.o dget40.o dget51.o dget52.o dget53.o \ dget54.o dglmts.o dgqrts.o dgrqts.o dgsvts3.o \ - dhst01.o dlarfy.o dlarhs.o dlatm4.o dlctes.o dlctsx.o dlsets.o dort01.o \ - dort03.o dsbt21.o dsgt01.o dslect.o dspt21.o dstt21.o \ - dstt22.o dsyl01.o dsyt21.o dsyt22.o + dhst01.o dlarfy.o dlarfyk.o dlarhs.o dlatm4.o dlctes.o dlctsx.o dlsets.o dort01.o \ + dort03.o dsbt21.o dsgt01.o dkgt01.o dslect.o dspt21.o dstt21.o dktt21.o \ + dstt22.o dsyl01.o dsyt21.o dkyt21.o dsyt22.o DDMDEIGTST = dchkdmd.o diff --git a/TESTING/EIG/dchkee.F b/TESTING/EIG/dchkee.F index 2b8e0b371..ddf6ec6be 100644 --- a/TESTING/EIG/dchkee.F +++ b/TESTING/EIG/dchkee.F @@ -27,6 +27,9 @@ *> and drivers DSYEV(X), DSBEV(X), DSPEV(X), DSTEV(X), *> DSYEVD, DSBEVD, DSPEVD, DSTEVD *> +*> KEP (Skew-symmetric Eigenvalue Problem): +*> Test DKYTRD, DSTEQR, and driver DSYEV, DSTEV +*> *> SVD (Singular Value Decomposition): *> Test DGEBRD, DORGBR, DBDSQR, DBDSDC *> and the drivers DGESVD, DGESDD @@ -62,6 +65,9 @@ *> Test DSYGST, DSYGV, DSYGVD, DSYGVX, DSPGST, DSPGV, DSPGVD, *> DSPGVX, DSBGST, DSBGV, DSBGVD, and DSBGVX *> +*> DKG (Skew-symmetric Generalized Eigenvalue Problem): +*> Test DKYGST, DKYGV +*> *> DSB (Symmetric Band Eigenvalue Problem): *> Test DSBTRD *> @@ -114,6 +120,8 @@ *> DHS or NEP 21 DCHKHS *> DST or SEP 21 DCHKST (routines) *> 18 DDRVST (drivers) +*> DKT or KEP 21 DCHKKT (routines) +*> 18 DDRVKT (drivers) *> DBD or SVD 16 DCHKBD (routines) *> 5 DDRVBD (drivers) *> DEV 21 DDRVEV @@ -126,6 +134,7 @@ *> DGV 26 DDRGEV *> DXV 2 DDRGVX *> DSG 21 DDRVSG +*> DKG 21 DDRVKG *> DSB 15 DCHKSB *> DBB 15 DCHKBB *> DEC - DCHKEC @@ -215,7 +224,7 @@ *> *>----------------------------------------------------------------------- *> -*> SEP or DSG input file: +*> SEP, KEP, DSG or DKG input file: *> *> line 2: NN, INTEGER *> Number of values of N. @@ -263,9 +272,9 @@ *> Four integer values for the random number seed. *> *> lines 13-EOF: Lines specifying matrix types, as for NEP. -*> The 3-character path names are 'SEP' or 'SST' for the -*> symmetric eigenvalue routines and driver routines, and -*> 'DSG' for the routines for the symmetric generalized +*> The 3-character path names are 'SEP', 'KEP', 'DST' or 'DKT' for +*> the (skew-)symmetric eigenvalue routines and driver routines, and +*> 'DSG', 'DKG' for the routines for the (skew-)symmetric generalized *> eigenvalue problem. *> *>----------------------------------------------------------------------- @@ -1068,9 +1077,9 @@ PROGRAM DCHKEE * .. * .. Local Scalars .. LOGICAL CSD, DBB, DGG, DSB, FATAL, GLM, GQR, GSV, LSE, - $ NEP, DBK, DBL, SEP, DES, DEV, DGK, DGL, DGS, - $ DGV, DGX, DSX, SVD, DVX, DXV, TSTCHK, TSTDIF, - $ TSTDRV, TSTERR + $ NEP, DBK, DBL, SEP, KEP, DES, DEV, DGK, DGL, + $ DGS, DGV, DGX, DSX, SVD, DVX, DXV, TSTCHK, + $ TSTDIF, TSTDRV, TSTERR CHARACTER C1 CHARACTER*3 C3, PATH CHARACTER*32 VNAME @@ -1111,7 +1120,7 @@ PROGRAM DCHKEE $ DDRGEV, DDRGSX, DDRGVX, DDRVBD, DDRVES, DDRVEV, $ DDRVSG, DDRVST, DDRVSX, DDRVVX, DERRBD, $ DERRED, DERRGG, DERRHS, DERRST, ILAVER, XLAENV, - $ DDRGES3, DDRGEV3, + $ DDRGES3, DDRGEV3, DERRKT, DCHKKT, DDRVKT, $ DCHKST2STG, DDRVST2STG, DCHKSB2STG, DDRVSG2STG * .. * .. Intrinsic Functions .. @@ -1171,6 +1180,8 @@ PROGRAM DCHKEE NEP = LSAMEN( 3, PATH, 'NEP' ) .OR. LSAMEN( 3, PATH, 'DHS' ) SEP = LSAMEN( 3, PATH, 'SEP' ) .OR. LSAMEN( 3, PATH, 'DST' ) .OR. $ LSAMEN( 3, PATH, 'DSG' ) .OR. LSAMEN( 3, PATH, 'SE2' ) + KEP = LSAMEN( 3, PATH, 'KEP' ) .OR. LSAMEN( 3, PATH, 'DKT' ) .OR. + $ LSAMEN( 3, PATH, 'DKG' ) SVD = LSAMEN( 3, PATH, 'SVD' ) .OR. LSAMEN( 3, PATH, 'DBD' ) DEV = LSAMEN( 3, PATH, 'DEV' ) DES = LSAMEN( 3, PATH, 'DES' ) @@ -1201,6 +1212,8 @@ PROGRAM DCHKEE WRITE( NOUT, FMT = 9987 ) ELSE IF( SEP ) THEN WRITE( NOUT, FMT = 9986 ) + ELSE IF( KEP ) THEN + WRITE( NOUT, FMT = 9959 ) ELSE IF( SVD ) THEN WRITE( NOUT, FMT = 9985 ) ELSE IF( DEV ) THEN @@ -1492,7 +1505,7 @@ PROGRAM DCHKEE * * Read the values of NBMIN * - IF( NEP .OR. SEP .OR. SVD .OR. DGG ) THEN + IF( NEP .OR. SEP .OR. KEP .OR. SVD .OR. DGG ) THEN READ( NIN, FMT = * )( NBMIN( I ), I = 1, NPARMS ) DO 80 I = 1, NPARMS IF( NBMIN( I ).LT.0 ) THEN @@ -1513,7 +1526,7 @@ PROGRAM DCHKEE * * Read the values of NX * - IF( NEP .OR. SEP .OR. SVD ) THEN + IF( NEP .OR. SEP .OR. KEP .OR. SVD ) THEN READ( NIN, FMT = * )( NXVAL( I ), I = 1, NPARMS ) DO 100 I = 1, NPARMS IF( NXVAL( I ).LT.0 ) THEN @@ -1701,7 +1714,7 @@ PROGRAM DCHKEE * READ( NIN, FMT = * )THRESH WRITE( NOUT, FMT = 9982 )THRESH - IF( SEP .OR. SVD .OR. DGG ) THEN + IF( SEP .OR. KEP .OR. SVD .OR. DGG ) THEN * * Read the flag that indicates whether to test LAPACK routines. * @@ -1936,6 +1949,67 @@ PROGRAM DCHKEE $ WRITE( NOUT, FMT = 9980 )'DDRVST', INFO END IF 290 CONTINUE +* + ELSE IF( LSAMEN( 3, C3, 'DKT' ) .OR. LSAMEN( 3, C3, 'KEP' ) ) THEN +* +* ---------------------------------- +* KEP: Skew-symmetric Eigenvalue Problem +* ---------------------------------- +* Vary the parameters +* NB = block size +* NBMIN = minimum block size +* NX = crossover point +* + MAXTYP = 21 + NTYPES = MIN( MAXTYP, NTYPES ) + CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT ) + CALL XLAENV( 1, 1 ) + CALL XLAENV( 9, 25 ) + IF( TSTERR ) THEN +#if defined(_OPENMP) + N_THREADS = OMP_GET_MAX_THREADS() + ONE_THREAD = 1 + CALL OMP_SET_NUM_THREADS(ONE_THREAD) +#endif + CALL DERRKT( 'DKT', NOUT ) +#if defined(_OPENMP) + CALL OMP_SET_NUM_THREADS(N_THREADS) +#endif + END IF + DO 400 I = 1, NPARMS + CALL XLAENV( 1, NBVAL( I ) ) + CALL XLAENV( 2, NBMIN( I ) ) + CALL XLAENV( 3, NXVAL( I ) ) +* + IF( NEWSD.EQ.0 ) THEN + DO 390 K = 1, 4 + ISEED( K ) = IOLDSD( K ) + 390 CONTINUE + END IF + WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ), + $ NXVAL( I ) + IF( TSTCHK ) THEN + CALL DCHKKT( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), D( 1, 1 ), + $ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), D( 1, 5 ), + $ D( 1, 6 ), D( 1, 7 ), D( 1, 8 ), D( 1, 9 ), + $ D( 1, 10 ), D( 1, 11 ), A( 1, 3 ), NMAX, + $ A( 1, 4 ), A( 1, 5 ), D( 1, 12 ), A( 1, 6 ), + $ WORK, LWORK, IWORK, LIWORK, RESULT, INFO ) + IF( INFO.NE.0 ) + $ WRITE( NOUT, FMT = 9980 )'DCHKKT', INFO + END IF + IF( TSTDRV ) THEN + CALL DDRVKT( NN, NVAL, 18, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, D( 1, 3 ), D( 1, 4 ), + $ D( 1, 5 ), D( 1, 6 ), D( 1, 8 ), D( 1, 9 ), + $ D( 1, 10 ), D( 1, 11), A( 1, 2 ), NMAX, + $ A( 1, 3 ), D( 1, 12 ), A( 1, 4 ), WORK, + $ LWORK, IWORK, LIWORK, RESULT, INFO ) + IF( INFO.NE.0 ) + $ WRITE( NOUT, FMT = 9980 )'DDRVKT', INFO + END IF + 400 CONTINUE * ELSE IF( LSAMEN( 3, C3, 'DSG' ) ) THEN * @@ -1979,6 +2053,49 @@ PROGRAM DCHKEE $ WRITE( NOUT, FMT = 9980 )'DDRVSG', INFO END IF 310 CONTINUE +* + ELSE IF( LSAMEN( 3, C3, 'DKG' ) ) THEN +* +* ---------------------------------------------- +* DKG: Skew-symmetric Generalized Eigenvalue Problem +* ---------------------------------------------- +* Vary the parameters +* NB = block size +* NBMIN = minimum block size +* NX = crossover point +* + MAXTYP = 21 + NTYPES = MIN( MAXTYP, NTYPES ) + CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT ) + CALL XLAENV( 9, 25 ) + DO 420 I = 1, NPARMS + CALL XLAENV( 1, NBVAL( I ) ) + CALL XLAENV( 2, NBMIN( I ) ) + CALL XLAENV( 3, NXVAL( I ) ) +* + IF( NEWSD.EQ.0 ) THEN + DO 410 K = 1, 4 + ISEED( K ) = IOLDSD( K ) + 410 CONTINUE + END IF + WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ), + $ NXVAL( I ) + IF( TSTCHK ) THEN +* CALL DDRVSG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, +* $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, +* $ D( 1, 3 ), A( 1, 3 ), NMAX, A( 1, 4 ), +* $ A( 1, 5 ), A( 1, 6 ), A( 1, 7 ), WORK, +* $ LWORK, IWORK, LIWORK, RESULT, INFO ) + CALL DDRVKG2STG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, + $ D( 1, 3 ), D( 1, 3 ), A( 1, 3 ), NMAX, + $ A( 1, 4 ), A( 1, 5 ), A( 1, 6 ), + $ A( 1, 7 ), WORK, LWORK, IWORK, LIWORK, + $ RESULT, INFO ) + IF( INFO.NE.0 ) + $ WRITE( NOUT, FMT = 9980 )'DDRVSG', INFO + END IF + 420 CONTINUE * ELSE IF( LSAMEN( 3, C3, 'DBD' ) .OR. LSAMEN( 3, C3, 'SVD' ) ) THEN * @@ -2531,6 +2648,8 @@ PROGRAM DCHKEE $ ', INWIN =', I4, ', INIBL =', I4, ', ISHFTS =', I4, $ ', IACC22 =', I4) 9960 FORMAT( / ' Tests of the CS Decomposition routines' ) + 9959 FORMAT( ' Tests of the Skew-symmetric Eigenvalue Problem ', + $ 'routines' ) * * End of DCHKEE * diff --git a/TESTING/EIG/dchkkt.f b/TESTING/EIG/dchkkt.f new file mode 100644 index 000000000..3ac7185b3 --- /dev/null +++ b/TESTING/EIG/dchkkt.f @@ -0,0 +1,1098 @@ +*> \brief \b DCHKKT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DCHKKT( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, +* WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, +* LWORK, IWORK, LIWORK, RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, +* $ NTYPES +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* DOUBLE PRECISION A( LDA, * ), AP( * ), D1( * ), D2( * ), +* $ D3( * ), D4( * ), D5( * ), RESULT( * ), +* $ SD( * ), SE( * ), TAU( * ), U( LDU, * ), +* $ V( LDU, * ), VP( * ), WA1( * ), WA2( * ), +* $ WA3( * ), WORK( * ), WR( * ), Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DCHKKT checks the skew-symmetric eigenvalue problem routines. +*> +*> DKYTRD factors A as U S U' , where ' means transpose, +*> S is skew-symmetric tridiagonal, and U is orthogonal. +*> DKYTRD can use either just the lower or just the upper triangle +*> of A; DCHKKT checks both cases. +*> U is represented as a product of Householder +*> transformations, whose vectors are stored in the first +*> n-1 columns of V, and whose scale factors are in TAU. +*> +*> DKTEQR factors S as Z D1 Z' , where Z is the orthogonal +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal. D2 is the matrix of +*> eigenvalues computed when Z is not computed. +*> +*> When DCHKKT is called, a number of matrix "sizes" ("n's") and a +*> number of matrix "types" are specified. For each size ("n") +*> and each type of matrix, one matrix will be generated and used +*> to test the skew-symmetric eigenroutines. For each matrix, a +*> number of tests will be performed: +*> +*> (1) | A - V S V' | / ( |A| n ulp ) DKYTRD( UPLO='U', ... ) +*> +*> (2) | I - UV' | / ( n ulp ) DORGTR( UPLO='U', ... ) +*> +*> (3) | A - V S V' | / ( |A| n ulp ) DKYTRD( UPLO='L', ... ) +*> +*> (4) | I - UV' | / ( n ulp ) DORGTR( UPLO='L', ... ) +*> +*> (5-8) Same as 1-4, but for SSPTRD and SOPGTR. +*> +*> (9) | S - Z D Z' | / ( |S| n ulp ) DKTEQR('V',...) +*> +*> (10) | I - ZZ' | / ( n ulp ) DKTEQR('V',...) +*> +*> (11) | D1 - D2 | / ( |D1| ulp ) DKTEQR('N',...) +*> +*> (12) | D1 - D3 | / ( |D1| ulp ) SSTERF +*> +*> (13) 0 if the true eigenvalues (computed by sturm count) +*> of S are within THRESH of +*> those in D1. 2*THRESH if they are not. (Tested using +*> SSTECH) +*> +*> For S positive definite, +*> +*> (14) | S - Z4 D4 Z4' | / ( |S| n ulp ) SPTEQR('V',...) +*> +*> (15) | I - Z4 Z4' | / ( n ulp ) SPTEQR('V',...) +*> +*> (16) | D4 - D5 | / ( 100 |D4| ulp ) SPTEQR('N',...) +*> +*> When S is also diagonally dominant by the factor gamma < 1, +*> +*> (17) max | D4(i) - WR(i) | / ( |D4(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> SSTEBZ( 'A', 'E', ...) +*> +*> (18) | WA1 - D3 | / ( |D3| ulp ) SSTEBZ( 'A', 'E', ...) +*> +*> (19) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> SSTEBZ( 'I', 'E', ...) +*> +*> (20) | S - Y WA1 Y' | / ( |S| n ulp ) SSTEBZ, SSTEIN +*> +*> (21) | I - Y Y' | / ( n ulp ) SSTEBZ, SSTEIN +*> +*> (22) | S - Z D Z' | / ( |S| n ulp ) SSTEDC('I') +*> +*> (23) | I - ZZ' | / ( n ulp ) SSTEDC('I') +*> +*> (24) | S - Z D Z' | / ( |S| n ulp ) SSTEDC('V') +*> +*> (25) | I - ZZ' | / ( n ulp ) SSTEDC('V') +*> +*> (26) | D1 - D2 | / ( |D1| ulp ) SSTEDC('V') and +*> SSTEDC('N') +*> +*> Test 27 is disabled at the moment because SSTEMR does not +*> guarantee high relatvie accuracy. +*> +*> (27) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> SSTEMR('V', 'A') +*> +*> (28) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> SSTEMR('V', 'I') +*> +*> Tests 29 through 34 are disable at present because SSTEMR +*> does not handle partial spectrum requests. +*> +*> (29) | S - Z D Z' | / ( |S| n ulp ) SSTEMR('V', 'I') +*> +*> (30) | I - ZZ' | / ( n ulp ) SSTEMR('V', 'I') +*> +*> (31) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> SSTEMR('N', 'I') vs. SSTEMR('V', 'I') +*> +*> (32) | S - Z D Z' | / ( |S| n ulp ) SSTEMR('V', 'V') +*> +*> (33) | I - ZZ' | / ( n ulp ) SSTEMR('V', 'V') +*> +*> (34) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> SSTEMR('N', 'V') vs. SSTEMR('V', 'V') +*> +*> (35) | S - Z D Z' | / ( |S| n ulp ) SSTEMR('V', 'A') +*> +*> (36) | I - ZZ' | / ( n ulp ) SSTEMR('V', 'A') +*> +*> (37) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> SSTEMR('N', 'A') vs. SSTEMR('V', 'A') +*> +*> The "sizes" are specified by an array NN(1:NSIZES); the value of +*> each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); +*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U' D U, where U is orthogonal and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U' D U, where U is orthogonal and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U' D U, where U is orthogonal and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> (16) Same as (8), but diagonal elements are all positive. +*> (17) Same as (9), but diagonal elements are all positive. +*> (18) Same as (10), but diagonal elements are all positive. +*> (19) Same as (16), but multiplied by SQRT( overflow threshold ) +*> (20) Same as (16), but multiplied by SQRT( underflow threshold ) +*> (21) A diagonally dominant tridiagonal matrix with geometrically +*> spaced diagonal entries 1, ..., ULP. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> DCHKKT does nothing. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. The values must be at least +*> zero. +*> \endverbatim +*> +*> \param[in] NTYPES +*> \verbatim +*> NTYPES is INTEGER +*> The number of elements in DOTYPE. If it is zero, DCHKKT +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> \endverbatim +*> +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> \endverbatim +*> +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to DCHKKT to continue the same random number +*> sequence. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error +*> is scaled to be O(1), so THRESH should be a reasonably +*> small multiple of 1, e.g., 10 or 100. In particular, +*> it should not depend on the precision (single vs. double) +*> or the size of the matrix. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NOUNIT +*> \verbatim +*> NOUNIT is INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array of +*> dimension ( LDA , max(NN) ) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[out] AP +*> \verbatim +*> AP is DOUBLE PRECISION array of +*> dimension( max(NN)*max(NN+1)/2 ) +*> The matrix A stored in packed format. +*> \endverbatim +*> +*> \param[out] SD +*> \verbatim +*> SD is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The diagonal of the tridiagonal matrix computed by DKYTRD. +*> On exit, SD and SE contain the tridiagonal form of the +*> matrix in A. +*> \endverbatim +*> +*> \param[out] SE +*> \verbatim +*> SE is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The off-diagonal of the tridiagonal matrix computed by +*> DKYTRD. On exit, SD and SE contain the tridiagonal form of +*> the matrix in A. +*> \endverbatim +*> +*> \param[out] D1 +*> \verbatim +*> D1 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by DKTEQR simlutaneously +*> with Z. On exit, the eigenvalues in D1 correspond with the +*> matrix in A. +*> \endverbatim +*> +*> \param[out] D2 +*> \verbatim +*> D2 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by DKTEQR if Z is not +*> computed. On exit, the eigenvalues in D2 correspond with +*> the matrix in A. +*> \endverbatim +*> +*> \param[out] D3 +*> \verbatim +*> D3 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by SSTERF. On exit, the +*> eigenvalues in D3 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] D4 +*> \verbatim +*> D4 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by SPTEQR(V). +*> ZPTEQR factors S as Z4 D4 Z4* +*> On exit, the eigenvalues in D4 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] D5 +*> \verbatim +*> D5 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by SPTEQR(N) +*> when Z is not computed. On exit, the +*> eigenvalues in D4 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] WA1 +*> \verbatim +*> WA1 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> All eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by SSTEBZ. +*> \endverbatim +*> +*> \param[out] WA2 +*> \verbatim +*> WA2 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> Selected eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by SSTEBZ. +*> Choose random values for IL and IU, and ask for the +*> IL-th through IU-th eigenvalues. +*> \endverbatim +*> +*> \param[out] WA3 +*> \verbatim +*> WA3 is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> Selected eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by SSTEBZ. +*> Determine the values VL and VU of the IL-th and IU-th +*> eigenvalues and ask for all eigenvalues in this range. +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> All eigenvalues of A, computed to high +*> absolute accuracy, with different options. +*> as computed by SSTEBZ. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is DOUBLE PRECISION array of +*> dimension( LDU, max(NN) ). +*> The orthogonal matrix computed by DKYTRD + DORGTR. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of U, Z, and V. It must be at least 1 +*> and at least max( NN ). +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is DOUBLE PRECISION array of +*> dimension( LDU, max(NN) ). +*> The Housholder vectors computed by DKYTRD in reducing A to +*> tridiagonal form. The vectors computed with UPLO='U' are +*> in the upper triangle, and the vectors computed with UPLO='L' +*> are in the lower triangle. (As described in DKYTRD, the +*> sub- and superdiagonal are not set to 1, although the +*> true Householder vector has a 1 in that position. The +*> routines that use V, such as DORGTR, set those entries to +*> 1 before using them, and then restore them later.) +*> \endverbatim +*> +*> \param[out] VP +*> \verbatim +*> VP is DOUBLE PRECISION array of +*> dimension( max(NN)*max(NN+1)/2 ) +*> The matrix V stored in packed format. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array of +*> dimension( max(NN) ) +*> The Householder factors computed by DKYTRD in reducing A +*> to tridiagonal form. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is DOUBLE PRECISION array of +*> dimension( LDU, max(NN) ). +*> The orthogonal matrix of eigenvectors computed by DKTEQR, +*> SPTEQR, and SSTEIN. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array of +*> dimension( LWORK ) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The number of entries in WORK. This must be at least +*> 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 3 * Nmax**2 +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, +*> Workspace. +*> \endverbatim +*> +*> \param[out] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The number of entries in IWORK. This must be at least +*> 6 + 6*Nmax + 5 * Nmax * lg Nmax +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (26) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid +*> overflow. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -23: LDU < 1 or LDU < NMAX. +*> -29: LWORK too small. +*> If DLATMR, DLATMS, DKYTRD, DORGTR, DKTEQR, DSTERF, +*> or DORMC2 returns an error code, the +*> absolute value of it is returned. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE DOUBLE PRECISION 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NBLOCK Blocksize as returned by ENVIR. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far. +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_eig +* +* ===================================================================== + SUBROUTINE DCHKKT( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, + $ WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, + $ LWORK, IWORK, LIWORK, RESULT, INFO ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, + $ NTYPES + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + DOUBLE PRECISION A( LDA, * ), AP( * ), D1( * ), D2( * ), + $ D3( * ), D4( * ), D5( * ), RESULT( * ), + $ SD( * ), SE( * ), TAU( * ), U( LDU, * ), + $ V( LDU, * ), VP( * ), WA1( * ), WA2( * ), + $ WA3( * ), WORK( * ), WR( * ), Z( LDU, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, EIGHT, TEN, HUN + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ EIGHT = 8.0D0, TEN = 10.0D0, HUN = 100.0D0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = ONE / TWO ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 21 ) + LOGICAL SRANGE + PARAMETER ( SRANGE = .FALSE. ) + LOGICAL SREL + PARAMETER ( SREL = .FALSE. ) +* .. +* .. Local Scalars .. + LOGICAL BADNN, TRYRAC + INTEGER I, IINFO, IL, IMODE, ITEMP, ITYPE, IU, J, JC, + $ JR, JSIZE, JTYPE, LGN, LIWEDC, LOG2UI, LWEDC, + $ M, M2, M3, MTYPES, N, NAP, NBLOCK, NERRS, + $ NMATS, NMAX, NSPLIT, NTEST, NTESTT + DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, TEMP1, TEMP2, TEMP3, TEMP4, ULP, + $ ULPINV, UNFL, VL, VU +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) + DOUBLE PRECISION DUMMA( 1 ) +* .. +* .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DLAMCH + EXTERNAL ILAENV, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLABAD, DLACPY, DLASET, DLASUM, DLATMR, + $ DLATMS, DORGTR, DKTEQR, DKTT21, DKYT21, + $ DKYTRD, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, INT, LOG, MAX, MIN, DBLE, + $ SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8, + $ 8, 8, 9, 9, 9, 9, 9, 10 / + DATA KMAGN / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 1, 1, 1, 2, 3, 1 / + DATA KMODE / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 4, 3, 1, 4, 4, 3 / +* .. +* .. Executable Statements .. +* +* Keep ftnchek happy + IDUMMA( 1 ) = 1 +* +* Check for errors +* + NTESTT = 0 + INFO = 0 +* +* Important constants +* + BADNN = .FALSE. + TRYRAC = .TRUE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + NBLOCK = ILAENV( 1, 'DKYTRD', 'L', NMAX, -1, -1, -1 ) + NBLOCK = MIN( NMAX, MAX( 1, NBLOCK ) ) +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -23 + ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN + INFO = -29 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DCHKKT', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) + ULPINV = ONE / ULP + LOG2UI = INT( LOG( ULPINV ) / LOG( TWO ) ) + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + 20 CONTINUE + NERRS = 0 + NMATS = 0 +* + DO 310 JSIZE = 1, NSIZES + N = NN( JSIZE ) + IF( N.GT.0 ) THEN + LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) ) + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + LWEDC = 1 + 4*N + 2*N*LGN + 4*N**2 + LIWEDC = 6 + 6*N + 5*N*LGN + ELSE + LWEDC = 8 + LIWEDC = 12 + END IF + NAP = ( N*( N+1 ) ) / 2 + ANINV = ONE / DBLE( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 300 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 300 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log symmetric, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random symmetric +* =9 positive definite +* =10 diagonally dominant tridiagonal +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 100 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + IINFO = 0 + IF( JTYPE.LE.15 ) THEN + COND = ULPINV + ELSE + COND = ULPINV*ANINV / TEN + END IF +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JC = 1, N + A( JC, JC ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* tridiagonal Matrix, [Eigen]values Specified +* + CALL DLATMS( N, N, 'S', ISEED, 'K', WORK, IMODE, COND, + $ ANORM, 1, 1, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* skew-ymmetric, eigenvalues specified +* + CALL DLATMS( N, N, 'S', ISEED, 'K', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* tridiagonal, random eigenvalues +* + CALL DLATMR( N, N, 'S', ISEED, 'K', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 1, 1, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* skew-ymmetric, random eigenvalues +* + CALL DLATMR( N, N, 'S', ISEED, 'K', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* skew-ymmetric, eigenvalues specified. +* + CALL DLATMS( N, N, 'S', ISEED, 'K', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.10 ) THEN +* +* skew-ymmetric tridiagonal, eigenvalues specified. +* + CALL DLATMS( N, N, 'S', ISEED, 'K', WORK, IMODE, COND, + $ ANORM, 1, 1, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) + DO 90 I = 2, N + TEMP1 = ABS( A( I-1, I ) ) / + $ SQRT( ABS( A( I-1, I-1 )*A( I, I ) ) ) + IF( TEMP1.GT.HALF ) THEN + A( I-1, I ) = HALF*SQRT( ABS( A( I-1, I-1 )*A( I, + $ I ) ) ) + A( I, I-1 ) = A( I-1, I ) + END IF + 90 CONTINUE +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 100 CONTINUE +* +* Call DKYTRD and DORGTR to compute S and U from +* upper triangle. +* + CALL DLACPY( 'U', N, N, A, LDA, V, LDU ) +* + NTEST = 1 + CALL DKYTRD( 'U', N, V, LDU, SE, TAU, WORK, LWORK, + $ IINFO ) + CALL DLASET( 'N', N, 1, ZERO, ZERO, SD, N) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DKYTRD(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL DLACPY( 'U', N, N, V, LDU, U, LDU ) +* + NTEST = 2 + CALL DORGTR( 'U', N, U, LDU, TAU, WORK, LWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DORGTR(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 2 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 1 and 2 +* + CALL DKYT21( 2, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RESULT( 1 ) ) + CALL DKYT21( 3, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RESULT( 2 ) ) +* +* Call DKYTRD and DORGTR to compute S and U from +* lower triangle, do tests. +* + CALL DLACPY( 'L', N, N, A, LDA, V, LDU ) +* + NTEST = 3 + CALL DKYTRD( 'L', N, V, LDU, SE, TAU, WORK, LWORK, + $ IINFO ) + CALL DLASET( 'N', N, 1, ZERO, ZERO, SD, N) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DKYTRD(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL DLACPY( 'L', N, N, V, LDU, U, LDU ) +* + NTEST = 4 + CALL DORGTR( 'L', N, U, LDU, TAU, WORK, LWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DORGTR(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 4 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 3 and 4 +* + CALL DKYT21( 2, 'Lower', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RESULT( 3 ) ) + CALL DKYT21( 3, 'Lower', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RESULT( 4 ) ) +* +* Call DKTEQR to compute D1, D2, and Z, do tests. +* +* Compute D1 and Z +* + CALL DCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 5 + CALL DKTEQR( 'V', N, WORK, Z, LDU, WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DKTEQR(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 280 + END IF + END IF + IF( N.GT.0 ) + $ CALL DCOPY( N-1, WORK, 1, D1, 1 ) +* +* Compute D2 +* + CALL DCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 7 + CALL DKTEQR( 'N', N, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DKTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 6 ) = ULPINV + GO TO 280 + END IF + END IF + IF( N.GT.0 ) + $ CALL DCOPY( N-1, WORK, 1, D2, 1 ) +* +* Do Tests 5 and 6 +* + CALL DKTT21( N, 1, DUMMA, SE, DUMMA, D1, Z, LDU, WORK, + $ RESULT( 5 ) ) +* +* Do Tests 7 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 150 J = 1, N-1 + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 150 CONTINUE +* + RESULT( 7 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* + 280 CONTINUE + NTESTT = NTESTT + NTEST +* +* End of Loop -- Check for RESULT(j) > THRESH +* +* +* Print out tests which fail. +* + DO 290 JR = 1, NTEST + IF( RESULT( JR ).GE.THRESH ) THEN +* +* If this is the first test to fail, +* print a header to the data file. +* + IF( NERRS.EQ.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'SKT' + WRITE( NOUNIT, FMT = 9997 ) + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 )'Skew-symmetric' + WRITE( NOUNIT, FMT = 9994 ) +* +* Tests performed +* + WRITE( NOUNIT, FMT = 9988 ) + END IF + NERRS = NERRS + 1 + WRITE( NOUNIT, FMT = 9990 )N, IOLDSD, JTYPE, JR, + $ RESULT( JR ) + END IF + 290 CONTINUE + 300 CONTINUE + 310 CONTINUE +* +* Summary +* + CALL DLASUM( 'DKT', NOUNIT, NERRS, NTESTT ) + RETURN +* + 9999 FORMAT( ' DCHKKT: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', + $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* + 9998 FORMAT( / 1X, A3, ' -- DOUBLE PRECISION Skew-symmetric', + $ / 'eigenvalue problem' ) + 9997 FORMAT( ' Matrix types (see DCHKKT for details): ' ) +* + 9996 FORMAT( / ' Special Matrices:', + $ / ' 1=Zero matrix. ', + $ ' 5=Diagonal: clustered entries.', + $ / ' 2=Identity matrix. ', + $ ' 6=Diagonal: large, evenly spaced.', + $ / ' 3=Diagonal: evenly spaced entries. ', + $ ' 7=Diagonal: small, evenly spaced.', + $ / ' 4=Diagonal: geometr. spaced entries.' ) + 9995 FORMAT( ' Dense ', A, ' Matrices:', + $ / ' 8=Evenly spaced eigenvals. ', + $ ' 12=Small, evenly spaced eigenvals.', + $ / ' 9=Geometrically spaced eigenvals. ', + $ ' 13=Matrix with random O(1) entries.', + $ / ' 10=Clustered eigenvalues. ', + $ ' 14=Matrix with large random entries.', + $ / ' 11=Large, evenly spaced eigenvals. ', + $ ' 15=Matrix with small random entries.' ) + 9994 FORMAT( ' 16=Positive definite, evenly spaced eigenvalues', + $ / ' 17=Positive definite, geometrically spaced eigenvlaues', + $ / ' 18=Positive definite, clustered eigenvalues', + $ / ' 19=Positive definite, small evenly spaced eigenvalues', + $ / ' 20=Positive definite, large evenly spaced eigenvalues', + $ / ' 21=Diagonally dominant tridiagonal, geometrically', + $ ' spaced eigenvalues' ) +* + 9990 FORMAT( ' N=', I5, ', seed=', 4( I4, ',' ), ' type ', I2, + $ ', test(', I2, ')=', G10.3 ) +* + 9988 FORMAT( / 'Test performed: see DCHKKT for details.', / ) +* End of DCHKKT +* + END diff --git a/TESTING/EIG/ddrvkg2stg.f b/TESTING/EIG/ddrvkg2stg.f new file mode 100644 index 000000000..ff7b2b4ac --- /dev/null +++ b/TESTING/EIG/ddrvkg2stg.f @@ -0,0 +1,705 @@ +*> \brief \b DDRVKG2STG +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DDRVKG2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, B, LDB, D, D2, Z, LDZ, AB, +* BB, AP, BP, WORK, NWORK, IWORK, LIWORK, +* RESULT, INFO ) +* +* IMPLICIT NONE +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDZ, LIWORK, NOUNIT, NSIZES, +* $ NTYPES, NWORK +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* DOUBLE PRECISION A( LDA, * ), AB( LDA, * ), AP( * ), +* $ B( LDB, * ), BB( LDB, * ), BP( * ), D( * ), +* $ RESULT( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DDRVKG2STG checks the DOUBLE PRECISION skew-symmetric generalized eigenproblem +*> drivers. +*> +*> DKYGV computes all eigenvalues and, optionally, +*> eigenvectors of a DOUBLE PRECISION skew-symmetric-definite generalized +*> eigenproblem. +*> +*> When DDRVKG2STG is called, a number of matrix "sizes" ("n's") and a +*> number of matrix "types" are specified. For each size ("n") +*> and each type of matrix, one matrix A of the given type will be +*> generated; a random well-conditioned matrix B is also generated +*> and the pair (A,B) is used to test the drivers. +*> +*> For each pair (A,B), the following tests are performed: +*> +*> (1) DKYGV with ITYPE = 1 and UPLO ='U': +*> +*> | A Z - B Z D | / ( |A| |Z| n ulp ) +*> | D - D2 | / ( |D| ulp ) where D is computed by +*> DKYGV and D2 is computed by +*> DKYGV_2STAGE. This test is +*> only performed for DKYGV +*> +*> (2) as (1) but calling SSPGV +*> (3) as (1) but calling SSBGV +*> (4) as (1) but with UPLO = 'L' +*> (5) as (4) but calling SSPGV +*> (6) as (4) but calling SSBGV +*> +*> (7) DKYGV with ITYPE = 2 and UPLO ='U': +*> +*> | A B Z - Z D | / ( |A| |Z| n ulp ) +*> +*> (8) as (7) but calling SSPGV +*> (9) as (7) but with UPLO = 'L' +*> (10) as (9) but calling SSPGV +*> +*> (11) DKYGV with ITYPE = 3 and UPLO ='U': +*> +*> | B A Z - Z D | / ( |A| |Z| n ulp ) +*> +*> (12) as (11) but calling SSPGV +*> (13) as (11) but with UPLO = 'L' +*> (14) as (13) but calling SSPGV +*> +*> DKYGVD, SSPGVD and SSBGVD performed the same 14 tests. +*> +*> DKYGVX, SSPGVX and SSBGVX performed the above 14 tests with +*> the parameter RANGE = 'A', 'N' and 'I', respectively. +*> +*> The "sizes" are specified by an array NN(1:NSIZES); the value +*> of each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); +*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> This type is used for the matrix A which has half-bandwidth KA. +*> B is generated as a well-conditioned positive definite matrix +*> with half-bandwidth KB (<= KA). +*> Currently, the list of possible types for A is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries +*> 1, ULP, ..., ULP and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U* D U, where U is orthogonal and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U* D U, where U is orthogonal and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U* D U, where U is orthogonal and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) skew-symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold) +*> +*> (16) Same as (8), but with KA = 1 and KB = 1 +*> (17) Same as (8), but with KA = 2 and KB = 1 +*> (18) Same as (8), but with KA = 2 and KB = 2 +*> (19) Same as (8), but with KA = 3 and KB = 1 +*> (20) Same as (8), but with KA = 3 and KB = 2 +*> (21) Same as (8), but with KA = 3 and KB = 3 +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> NSIZES INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> DDRVKG2STG does nothing. It must be at least zero. +*> Not modified. +*> +*> NN INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. The values must be at least +*> zero. +*> Not modified. +*> +*> NTYPES INTEGER +*> The number of elements in DOTYPE. If it is zero, DDRVKG2STG +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> Not modified. +*> +*> DOTYPE LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> Not modified. +*> +*> ISEED INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to DDRVKG2STG to continue the same random number +*> sequence. +*> Modified. +*> +*> THRESH DOUBLE PRECISION +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error +*> is scaled to be O(1), so THRESH should be a reasonably +*> small multiple of 1, e.g., 10 or 100. In particular, +*> it should not depend on the precision (single vs. DOUBLE PRECISION) +*> or the size of the matrix. It must be at least zero. +*> Not modified. +*> +*> NOUNIT INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> Not modified. +*> +*> A DOUBLE PRECISION array, dimension (LDA , max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> Modified. +*> +*> LDA INTEGER +*> The leading dimension of A and AB. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> B DOUBLE PRECISION array, dimension (LDB , max(NN)) +*> Used to hold the symmetric positive definite matrix for +*> the generailzed problem. +*> On exit, B contains the last matrix actually +*> used. +*> Modified. +*> +*> LDB INTEGER +*> The leading dimension of B and BB. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> D DOUBLE PRECISION array, dimension (max(NN)) +*> The eigenvalues of A. On exit, the eigenvalues in D +*> correspond with the matrix in A. +*> Modified. +*> +*> Z DOUBLE PRECISION array, dimension (LDZ, max(NN)) +*> The matrix of eigenvectors. +*> Modified. +*> +*> LDZ INTEGER +*> The leading dimension of Z. It must be at least 1 and +*> at least max( NN ). +*> Not modified. +*> +*> AB DOUBLE PRECISION array, dimension (LDA, max(NN)) +*> Workspace. +*> Modified. +*> +*> BB DOUBLE PRECISION array, dimension (LDB, max(NN)) +*> Workspace. +*> Modified. +*> +*> AP DOUBLE PRECISION array, dimension (max(NN)**2) +*> Workspace. +*> Modified. +*> +*> BP DOUBLE PRECISION array, dimension (max(NN)**2) +*> Workspace. +*> Modified. +*> +*> WORK DOUBLE PRECISION array, dimension (NWORK) +*> Workspace. +*> Modified. +*> +*> NWORK INTEGER +*> The number of entries in WORK. This must be at least +*> 1+5*N+2*N*lg(N)+3*N**2 where N = max( NN(j) ) and +*> lg( N ) = smallest integer k such that 2**k >= N. +*> Not modified. +*> +*> IWORK INTEGER array, dimension (LIWORK) +*> Workspace. +*> Modified. +*> +*> LIWORK INTEGER +*> The number of entries in WORK. This must be at least 6*N. +*> Not modified. +*> +*> RESULT DOUBLE PRECISION array, dimension (70) +*> The values computed by the 70 tests described above. +*> Modified. +*> +*> INFO INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -16: LDZ < 1 or LDZ < NMAX. +*> -21: NWORK too small. +*> -23: LIWORK too small. +*> If DLATMR, DLATMS, DKYGV, SSPGV, SSBGV, DKYGVD, SSPGVD, +*> SSBGVD, DKYGVX, SSPGVX or SSBGVX returns an error code, +*> the absolute value of it is returned. +*> Modified. +*> +*> ---------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE DOUBLE PRECISION 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests that have been run +*> on this matrix. +*> NTESTT The total number of tests for this call. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far (computed by DLAFTS). +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_eig +* +* ===================================================================== + SUBROUTINE DDRVKG2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, B, LDB, D, D2, Z, LDZ, AB, + $ BB, AP, BP, WORK, NWORK, IWORK, LIWORK, + $ RESULT, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDZ, LIWORK, NOUNIT, NSIZES, + $ NTYPES, NWORK + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + DOUBLE PRECISION A( LDA, * ), AB( LDA, * ), AP( * ), + $ B( LDB, * ), BB( LDB, * ), BP( * ), D( * ), + $ D2( * ), RESULT( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TEN + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 21 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + CHARACTER UPLO + INTEGER I, IBTYPE, IBUPLO, IINFO, IJ, IL, IMODE, ITEMP, + $ ITYPE, IU, J, JCOL, JSIZE, JTYPE, KA, KA9, KB, + $ KB9, M, MTYPES, N, NERRS, NMATS, NMAX, NTEST, + $ NTESTT + DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, ULP, ULPINV, UNFL, VL, VU, TEMP1, TEMP2 +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLARND + EXTERNAL LSAME, DLAMCH, DLARND +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, DLACPY, DLAFTS, DLASET, DLASUM, DLATMR, + $ DLATMS, DKYGV, DKGT01 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 6*9 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 6*1 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 6*4 / +* .. +* .. Executable Statements .. +* +* 1) Check for errors +* + NTESTT = 0 + INFO = 0 +* + BADNN = .FALSE. + NMAX = 0 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDZ.LE.1 .OR. LDZ.LT.NMAX ) THEN + INFO = -16 + ELSE IF( 2*MAX( NMAX, 3 )**2.GT.NWORK ) THEN + INFO = -21 + ELSE IF( 2*MAX( NMAX, 3 )**2.GT.LIWORK ) THEN + INFO = -23 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DDRVKG2STG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = DLAMCH( 'Overflow' ) + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + 20 CONTINUE +* +* Loop over sizes, types +* + NERRS = 0 + NMATS = 0 +* + DO 650 JSIZE = 1, NSIZES + N = NN( JSIZE ) + ANINV = ONE / DBLE( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + KA9 = 0 + KB9 = 0 + DO 640 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 640 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* 2) Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, w/ eigenvalues +* =5 random log hermitian, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random hermitian +* =9 banded, w/ eigenvalues +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 90 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + IINFO = 0 + COND = ULPINV +* +* Special Matrices -- Identity & Jordan block +* + IF( ITYPE.EQ.1 ) THEN +* +* Zero +* + KA = 0 + KB = 0 + CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + KA = 0 + KB = 0 + CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + DO 80 JCOL = 1, N + A( JCOL, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* tridiagonal Matrix, [Eigen]values Specified +* + KA = 0 + KB = 0 + CALL DLATMS( N, N, 'S', ISEED, 'K', WORK, IMODE, COND, + $ ANORM, 1, 1, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* skew-symmetric, eigenvalues specified +* + KA = MAX( 0, N-1 ) + KB = KA + CALL DLATMS( N, N, 'S', ISEED, 'K', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* tridiagonal, random eigenvalues +* + KA = 0 + KB = 0 + CALL DLATMR( N, N, 'S', ISEED, 'K', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 1, 1, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* skew-symmetric, random eigenvalues +* + KA = MAX( 0, N-1 ) + KB = KA + CALL DLATMR( N, N, 'S', ISEED, 'K', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* skew-symmetric banded, eigenvalues specified +* +* The following values are used for the half-bandwidths: +* +* ka = 1 kb = 1 +* ka = 2 kb = 1 +* ka = 2 kb = 2 +* ka = 3 kb = 1 +* ka = 3 kb = 2 +* ka = 3 kb = 3 +* + KB9 = KB9 + 1 + IF( KB9.GT.KA9 ) THEN + KA9 = KA9 + 1 + KB9 = 1 + END IF + KA = MAX( 0, MIN( N-1, KA9 ) ) + KB = MAX( 0, MIN( N-1, KB9 ) ) + CALL DLATMS( N, N, 'S', ISEED, 'K', WORK, IMODE, COND, + $ ANORM, KA, KA, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 90 CONTINUE +* + ABSTOL = UNFL + UNFL + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + INT( ( N-1 )*DLARND( 1, ISEED2 ) ) + IU = 1 + INT( ( N-1 )*DLARND( 1, ISEED2 ) ) + IF( IL.GT.IU ) THEN + ITEMP = IL + IL = IU + IU = ITEMP + END IF + END IF +* +* 3) Call DKYGV, SSPGV, SSBGV, DKYGVD, SSPGVD, SSBGVD, +* DKYGVX, SSPGVX, and SSBGVX, do tests. +* +* loop over the three generalized problems +* IBTYPE = 1: A*x = (lambda)*B*x +* IBTYPE = 2: A*B*x = (lambda)*x +* IBTYPE = 3: B*A*x = (lambda)*x +* + DO 630 IBTYPE = 1, 3 +* +* loop over the setting UPLO +* + DO 620 IBUPLO = 1, 2 + IF( IBUPLO.EQ.1 ) + $ UPLO = 'U' + IF( IBUPLO.EQ.2 ) + $ UPLO = 'L' +* +* Generate random well-conditioned positive definite +* matrix B, of bandwidth not greater than that of A. +* + CALL DLATMS( N, N, 'U', ISEED, 'P', WORK, 5, TEN, ONE, + $ KB, KB, UPLO, B, LDB, WORK( N+1 ), + $ IINFO ) +* +* Test DKYGV +* + NTEST = NTEST + 1 +* + CALL DLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL DKYGV( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D, + $ WORK, NWORK, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DKYGV(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL DKGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) + 100 CONTINUE +* + 620 CONTINUE + 630 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + NTESTT = NTESTT + NTEST + CALL DLAFTS( 'DKG', N, N, JTYPE, NTEST, RESULT, IOLDSD, + $ THRESH, NOUNIT, NERRS ) + 640 CONTINUE + 650 CONTINUE +* +* Summary +* + CALL DLASUM( 'DKG', NOUNIT, NERRS, NTESTT ) +* + RETURN +* +* End of DDRVKG2STG +* + 9999 FORMAT( ' DDRVKG2STG: ', A, ' returned INFO=', I6, '.', / 9X, + $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) + END diff --git a/TESTING/EIG/ddrvkt.f b/TESTING/EIG/ddrvkt.f new file mode 100644 index 000000000..5024803db --- /dev/null +++ b/TESTING/EIG/ddrvkt.f @@ -0,0 +1,897 @@ +*> \brief \b DDRVKT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DDRVKT( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, D1, D2, D3, D4, EVEIGS, WA1, +* WA2, WA3, U, LDU, V, TAU, Z, WORK, LWORK, +* IWORK, LIWORK, RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, +* $ NTYPES +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* DOUBLE PRECISION A( LDA, * ), D1( * ), D2( * ), D3( * ), +* $ D4( * ), EVEIGS( * ), RESULT( * ), TAU( * ), +* $ U( LDU, * ), V( LDU, * ), WA1( * ), WA2( * ), +* $ WA3( * ), WORK( * ), Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DDRVKT checks the skew-symmetric eigenvalue problem drivers. +*> +*> DKTEV computes all eigenvalues and, optionally, +*> eigenvectors of a DOUBLE PRECISION skew-symmetric tridiagonal matrix. +*> +*> DKYEV computes all eigenvalues and, optionally, +*> eigenvectors of a DOUBLE PRECISION skew-symmetric matrix. +*> +*> When DDRVKT is called, a number of matrix "sizes" ("n's") and a +*> number of matrix "types" are specified. For each size ("n") +*> and each type of matrix, one matrix will be generated and used +*> to test the appropriate drivers. For each matrix and each +*> driver routine called, the following tests will be performed: +*> +*> (1) | A - Z D Z' | / ( |A| n ulp ) +*> +*> (2) | I - Z Z' | / ( n ulp ) +*> +*> (3) | D1 - D2 | / ( |D1| ulp ) +*> +*> where Z is the matrix of eigenvectors returned when the +*> eigenvector option is given and D1 and D2 are the eigenvalues +*> returned with and without the eigenvector option. +*> +*> The "sizes" are specified by an array NN(1:NSIZES); the value of +*> each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); +*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced eigenvalues +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced eigenvalues +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" eigenvalues +*> 1, ULP, ..., ULP and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U' D U, where U is orthogonal and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U' D U, where U is orthogonal and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U' D U, where U is orthogonal and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) skew-symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> (16) A band matrix with half bandwidth randomly chosen between +*> 0 and N-1, with evenly spaced eigenvalues 1, ..., ULP +*> with random signs. +*> (17) Same as (16), but multiplied by SQRT( overflow threshold ) +*> (18) Same as (16), but multiplied by SQRT( underflow threshold ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> NSIZES INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> DDRVKT does nothing. It must be at least zero. +*> Not modified. +*> +*> NN INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. The values must be at least +*> zero. +*> Not modified. +*> +*> NTYPES INTEGER +*> The number of elements in DOTYPE. If it is zero, DDRVKT +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> Not modified. +*> +*> DOTYPE LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> Not modified. +*> +*> ISEED INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to DDRVKT to continue the same random number +*> sequence. +*> Modified. +*> +*> THRESH DOUBLE PRECISION +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error +*> is scaled to be O(1), so THRESH should be a reasonably +*> small multiple of 1, e.g., 10 or 100. In particular, +*> it should not depend on the precision (single vs. double) +*> or the size of the matrix. It must be at least zero. +*> Not modified. +*> +*> NOUNIT INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> Not modified. +*> +*> A DOUBLE PRECISION array, dimension (LDA , max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> Modified. +*> +*> LDA INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> D1 DOUBLE PRECISION array, dimension (max(NN)) +*> The eigenvalues of A, as computed by SSTEQR simlutaneously +*> with Z. On exit, the eigenvalues in D1 correspond with the +*> matrix in A. +*> Modified. +*> +*> D2 DOUBLE PRECISION array, dimension (max(NN)) +*> The eigenvalues of A, as computed by SSTEQR if Z is not +*> computed. On exit, the eigenvalues in D2 correspond with +*> the matrix in A. +*> Modified. +*> +*> D3 DOUBLE PRECISION array, dimension (max(NN)) +*> The eigenvalues of A, as computed by SSTERF. On exit, the +*> eigenvalues in D3 correspond with the matrix in A. +*> Modified. +*> +*> D4 DOUBLE PRECISION array, dimension +*> +*> EVEIGS DOUBLE PRECISION array, dimension (max(NN)) +*> The eigenvalues as computed by DKTEV('N', ... ) +*> (I reserve the right to change this to the output of +*> whichever algorithm computes the most accurate eigenvalues). +*> +*> WA1 DOUBLE PRECISION array, dimension +*> +*> WA2 DOUBLE PRECISION array, dimension +*> +*> WA3 DOUBLE PRECISION array, dimension +*> +*> U DOUBLE PRECISION array, dimension (LDU, max(NN)) +*> The orthogonal matrix computed by SSYTRD + SORGTR. +*> Modified. +*> +*> LDU INTEGER +*> The leading dimension of U, Z, and V. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> V DOUBLE PRECISION array, dimension (LDU, max(NN)) +*> The Housholder vectors computed by SSYTRD in reducing A to +*> tridiagonal form. +*> Modified. +*> +*> TAU DOUBLE PRECISION array, dimension (max(NN)) +*> The Householder factors computed by SSYTRD in reducing A +*> to tridiagonal form. +*> Modified. +*> +*> Z DOUBLE PRECISION array, dimension (LDU, max(NN)) +*> The orthogonal matrix of eigenvectors computed by SSTEQR, +*> SPTEQR, and SSTEIN. +*> Modified. +*> +*> WORK DOUBLE PRECISION array, dimension (LWORK) +*> Workspace. +*> Modified. +*> +*> LWORK INTEGER +*> The number of entries in WORK. This must be at least +*> 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 4 * Nmax**2 +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> Not modified. +*> +*> IWORK INTEGER array, +*> dimension (6 + 6*Nmax + 5 * Nmax * lg Nmax ) +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> Workspace. +*> Modified. +*> +*> RESULT DOUBLE PRECISION array, dimension (105) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid +*> overflow. +*> Modified. +*> +*> INFO INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -16: LDU < 1 or LDU < NMAX. +*> -21: LWORK too small. +*> If DLATMR, DLATMS, SSYTRD, SORGTR, SSTEQR, SSTERF, +*> or SORMTR returns an error code, the +*> absolute value of it is returned. +*> Modified. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE DOUBLE PRECISION 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far (computed by DLAFTS). +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> +*> The tests performed are: Routine tested +*> 1= | A - U S U' | / ( |A| n ulp ) DKTEV('V', ... ) +*> 2= | I - U U' | / ( n ulp ) DKTEV('V', ... ) +*> 3= |D(with Z) - D(w/o Z)| / (|D| ulp) DKTEV('N', ... ) +*> 4= | A - U S U' | / ( |A| n ulp ) SSTEVX('V','A', ... ) +*> 5= | I - U U' | / ( n ulp ) SSTEVX('V','A', ... ) +*> 6= |D(with Z) - EVEIGS| / (|D| ulp) SSTEVX('N','A', ... ) +*> 7= | A - U S U' | / ( |A| n ulp ) SSTEVR('V','A', ... ) +*> 8= | I - U U' | / ( n ulp ) SSTEVR('V','A', ... ) +*> 9= |D(with Z) - EVEIGS| / (|D| ulp) SSTEVR('N','A', ... ) +*> 10= | A - U S U' | / ( |A| n ulp ) SSTEVX('V','I', ... ) +*> 11= | I - U U' | / ( n ulp ) SSTEVX('V','I', ... ) +*> 12= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVX('N','I', ... ) +*> 13= | A - U S U' | / ( |A| n ulp ) SSTEVX('V','V', ... ) +*> 14= | I - U U' | / ( n ulp ) SSTEVX('V','V', ... ) +*> 15= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVX('N','V', ... ) +*> 16= | A - U S U' | / ( |A| n ulp ) SSTEVD('V', ... ) +*> 17= | I - U U' | / ( n ulp ) SSTEVD('V', ... ) +*> 18= |D(with Z) - EVEIGS| / (|D| ulp) SSTEVD('N', ... ) +*> 19= | A - U S U' | / ( |A| n ulp ) SSTEVR('V','I', ... ) +*> 20= | I - U U' | / ( n ulp ) SSTEVR('V','I', ... ) +*> 21= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVR('N','I', ... ) +*> 22= | A - U S U' | / ( |A| n ulp ) SSTEVR('V','V', ... ) +*> 23= | I - U U' | / ( n ulp ) SSTEVR('V','V', ... ) +*> 24= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVR('N','V', ... ) +*> +*> 25= | A - U S U' | / ( |A| n ulp ) DKYEV('L','V', ... ) +*> 26= | I - U U' | / ( n ulp ) DKYEV('L','V', ... ) +*> 27= |D(with Z) - D(w/o Z)| / (|D| ulp) DKYEV('L','N', ... ) +*> 28= | A - U S U' | / ( |A| n ulp ) SSYEVX('L','V','A', ... ) +*> 29= | I - U U' | / ( n ulp ) SSYEVX('L','V','A', ... ) +*> 30= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVX('L','N','A', ... ) +*> 31= | A - U S U' | / ( |A| n ulp ) SSYEVX('L','V','I', ... ) +*> 32= | I - U U' | / ( n ulp ) SSYEVX('L','V','I', ... ) +*> 33= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVX('L','N','I', ... ) +*> 34= | A - U S U' | / ( |A| n ulp ) SSYEVX('L','V','V', ... ) +*> 35= | I - U U' | / ( n ulp ) SSYEVX('L','V','V', ... ) +*> 36= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVX('L','N','V', ... ) +*> 37= | A - U S U' | / ( |A| n ulp ) SSPEV('L','V', ... ) +*> 38= | I - U U' | / ( n ulp ) SSPEV('L','V', ... ) +*> 39= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEV('L','N', ... ) +*> 40= | A - U S U' | / ( |A| n ulp ) SSPEVX('L','V','A', ... ) +*> 41= | I - U U' | / ( n ulp ) SSPEVX('L','V','A', ... ) +*> 42= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVX('L','N','A', ... ) +*> 43= | A - U S U' | / ( |A| n ulp ) SSPEVX('L','V','I', ... ) +*> 44= | I - U U' | / ( n ulp ) SSPEVX('L','V','I', ... ) +*> 45= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVX('L','N','I', ... ) +*> 46= | A - U S U' | / ( |A| n ulp ) SSPEVX('L','V','V', ... ) +*> 47= | I - U U' | / ( n ulp ) SSPEVX('L','V','V', ... ) +*> 48= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVX('L','N','V', ... ) +*> 49= | A - U S U' | / ( |A| n ulp ) SSBEV('L','V', ... ) +*> 50= | I - U U' | / ( n ulp ) SSBEV('L','V', ... ) +*> 51= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEV('L','N', ... ) +*> 52= | A - U S U' | / ( |A| n ulp ) SSBEVX('L','V','A', ... ) +*> 53= | I - U U' | / ( n ulp ) SSBEVX('L','V','A', ... ) +*> 54= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVX('L','N','A', ... ) +*> 55= | A - U S U' | / ( |A| n ulp ) SSBEVX('L','V','I', ... ) +*> 56= | I - U U' | / ( n ulp ) SSBEVX('L','V','I', ... ) +*> 57= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVX('L','N','I', ... ) +*> 58= | A - U S U' | / ( |A| n ulp ) SSBEVX('L','V','V', ... ) +*> 59= | I - U U' | / ( n ulp ) SSBEVX('L','V','V', ... ) +*> 60= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVX('L','N','V', ... ) +*> 61= | A - U S U' | / ( |A| n ulp ) SSYEVD('L','V', ... ) +*> 62= | I - U U' | / ( n ulp ) SSYEVD('L','V', ... ) +*> 63= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVD('L','N', ... ) +*> 64= | A - U S U' | / ( |A| n ulp ) SSPEVD('L','V', ... ) +*> 65= | I - U U' | / ( n ulp ) SSPEVD('L','V', ... ) +*> 66= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVD('L','N', ... ) +*> 67= | A - U S U' | / ( |A| n ulp ) SSBEVD('L','V', ... ) +*> 68= | I - U U' | / ( n ulp ) SSBEVD('L','V', ... ) +*> 69= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVD('L','N', ... ) +*> 70= | A - U S U' | / ( |A| n ulp ) SSYEVR('L','V','A', ... ) +*> 71= | I - U U' | / ( n ulp ) SSYEVR('L','V','A', ... ) +*> 72= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVR('L','N','A', ... ) +*> 73= | A - U S U' | / ( |A| n ulp ) SSYEVR('L','V','I', ... ) +*> 74= | I - U U' | / ( n ulp ) SSYEVR('L','V','I', ... ) +*> 75= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVR('L','N','I', ... ) +*> 76= | A - U S U' | / ( |A| n ulp ) SSYEVR('L','V','V', ... ) +*> 77= | I - U U' | / ( n ulp ) SSYEVR('L','V','V', ... ) +*> 78= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVR('L','N','V', ... ) +*> +*> Tests 25 through 78 are repeated (as tests 79 through 132) +*> with UPLO='U' +*> +*> To be added in 1999 +*> +*> 79= | A - U S U' | / ( |A| n ulp ) SSPEVR('L','V','A', ... ) +*> 80= | I - U U' | / ( n ulp ) SSPEVR('L','V','A', ... ) +*> 81= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVR('L','N','A', ... ) +*> 82= | A - U S U' | / ( |A| n ulp ) SSPEVR('L','V','I', ... ) +*> 83= | I - U U' | / ( n ulp ) SSPEVR('L','V','I', ... ) +*> 84= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVR('L','N','I', ... ) +*> 85= | A - U S U' | / ( |A| n ulp ) SSPEVR('L','V','V', ... ) +*> 86= | I - U U' | / ( n ulp ) SSPEVR('L','V','V', ... ) +*> 87= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVR('L','N','V', ... ) +*> 88= | A - U S U' | / ( |A| n ulp ) SSBEVR('L','V','A', ... ) +*> 89= | I - U U' | / ( n ulp ) SSBEVR('L','V','A', ... ) +*> 90= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVR('L','N','A', ... ) +*> 91= | A - U S U' | / ( |A| n ulp ) SSBEVR('L','V','I', ... ) +*> 92= | I - U U' | / ( n ulp ) SSBEVR('L','V','I', ... ) +*> 93= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVR('L','N','I', ... ) +*> 94= | A - U S U' | / ( |A| n ulp ) SSBEVR('L','V','V', ... ) +*> 95= | I - U U' | / ( n ulp ) SSBEVR('L','V','V', ... ) +*> 96= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVR('L','N','V', ... ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_eig +* +* ===================================================================== + SUBROUTINE DDRVKT( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, D1, D2, D3, D4, EVEIGS, WA1, + $ WA2, WA3, U, LDU, V, TAU, Z, WORK, LWORK, + $ IWORK, LIWORK, RESULT, INFO ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, + $ NTYPES + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + DOUBLE PRECISION A( LDA, * ), D1( * ), D2( * ), D3( * ), + $ D4( * ), EVEIGS( * ), RESULT( * ), TAU( * ), + $ U( LDU, * ), V( LDU, * ), WA1( * ), WA2( * ), + $ WA3( * ), WORK( * ), Z( LDU, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, TEN + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ TEN = 10.0D0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = 0.5D0 ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 18 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + CHARACTER UPLO + INTEGER I, IDIAG, IHBW, IINFO, IL, IMODE, IROW, + $ ITEMP, ITYPE, IU, IUPLO, J, J1, J2, JCOL, + $ JSIZE, JTYPE, LGN, LIWEDC, LWEDC, + $ MTYPES, N, NERRS, NMATS, NMAX, NTEST, + $ NTESTT + DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, TEMP1, TEMP2, ULP, ULPINV, UNFL, + $ VL, VU +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ ISEED3( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLARND, DSXT1 + EXTERNAL DLAMCH, DLARND, DSXT1 +* .. +* .. External Subroutines .. + EXTERNAL ALASVM, DLABAD, DLACPY, DLAFTS, DLASET, DLATMR, + $ DLATMS, DKTEV, DKTT21, DKYEV, DKYT21, XERBLA +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, INT, LOG, MAX, MIN, DBLE, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 3*9 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 1, 2, 3 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 4, 4, 4 / +* .. +* .. Executable Statements .. +* +* Keep ftrnchek happy +* + VL = ZERO + VU = ZERO +* +* 1) Check for errors +* + NTESTT = 0 + INFO = 0 +* + BADNN = .FALSE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -16 + ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN + INFO = -21 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DDRVKT', -INFO ) + RETURN + END IF +* +* Quick return if nothing to do +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = DLAMCH( 'Overflow' ) + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + ISEED3( I ) = ISEED( I ) + 20 CONTINUE +* + NERRS = 0 + NMATS = 0 +* +* + DO 1740 JSIZE = 1, NSIZES + N = NN( JSIZE ) + IF( N.GT.0 ) THEN + LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) ) + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + LWEDC = 1 + 4*N + 2*N*LGN + 4*N**2 +c LIWEDC = 6 + 6*N + 5*N*LGN + LIWEDC = 3 + 5*N + ELSE + LWEDC = 9 +c LIWEDC = 12 + LIWEDC = 8 + END IF + ANINV = ONE / DBLE( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 1730 JTYPE = 1, MTYPES +* + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 1730 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* 2) Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log skew-symmetric, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random skew-symmetric +* =9 band skew-symmetric, w/ eigenvalues +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 110 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + IINFO = 0 + COND = ULPINV +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JCOL = 1, N + A( JCOL, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* tridiagonal Matrix, [Eigen]values Specified +* + CALL DLATMS( N, N, 'S', ISEED, 'K', WORK, IMODE, COND, + $ ANORM, 1, 1, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* skew-symmetric, eigenvalues specified +* + CALL DLATMS( N, N, 'S', ISEED, 'K', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* tridiagonal, random eigenvalues +* + IDUMMA( 1 ) = 1 + CALL DLATMR( N, N, 'S', ISEED, 'K', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 1, 1, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* skew-symmetric, random eigenvalues +* + IDUMMA( 1 ) = 1 + CALL DLATMR( N, N, 'S', ISEED, 'K', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* skew-symmetric banded, eigenvalues specified +* + IHBW = INT( ( N-1 )*DLARND( 1, ISEED3 ) ) + CALL DLATMS( N, N, 'S', ISEED, 'K', WORK, IMODE, COND, + $ ANORM, IHBW, IHBW, 'Z', U, LDU, WORK( N+1 ), + $ IINFO ) +* +* Store as dense matrix for most routines. +* + CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + DO 100 IDIAG = -IHBW, IHBW + IROW = IHBW - IDIAG + 1 + J1 = MAX( 1, IDIAG+1 ) + J2 = MIN( N, N+IDIAG ) + DO 90 J = J1, J2 + I = J - IDIAG + A( I, J ) = U( IROW, J ) + 90 CONTINUE + 100 CONTINUE + ELSE + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 110 CONTINUE +* + ABSTOL = UNFL + UNFL + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + INT( ( N-1 )*DLARND( 1, ISEED2 ) ) + IU = 1 + INT( ( N-1 )*DLARND( 1, ISEED2 ) ) + IF( IL.GT.IU ) THEN + ITEMP = IL + IL = IU + IU = ITEMP + END IF + END IF +* +* 3) If matrix is tridiagonal, call DKTEV and SSTEVX. +* + IF( JTYPE.LE.7 ) THEN + NTEST = 1 + DO 120 I = 1, N + D1( I ) = DBLE( A( I, I ) ) + 120 CONTINUE + DO 130 I = 1, N - 1 + D2( I ) = DBLE( A( I+1, I ) ) + 130 CONTINUE + SRNAMT = 'DKTEV' + CALL DKTEV( 'V', N, D1, D2, Z, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DKTEV(V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + RESULT( 2 ) = ULPINV + RESULT( 3 ) = ULPINV + GO TO 180 + END IF + END IF +* +* Do tests 1 and 2. +* + DO 140 I = 1, N + D3( I ) = DBLE( A( I, I ) ) + 140 CONTINUE + DO 150 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 150 CONTINUE + CALL DKTT21( N, 1, D3, D4, D2, D1, Z, LDU, WORK, + $ RESULT( 1 ) ) +* + NTEST = 3 + DO 160 I = 1, N - 1 + D4( I ) = DBLE( A( I+1, I ) ) + 160 CONTINUE + SRNAMT = 'DKTEV' + CALL DKTEV( 'N', N, D3, D4, Z, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DKTEV(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 180 + END IF + END IF +* +* Do test 3. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 170 J = 1, N-1 + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 170 CONTINUE + RESULT( 3 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 180 CONTINUE +* + ELSE +* + DO 640 I = 1, 3 + RESULT( I ) = ZERO + 640 CONTINUE + NTEST = 3 + END IF +* +* Perform remaining tests storing upper or lower triangular +* part of matrix. +* + DO 1720 IUPLO = 0, 1 + IF( IUPLO.EQ.0 ) THEN + UPLO = 'L' + ELSE + UPLO = 'U' + END IF +* +* 4) Call DKYEV and SSYEVX. +* + CALL DLACPY( ' ', N, N, A, LDA, V, LDU ) +* + NTEST = NTEST + 1 + SRNAMT = 'DKYEV' + CALL DKYEV( 'V', UPLO, N, A, LDU, D1, WORK, LWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DKYEV(V,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 660 + END IF + END IF +* +* Do tests 25 and 26 (or +54) +* + CALL DKYT21( 1, UPLO, N, 1, V, LDU, D2, D1, A, LDU, Z, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 2 + SRNAMT = 'DKYEV' + CALL DKYEV( 'N', UPLO, N, A, LDU, D3, WORK, LWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DKYEV(N,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 660 + END IF + END IF +* +* Do test 27 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 650 J = 1, N-1 + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 650 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 660 CONTINUE +* + CALL DLACPY( ' ', N, N, V, LDU, A, LDA ) +* + 1720 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + NTESTT = NTESTT + NTEST +* + CALL DLAFTS( 'DKT', N, N, JTYPE, NTEST, RESULT, IOLDSD, + $ THRESH, NOUNIT, NERRS ) +* + 1730 CONTINUE + 1740 CONTINUE +* +* Summary +* + CALL ALASVM( 'DKT', NOUNIT, NERRS, NTESTT, 0 ) +* + 9999 FORMAT( ' DDRVKT: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', + $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* + RETURN +* +* End of DDRVKT +* + END diff --git a/TESTING/EIG/derrkt.f b/TESTING/EIG/derrkt.f new file mode 100644 index 000000000..4d76c0f05 --- /dev/null +++ b/TESTING/EIG/derrkt.f @@ -0,0 +1,211 @@ +*> \brief \b DERRKT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DERRKT( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DERRKT tests the error exits for DKYTRD, DKTEQR and DKYEV. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_eig +* +* ===================================================================== + SUBROUTINE DERRKT( PATH, NUNIT ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* NMAX has to be at least 3 or LIW may be too small +* .. Parameters .. + INTEGER NMAX, LIW, LW + PARAMETER ( NMAX = 3, LIW = 12*NMAX, LW = 20*NMAX ) +* .. +* .. Local Scalars .. + CHARACTER*2 C2 + INTEGER I, INFO, J, M, N, NSPLIT, NT +* .. +* .. Local Arrays .. + INTEGER I1( NMAX ), I2( NMAX ), I3( NMAX ), IW( LIW ) + DOUBLE PRECISION A( NMAX, NMAX ), C( NMAX, NMAX ), D( NMAX ), + $ E( NMAX ), Q( NMAX, NMAX ), R( NMAX ), + $ TAU( NMAX ), W( LW ), X( NMAX ), + $ Z( NMAX, NMAX ) +* .. +* .. External Functions .. + LOGICAL LSAMEN + EXTERNAL LSAMEN +* .. +* .. External Subroutines .. + EXTERNAL CHKXER, DKTEQR, DKYEV, DKTEV, DKYTRD +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) + C2 = PATH( 2: 3 ) +* +* Set the variables to innocuous values. +* + DO 20 J = 1, NMAX + DO 10 I = 1, NMAX + A( I, J ) = 1. / DBLE( I+J ) + 10 CONTINUE + 20 CONTINUE + DO 30 J = 1, NMAX + D( J ) = DBLE( J ) + E( J ) = 0.0 + I1( J ) = J + I2( J ) = J + TAU( J ) = 1. + 30 CONTINUE + OK = .TRUE. + NT = 0 +* +* Test error exits for the KT path. +* + IF( LSAMEN( 2, C2, 'KT' ) ) THEN +* +* DKYTRD +* + SRNAMT = 'DKYTRD' + INFOT = 1 + CALL DKYTRD( '/', 0, A, 1, E, TAU, W, 1, INFO ) + CALL CHKXER( 'DKYTRD', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DKYTRD( 'U', -1, A, 1, E, TAU, W, 1, INFO ) + CALL CHKXER( 'DKYTRD', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DKYTRD( 'U', 2, A, 1, E, TAU, W, 1, INFO ) + CALL CHKXER( 'DKYTRD', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DKYTRD( 'U', 0, A, 1, E, TAU, W, 0, INFO ) + CALL CHKXER( 'DKYTRD', INFOT, NOUT, LERR, OK ) + NT = NT + 4 +* +* DKTEQR +* + SRNAMT = 'DKTEQR' + INFOT = 1 + CALL DKTEQR( '/', 0, E, Z, 1, W, INFO ) + CALL CHKXER( 'DKTEQR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DKTEQR( 'N', -1, E, Z, 1, W, INFO ) + CALL CHKXER( 'DKTEQR', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DKTEQR( 'V', 2, E, Z, 1, W, INFO ) + CALL CHKXER( 'DKTEQR', INFOT, NOUT, LERR, OK ) + NT = NT + 3 +* +* DKYEV +* + SRNAMT = 'DKYEV ' + INFOT = 1 + CALL DKYEV( '/', 'U', 0, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'DKYEV ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DKYEV( 'N', '/', 0, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'DKYEV ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DKYEV( 'N', 'U', -1, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'DKYEV ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DKYEV( 'N', 'U', 2, A, 1, X, W, 3, INFO ) + CALL CHKXER( 'DKYEV ', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DKYEV( 'N', 'U', 2, A, 2, X, W, 2, INFO ) + CALL CHKXER( 'DKYEV ', INFOT, NOUT, LERR, OK ) + NT = NT + 5 +* +* DKTEV +* + SRNAMT = 'DKTEV ' + INFOT = 1 + CALL DKTEV( '/', 0, D, E, Z, 1, W, INFO ) + CALL CHKXER( 'DKTEV ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DKTEV( 'N', -1, D, E, Z, 1, W, INFO ) + CALL CHKXER( 'DKTEV ', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DKTEV( 'V', 2, D, E, Z, 1, W, INFO ) + CALL CHKXER( 'DKTEV ', INFOT, NOUT, LERR, OK ) + NT = NT + 3 + END IF +* +* Print a summary line. +* + IF( OK ) THEN + WRITE( NOUT, FMT = 9999 )PATH, NT + ELSE + WRITE( NOUT, FMT = 9998 )PATH + END IF +* + 9999 FORMAT( 1X, A3, ' routines passed the tests of the error exits', + $ ' (', I3, ' tests done)' ) + 9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ', + $ 'exits ***' ) +* + RETURN +* +* End of DERRKT +* + END diff --git a/TESTING/EIG/dkgt01.f b/TESTING/EIG/dkgt01.f new file mode 100644 index 000000000..ca593af45 --- /dev/null +++ b/TESTING/EIG/dkgt01.f @@ -0,0 +1,263 @@ +*> \brief \b DKGT01 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DKGT01( ITYPE, UPLO, N, M, A, LDA, B, LDB, Z, LDZ, D, +* WORK, RESULT ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER ITYPE, LDA, LDB, LDZ, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), D( * ), RESULT( * ), +* $ WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DKGT01 checks a decomposition of the form +*> +*> A Z = B Z D or +*> A B Z = Z D or +*> B A Z = Z D +*> +*> where A is a skew-symmetric matrix, B is +*> skew-symmetric positive definite, Z is orthogonal, and D is diagonal. +*> +*> One of the following test ratios is computed: +*> +*> ITYPE = 1: RESULT(1) = | A Z - B Z D | / ( |A| |Z| n ulp ) +*> +*> ITYPE = 2: RESULT(1) = | A B Z - Z D | / ( |A| |Z| n ulp ) +*> +*> ITYPE = 3: RESULT(1) = | B A Z - Z D | / ( |A| |Z| n ulp ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is INTEGER +*> The form of the skew-symmetric generalized eigenproblem. +*> = 1: A*z = (lambda)*B*z +*> = 2: A*B*z = (lambda)*z +*> = 3: B*A*z = (lambda)*z +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> skew-symmetric matrices A and B is stored. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of eigenvalues found. 0 <= M <= N. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> The original skew-symmetric matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB, N) +*> The original symmetric positive definite matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in] Z +*> \verbatim +*> Z is DOUBLE PRECISION array, dimension (LDZ, M) +*> The computed eigenvectors of the generalized eigenproblem. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (M) +*> The computed eigenvalues of the generalized eigenproblem. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N*N) +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (1) +*> The test ratio as described above. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_eig +* +* ===================================================================== + SUBROUTINE DKGT01( ITYPE, UPLO, N, M, A, LDA, B, LDB, Z, LDZ, D, + $ WORK, RESULT ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER ITYPE, LDA, LDB, LDZ, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), D( * ), RESULT( * ), + $ WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION ANORM, ULP +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE, DLANKY + EXTERNAL DLAMCH, DLANGE, DLANKY +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DSCAL, DAXPY, DSYMM, DKYMM +* .. +* .. Executable Statements .. +* + RESULT( 1 ) = ZERO + IF( N.LE.0 ) + $ RETURN +* + ULP = DLAMCH( 'Epsilon' ) +* +* Compute product of 1-norms of A and Z. +* + ANORM = DLANKY( '1', UPLO, N, A, LDA, WORK )* + $ DLANGE( '1', N, M, Z, LDZ, WORK ) + IF( ANORM.EQ.ZERO ) + $ ANORM = ONE +* + IF( ITYPE.EQ.1 ) THEN +* +* Norm of AZ - BZD +* + CALL DKYMM( 'Left', UPLO, N, M, ONE, A, LDA, Z, LDZ, ZERO, + $ WORK, N ) + DO 10 I = 1, M-1 + CALL DCOPY( N, Z( 1, I+1 ), 1, WORK(N**2+(I-1)*N+1), 1 ) + CALL DSCAL( N, D( I ), WORK(N**2+(I-1)*N+1), 1 ) + 10 CONTINUE + DO 20 I = 2, M-1 + CALL DAXPY( N, -D( I-1 ), Z( 1, I-1 ), 1, + $ WORK(N**2+(I-1)*N+1), 1 ) + 20 CONTINUE + CALL DCOPY( N, Z( 1, M-1 ), 1, WORK(N**2+(M-1)*N+1), 1 ) + CALL DSCAL( N, -D( M-1 ), WORK(N**2+(M-1)*N+1), 1 ) + CALL DSYMM( 'Left', UPLO, N, M, ONE, B, LDB, WORK(N**2+1), + $ N, -ONE, WORK, N ) +* + RESULT( 1 ) = ( DLANGE( '1', N, M, WORK, N, WORK ) / ANORM ) / + $ ( N*ULP ) +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Norm of ABZ - ZD +* + CALL DSYMM( 'Left', UPLO, N, M, ONE, B, LDB, Z, LDZ, ZERO, + $ WORK, N ) + DO 30 I = 1, M-1 + CALL DCOPY( N, Z( 1, I+1 ), 1, WORK(N**2+(I-1)*N+1), 1 ) + CALL DSCAL( N, D( I ), WORK(N**2+(I-1)*N+1), 1 ) + 30 CONTINUE + DO 40 I = 2, M-1 + CALL DAXPY( N, -D( I-1 ), Z( 1, I-1 ), 1, + $ WORK(N**2+(I-1)*N+1), 1 ) + 40 CONTINUE + CALL DCOPY( N, Z( 1, M-1 ), 1, WORK(N**2+(M-1)*N+1), 1 ) + CALL DSCAL( N, -D( M-1 ), WORK(N**2+(M-1)*N+1), 1 ) + CALL DKYMM( 'Left', UPLO, N, M, ONE, A, LDA, WORK, N, -ONE, + $ WORK(N**2+1), N ) +* + RESULT( 1 ) = ( DLANGE( '1', N, M, WORK(N**2+1), N, WORK ) + $ / ANORM ) / ( N*ULP ) +* + ELSE IF( ITYPE.EQ.3 ) THEN +* +* Norm of BAZ - ZD +* + CALL DKYMM( 'Left', UPLO, N, M, ONE, A, LDA, Z, LDZ, ZERO, + $ WORK, N ) + DO 50 I = 1, M-1 + CALL DCOPY( N, Z( 1, I+1 ), 1, WORK(N**2+(I-1)*N+1), 1 ) + CALL DSCAL( N, D( I ), WORK(N**2+(I-1)*N+1), 1 ) + 50 CONTINUE + DO 60 I = 2, M-1 + CALL DAXPY( N, -D( I-1 ), Z( 1, I-1 ), 1, + $ WORK(N**2+(I-1)*N+1), 1 ) + 60 CONTINUE + CALL DCOPY( N, Z( 1, M-1 ), 1, WORK(N**2+(M-1)*N+1), 1 ) + CALL DSCAL( N, -D( M-1 ), WORK(N**2+(M-1)*N+1), 1 ) + CALL DSYMM( 'Left', UPLO, N, M, ONE, B, LDB, WORK, N, -ONE, + $ WORK(N**2+1), N ) +* + RESULT( 1 ) = ( DLANGE( '1', N, M, WORK(N**2+1), N, WORK ) + $ / ANORM ) / ( N*ULP ) + END IF +* + RETURN +* +* End of DKGT01 +* + END diff --git a/TESTING/EIG/dktt21.f b/TESTING/EIG/dktt21.f new file mode 100644 index 000000000..f2311f50e --- /dev/null +++ b/TESTING/EIG/dktt21.f @@ -0,0 +1,230 @@ +*> \brief \b DKTT21 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DKTT21( N, KBAND, AD, AE, SD, SE, U, LDU, WORK, +* RESULT ) +* +* .. Scalar Arguments .. +* INTEGER KBAND, LDU, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AD( * ), AE( * ), RESULT( 2 ), SD( * ), +* $ SE( * ), U( LDU, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DKTT21 checks a decomposition of the form +*> +*> A = U S U' +*> +*> where ' means transpose, A is skew-symmetric tridiagonal, U is orthogonal, +*> and S is diagonal (if KBAND=0) or skew-symmetric tridiagonal (if KBAND=1). +*> Two tests are performed: +*> +*> RESULT(1) = | A - U S U' | / ( |A| n ulp ) +*> +*> RESULT(2) = | I - UU' | / ( n ulp ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The size of the matrix. If it is zero, DKTT21 does nothing. +*> It must be at least zero. +*> \endverbatim +*> +*> \param[in] KBAND +*> \verbatim +*> KBAND is INTEGER +*> The bandwidth of the matrix S. It may only be zero or one. +*> If zero, then S is diagonal, and SE is not referenced. If +*> one, then S is skew-symmetric tri-diagonal. +*> \endverbatim +*> +*> \param[in] AD +*> \verbatim +*> AD is DOUBLE PRECISION array, dimension (N) +*> AD is not referenced. +*> \endverbatim +*> +*> \param[in] AE +*> \verbatim +*> AE is DOUBLE PRECISION array, dimension (N-1) +*> The off-diagonal of the original (unfactored) matrix A. A +*> is assumed to be skew-symmetric tridiagonal. AE(1) is the (1,2) +*> and (2,1) element, AE(2) is the (2,3) and (3,2) element, etc. +*> \endverbatim +*> +*> \param[in] SD +*> \verbatim +*> SD is DOUBLE PRECISION array, dimension (N) +*> SD is not referenced. +*> \endverbatim +*> +*> \param[in] SE +*> \verbatim +*> SE is DOUBLE PRECISION array, dimension (N-1) +*> The off-diagonal of the (skew-symmetric tri-) diagonal matrix S. +*> Not referenced if KBSND=0. If KBAND=1, then AE(1) is the +*> (1,2) and (2,1) element, SE(2) is the (2,3) and (3,2) +*> element, etc. +*> \endverbatim +*> +*> \param[in] U +*> \verbatim +*> U is DOUBLE PRECISION array, dimension (LDU, N) +*> The orthogonal matrix in the decomposition. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of U. LDU must be at least N. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N*(N+1)) +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (2) +*> The values computed by the two tests described above. The +*> values are currently limited to 1/ulp, to avoid overflow. +*> RESULT(1) is always modified. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_eig +* +* ===================================================================== + SUBROUTINE DKTT21( N, KBAND, AD, AE, SD, SE, U, LDU, WORK, + $ RESULT ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER KBAND, LDU, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AD( * ), AE( * ), RESULT( 2 ), SD( * ), + $ SE( * ), U( LDU, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + INTEGER J + DOUBLE PRECISION ANORM, TEMP1, TEMP2, ULP, UNFL, WNORM +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE, DLANKY + EXTERNAL DLAMCH, DLANGE, DLANKY +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DLASET, DKYR2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, DBLE +* .. +* .. Executable Statements .. +* +* 1) Constants +* + RESULT( 1 ) = ZERO + RESULT( 2 ) = ZERO + IF( N.LE.0 ) + $ RETURN +* + UNFL = DLAMCH( 'Safe minimum' ) + ULP = DLAMCH( 'Precision' ) +* +* Do Test 1 +* +* Copy A & Compute its 1-Norm: +* + CALL DLASET( 'Full', N, N, ZERO, ZERO, WORK, N ) +* + ANORM = ZERO + TEMP1 = ZERO +* + DO 10 J = 1, N - 1 + WORK( ( N+1 )*( J-1 )+1 ) = ZERO + WORK( ( N+1 )*( J-1 )+2 ) = AE( J ) + TEMP2 = ABS( AE( J ) ) + ANORM = MAX( ANORM, ABS( ZERO )+TEMP1+TEMP2 ) + TEMP1 = TEMP2 + 10 CONTINUE +* + WORK( N**2 ) = ZERO + ANORM = MAX( ANORM, ABS( ZERO )+TEMP1, UNFL ) +* +* Norm of A - USU' +* + IF( N.GT.1 .AND. KBAND.EQ.1 ) THEN + DO 30 J = 1, N - 1 + CALL DKYR2( 'L', N, -SE( J ), U( 1, J ), 1, U( 1, J+1 ), 1, + $ WORK, N ) + 30 CONTINUE + END IF +* + WNORM = DLANKY( '1', 'L', N, WORK, N, WORK( N**2+1 ) ) +* + IF( ANORM.GT.WNORM ) THEN + RESULT( 1 ) = ( WNORM / ANORM ) / ( N*ULP ) + ELSE + IF( ANORM.LT.ONE ) THEN + RESULT( 1 ) = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP ) + ELSE + RESULT( 1 ) = MIN( WNORM / ANORM, DBLE( N ) ) / ( N*ULP ) + END IF + END IF +* +* Do Test 2 +* +* Compute UU' - I +* + CALL DGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK, + $ N ) +* + DO 40 J = 1, N + WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE + 40 CONTINUE +* + RESULT( 2 ) = MIN( DBLE( N ), DLANGE( '1', N, N, WORK, N, + $ WORK( N**2+1 ) ) ) / ( N*ULP ) +* + RETURN +* +* End of DKTT21 +* + END diff --git a/TESTING/EIG/dkyt21.f b/TESTING/EIG/dkyt21.f new file mode 100644 index 000000000..22ff9fef5 --- /dev/null +++ b/TESTING/EIG/dkyt21.f @@ -0,0 +1,410 @@ +*> \brief \b DKYT21 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DKYT21( ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V, +* LDV, TAU, WORK, RESULT ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER ITYPE, KBAND, LDA, LDU, LDV, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), RESULT( 2 ), +* $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DKYT21 generally checks a decomposition of the form +*> +*> A = U S U**T +*> +*> where **T means transpose, A is skew-symmetric, U is orthogonal, and S is +*> diagonal (if KBAND=0) or skew-symmetric tridiagonal (if KBAND=1). +*> +*> If ITYPE=1, then U is represented as a dense matrix; otherwise U is +*> expressed as a product of Householder transformations, whose vectors +*> are stored in the array "V" and whose scaling constants are in "TAU". +*> We shall use the letter "V" to refer to the product of Householder +*> transformations (which should be equal to U). +*> +*> Specifically, if ITYPE=1, then: +*> +*> RESULT(1) = | A - U S U**T | / ( |A| n ulp ) and +*> RESULT(2) = | I - U U**T | / ( n ulp ) +*> +*> If ITYPE=2, then: +*> +*> RESULT(1) = | A - V S V**T | / ( |A| n ulp ) +*> +*> If ITYPE=3, then: +*> +*> RESULT(1) = | I - V U**T | / ( n ulp ) +*> +*> For ITYPE > 1, the transformation U is expressed as a product +*> V = H(1)...H(n-2), where H(j) = I - tau(j) v(j) v(j)**T and each +*> vector v(j) has its first j elements 0 and the remaining n-j elements +*> stored in V(j+1:n,j). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is INTEGER +*> Specifies the type of tests to be performed. +*> 1: U expressed as a dense orthogonal matrix: +*> RESULT(1) = | A - U S U**T | / ( |A| n ulp ) and +*> RESULT(2) = | I - U U**T | / ( n ulp ) +*> +*> 2: U expressed as a product V of Housholder transformations: +*> RESULT(1) = | A - V S V**T | / ( |A| n ulp ) +*> +*> 3: U expressed both as a dense orthogonal matrix and +*> as a product of Housholder transformations: +*> RESULT(1) = | I - V U**T | / ( n ulp ) +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER +*> If UPLO='U', the upper triangle of A and V will be used and +*> the (strictly) lower triangle will not be referenced. +*> If UPLO='L', the lower triangle of A and V will be used and +*> the (strictly) upper triangle will not be referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The size of the matrix. If it is zero, DKYT21 does nothing. +*> It must be at least zero. +*> \endverbatim +*> +*> \param[in] KBAND +*> \verbatim +*> KBAND is INTEGER +*> The bandwidth of the matrix. It may only be zero or one. +*> If zero, then S is diagonal, and E is not referenced. If +*> one, then S is skew-symmetric tri-diagonal. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA, N) +*> The original (unfactored) matrix. It is assumed to be +*> skew-symmetric, and only the upper (UPLO='U') or only the lower +*> (UPLO='L') will be referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. It must be at least 1 +*> and at least N. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> D is not referenced. +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> The (n-1) lower subdiagonal elements of the block diagonal matrix. +*> The matrix consists of 2-by-2 skew-symmetric blocks, and zeros. +*> Not referenced if KBAND=0. +*> \endverbatim +*> +*> \param[in] U +*> \verbatim +*> U is DOUBLE PRECISION array, dimension (LDU, N) +*> If ITYPE=1 or 3, this contains the orthogonal matrix in +*> the decomposition, expressed as a dense matrix. If ITYPE=2, +*> then it is not referenced. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of U. LDU must be at least N and +*> at least 1. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (LDV, N) +*> If ITYPE=2 or 3, the columns of this array contain the +*> Householder vectors used to describe the orthogonal matrix +*> in the decomposition. If UPLO='L', then the vectors are in +*> the lower triangle, if UPLO='U', then in the upper +*> triangle. +*> *NOTE* If ITYPE=2 or 3, V is modified and restored. The +*> subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U') +*> is set to one, and later reset to its original value, during +*> the course of the calculation. +*> If ITYPE=1, then it is neither referenced nor modified. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of V. LDV must be at least N and +*> at least 1. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (N) +*> If ITYPE >= 2, then TAU(j) is the scalar factor of +*> v(j) v(j)**T in the Householder transformation H(j) of +*> the product U = H(1)...H(n-2) +*> If ITYPE < 2, then TAU is not referenced. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (2*N**2) +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is DOUBLE PRECISION array, dimension (2) +*> The values computed by the two tests described above. The +*> values are currently limited to 1/ulp, to avoid overflow. +*> RESULT(1) is always modified. RESULT(2) is modified only +*> if ITYPE=1. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_eig +* +* ===================================================================== + SUBROUTINE DKYT21( ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V, + $ LDV, TAU, WORK, RESULT ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER ITYPE, KBAND, LDA, LDU, LDV, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), RESULT( 2 ), + $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TEN + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER + CHARACTER CUPLO + INTEGER IINFO, J, JCOL, JR, JROW + DOUBLE PRECISION ANORM, ULP, UNFL, VSAVE, WNORM +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE, DLANKY + EXTERNAL LSAME, DLAMCH, DLANGE, DLANKY +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLARFYK, DLASET, DORM2L, DORM2R, + $ DSYR, DKYR2 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, DBLE +* .. +* .. Executable Statements .. +* + RESULT( 1 ) = ZERO + IF( ITYPE.EQ.1 ) + $ RESULT( 2 ) = ZERO + IF( N.LE.0 ) + $ RETURN +* + IF( LSAME( UPLO, 'U' ) ) THEN + LOWER = .FALSE. + CUPLO = 'U' + ELSE + LOWER = .TRUE. + CUPLO = 'L' + END IF +* + UNFL = DLAMCH( 'Safe minimum' ) + ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) +* +* Some Error Checks +* + IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN + RESULT( 1 ) = TEN / ULP + RETURN + END IF +* +* Do Test 1 +* +* Norm of A: +* + IF( ITYPE.EQ.3 ) THEN + ANORM = ONE + ELSE + ANORM = MAX( DLANKY( '1', CUPLO, N, A, LDA, WORK ), UNFL ) + END IF +* +* Compute error matrix: +* + IF( ITYPE.EQ.1 ) THEN +* +* ITYPE=1: error = A - U S U**T +* + CALL DLASET( 'Full', N, N, ZERO, ZERO, WORK, N ) + CALL DLACPY( CUPLO, N, N, A, LDA, WORK, N ) +* + IF( N.GT.1 .AND. KBAND.EQ.1 ) THEN + DO 20 J = 1, N - 1 + CALL DKYR2( CUPLO, N, -E( J ), U( 1, J ), 1, + $ U( 1, J+1 ), 1, WORK, N ) + 20 CONTINUE + END IF + WNORM = DLANKY( '1', CUPLO, N, WORK, N, WORK( N**2+1 ) ) +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* ITYPE=2: error = V S V**T - A +* + CALL DLASET( 'Full', N, N, ZERO, ZERO, WORK, N ) +* + IF( LOWER ) THEN + WORK( N**2 ) = ZERO + DO 40 J = N - 1, 1, -1 + IF( KBAND.EQ.1 ) THEN + WORK( ( N+1 )*( J-1 )+2 ) = ( ONE-TAU( J ) )*E( J ) + DO 30 JR = J + 2, N + WORK( ( J-1 )*N+JR ) = -TAU( J )*E( J )*V( JR, J ) + 30 CONTINUE + END IF +* + VSAVE = V( J+1, J ) + V( J+1, J ) = ONE + CALL DLARFYK( 'L', N-J, V( J+1, J ), 1, TAU( J ), + $ WORK( ( N+1 )*J+1 ), N, WORK( N**2+1 ) ) + V( J+1, J ) = VSAVE + WORK( ( N+1 )*( J-1 )+1 ) = ZERO + 40 CONTINUE + ELSE + WORK( 1 ) = ZERO + DO 60 J = 1, N - 1 + IF( KBAND.EQ.1 ) THEN + WORK( ( N+1 )*J ) = ( ONE-TAU( J ) )*E( J ) + DO 50 JR = 1, J - 1 + WORK( J*N+JR ) = -TAU( J )*E( J )*V( JR, J+1 ) + 50 CONTINUE + END IF +* + VSAVE = V( J, J+1 ) + V( J, J+1 ) = ONE + CALL DLARFYK( 'U', J, V( 1, J+1 ), 1, TAU( J ), WORK, N, + $ WORK( N**2+1 ) ) + V( J, J+1 ) = VSAVE + WORK( ( N+1 )*J+1 ) = ZERO + 60 CONTINUE + END IF +* + DO 90 JCOL = 1, N + IF( LOWER ) THEN + DO 70 JROW = JCOL+1, N + WORK( JROW+N*( JCOL-1 ) ) = WORK( JROW+N*( JCOL-1 ) ) + $ - A( JROW, JCOL ) + 70 CONTINUE + ELSE + DO 80 JROW = 1, JCOL-1 + WORK( JROW+N*( JCOL-1 ) ) = WORK( JROW+N*( JCOL-1 ) ) + $ - A( JROW, JCOL ) + 80 CONTINUE + END IF + 90 CONTINUE + WNORM = DLANKY( '1', CUPLO, N, WORK, N, WORK( N**2+1 ) ) +* + ELSE IF( ITYPE.EQ.3 ) THEN +* +* ITYPE=3: error = U V**T - I +* + IF( N.LT.2 ) + $ RETURN + CALL DLACPY( ' ', N, N, U, LDU, WORK, N ) + IF( LOWER ) THEN + CALL DORM2R( 'R', 'T', N, N-1, N-1, V( 2, 1 ), LDV, TAU, + $ WORK( N+1 ), N, WORK( N**2+1 ), IINFO ) + ELSE + CALL DORM2L( 'R', 'T', N, N-1, N-1, V( 1, 2 ), LDV, TAU, + $ WORK, N, WORK( N**2+1 ), IINFO ) + END IF + IF( IINFO.NE.0 ) THEN + RESULT( 1 ) = TEN / ULP + RETURN + END IF +* + DO 100 J = 1, N + WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE + 100 CONTINUE +* + WNORM = DLANGE( '1', N, N, WORK, N, WORK( N**2+1 ) ) + END IF +* + IF( ANORM.GT.WNORM ) THEN + RESULT( 1 ) = ( WNORM / ANORM ) / ( N*ULP ) + ELSE + IF( ANORM.LT.ONE ) THEN + RESULT( 1 ) = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP ) + ELSE + RESULT( 1 ) = MIN( WNORM / ANORM, DBLE( N ) ) / ( N*ULP ) + END IF + END IF +* +* Do Test 2 +* +* Compute U U**T - I +* + IF( ITYPE.EQ.1 ) THEN + CALL DGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK, + $ N ) +* + DO 110 J = 1, N + WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE + 110 CONTINUE +* + RESULT( 2 ) = MIN( DLANGE( '1', N, N, WORK, N, + $ WORK( N**2+1 ) ), DBLE( N ) ) / ( N*ULP ) + END IF +* + RETURN +* +* End of DKYT21 +* + END diff --git a/TESTING/EIG/dlarfyk.f b/TESTING/EIG/dlarfyk.f new file mode 100644 index 000000000..87a804fa0 --- /dev/null +++ b/TESTING/EIG/dlarfyk.f @@ -0,0 +1,158 @@ +*> \brief \b DLARFYK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DLARFYK( UPLO, N, V, INCV, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INCV, LDC, N +* DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. +* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARFYK applies an elementary reflector, or Householder matrix, H, +*> to an n x n skew-symmetric matrix C, from both the left and the right. +*> +*> H is represented in the form +*> +*> H = I - tau * v * v' +*> +*> where tau is a scalar and v is a vector. +*> +*> If tau is zero, then H is taken to be the unit matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> skew-symmetric matrix C is stored. +*> = 'U': Upper triangle +*> = 'L': Lower triangle +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension +*> (1 + (N-1)*abs(INCV)) +*> The vector v as described above. +*> \endverbatim +*> +*> \param[in] INCV +*> \verbatim +*> INCV is INTEGER +*> The increment between successive elements of v. INCV must +*> not be zero. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION +*> The value tau as described above. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC, N) +*> On entry, the matrix C. +*> On exit, C is overwritten by H * C * H'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max( 1, N ). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_eig +* +* ===================================================================== + SUBROUTINE DLARFYK( UPLO, N, V, INCV, TAU, C, LDC, WORK ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INCV, LDC, N + DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO, HALF + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, HALF = 0.5D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION ALPHA +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DKYMV, DKYR2 +* .. +* .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +* .. +* .. Executable Statements .. +* + IF( TAU.EQ.ZERO ) + $ RETURN +* +* Form w:= C * v +* + CALL DKYMV( UPLO, N, ONE, C, LDC, V, INCV, ZERO, WORK, 1 ) +* + ALPHA = -HALF*TAU*DDOT( N, WORK, 1, V, INCV ) + CALL DAXPY( N, ALPHA, V, INCV, WORK, 1 ) +* +* C := C - v * w' - w * v' +* + CALL DKYR2( UPLO, N, -TAU, V, INCV, WORK, 1, C, LDC ) +* + RETURN +* +* End of DLARFYK +* + END diff --git a/TESTING/EIG/schkee.F b/TESTING/EIG/schkee.F index bf04b5e5b..4b24c3f90 100644 --- a/TESTING/EIG/schkee.F +++ b/TESTING/EIG/schkee.F @@ -27,6 +27,9 @@ *> and drivers SSYEV(X), SSBEV(X), SSPEV(X), SSTEV(X), *> SSYEVD, SSBEVD, SSPEVD, SSTEVD *> +*> KEP (Skew-symmetric Eigenvalue Problem): +*> Test SKYTRD, SSTEQR, and driver SSYEV, SSTEV +*> *> SVD (Singular Value Decomposition): *> Test SGEBRD, SORGBR, SBDSQR, SBDSDC *> and the drivers SGESVD, SGESDD @@ -62,6 +65,9 @@ *> Test SSYGST, SSYGV, SSYGVD, SSYGVX, SSPGST, SSPGV, SSPGVD, *> SSPGVX, SSBGST, SSBGV, SSBGVD, and SSBGVX *> +*> SKG (Skew-symmetric Generalized Eigenvalue Problem): +*> Test SKYGST, SKYGV +*> *> SSB (Symmetric Band Eigenvalue Problem): *> Test SSBTRD *> @@ -114,6 +120,8 @@ *> SHS or NEP 21 SCHKHS *> SST or SEP 21 SCHKST (routines) *> 18 SDRVST (drivers) +*> SKT or KEP 21 SCHKKT (routines) +*> 18 SDRVKT (drivers) *> SBD or SVD 16 SCHKBD (routines) *> 5 SDRVBD (drivers) *> SEV 21 SDRVEV @@ -126,6 +134,7 @@ *> SGV 26 SDRGEV *> SXV 2 SDRGVX *> SSG 21 SDRVSG +*> SKG 21 SDRVKG *> SSB 15 SCHKSB *> SBB 15 SCHKBB *> SEC - SCHKEC @@ -215,7 +224,7 @@ *> *>----------------------------------------------------------------------- *> -*> SEP or SSG input file: +*> SEP, KEP, SSG or SKG input file: *> *> line 2: NN, INTEGER *> Number of values of N. @@ -263,9 +272,9 @@ *> Four integer values for the random number seed. *> *> lines 13-EOF: Lines specifying matrix types, as for NEP. -*> The 3-character path names are 'SEP' or 'SST' for the -*> symmetric eigenvalue routines and driver routines, and -*> 'SSG' for the routines for the symmetric generalized +*> The 3-character path names are 'SEP', 'KEP', 'SST' or 'SKT' for +*> the (skew-)symmetric eigenvalue routines and driver routines, +*> and 'SSG', 'SKG' for the routines for the (skew-)symmetric generalized *> eigenvalue problem. *> *>----------------------------------------------------------------------- @@ -1068,9 +1077,9 @@ PROGRAM SCHKEE * .. * .. Local Scalars .. LOGICAL CSD, FATAL, GLM, GQR, GSV, LSE, NEP, SBB, SBK, - $ SBL, SEP, SES, SEV, SGG, SGK, SGL, SGS, SGV, - $ SGX, SSB, SSX, SVD, SVX, SXV, TSTCHK, TSTDIF, - $ TSTDRV, TSTERR + $ SBL, SEP, KEP, SES, SEV, SGG, SGK, SGL, SGS, + $ SGV, SGX, SSB, SSX, SVD, SVX, SXV, TSTCHK, + $ TSTDIF, TSTDRV, TSTERR CHARACTER C1 CHARACTER*3 C3, PATH CHARACTER*32 VNAME @@ -1111,7 +1120,7 @@ PROGRAM SCHKEE $ SDRGEV, SDRGSX, SDRGVX, SDRVBD, SDRVES, SDRVEV, $ SDRVSG, SDRVST, SDRVSX, SDRVVX, SERRBD, $ SERRED, SERRGG, SERRHS, SERRST, ILAVER, XLAENV, - $ SDRGES3, SDRGEV3, + $ SDRGES3, SDRGEV3, SERRKT, SCHKKT, SDRVKT, $ SCHKST2STG, SDRVST2STG, SCHKSB2STG, SDRVSG2STG * .. * .. Intrinsic Functions .. @@ -1171,6 +1180,8 @@ PROGRAM SCHKEE NEP = LSAMEN( 3, PATH, 'NEP' ) .OR. LSAMEN( 3, PATH, 'SHS' ) SEP = LSAMEN( 3, PATH, 'SEP' ) .OR. LSAMEN( 3, PATH, 'SST' ) .OR. $ LSAMEN( 3, PATH, 'SSG' ) .OR. LSAMEN( 3, PATH, 'SE2' ) + KEP = LSAMEN( 3, PATH, 'KEP' ) .OR. LSAMEN( 3, PATH, 'SKT' ) .OR. + $ LSAMEN( 3, PATH, 'SKG' ) SVD = LSAMEN( 3, PATH, 'SVD' ) .OR. LSAMEN( 3, PATH, 'DBD' ) SVD = LSAMEN( 3, PATH, 'SVD' ) .OR. LSAMEN( 3, PATH, 'SBD' ) SEV = LSAMEN( 3, PATH, 'SEV' ) @@ -1202,6 +1213,8 @@ PROGRAM SCHKEE WRITE( NOUT, FMT = 9987 ) ELSE IF( SEP ) THEN WRITE( NOUT, FMT = 9986 ) + ELSE IF( KEP ) THEN + WRITE( NOUT, FMT = 9959 ) ELSE IF( SVD ) THEN WRITE( NOUT, FMT = 9985 ) ELSE IF( SEV ) THEN @@ -1493,7 +1506,7 @@ PROGRAM SCHKEE * * Read the values of NBMIN * - IF( NEP .OR. SEP .OR. SVD .OR. SGG ) THEN + IF( NEP .OR. SEP .OR. KEP .OR. SVD .OR. SGG ) THEN READ( NIN, FMT = * )( NBMIN( I ), I = 1, NPARMS ) DO 80 I = 1, NPARMS IF( NBMIN( I ).LT.0 ) THEN @@ -1514,7 +1527,7 @@ PROGRAM SCHKEE * * Read the values of NX * - IF( NEP .OR. SEP .OR. SVD ) THEN + IF( NEP .OR. SEP .OR. KEP .OR. SVD ) THEN READ( NIN, FMT = * )( NXVAL( I ), I = 1, NPARMS ) DO 100 I = 1, NPARMS IF( NXVAL( I ).LT.0 ) THEN @@ -1702,7 +1715,7 @@ PROGRAM SCHKEE * READ( NIN, FMT = * )THRESH WRITE( NOUT, FMT = 9982 )THRESH - IF( SEP .OR. SVD .OR. SGG ) THEN + IF( SEP .OR. KEP .OR. SVD .OR. SGG ) THEN * * Read the flag that indicates whether to test LAPACK routines. * @@ -1937,6 +1950,67 @@ PROGRAM SCHKEE $ WRITE( NOUT, FMT = 9980 )'SDRVST', INFO END IF 290 CONTINUE +* + ELSE IF( LSAMEN( 3, C3, 'SKT' ) .OR. LSAMEN( 3, C3, 'KEP' ) ) THEN +* +* ---------------------------------- +* KEP: Skew-symmetric Eigenvalue Problem +* ---------------------------------- +* Vary the parameters +* NB = block size +* NBMIN = minimum block size +* NX = crossover point +* + MAXTYP = 21 + NTYPES = MIN( MAXTYP, NTYPES ) + CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT ) + CALL XLAENV( 1, 1 ) + CALL XLAENV( 9, 25 ) + IF( TSTERR ) THEN +#if defined(_OPENMP) + N_THREADS = OMP_GET_MAX_THREADS() + ONE_THREAD = 1 + CALL OMP_SET_NUM_THREADS(ONE_THREAD) +#endif + CALL SERRKT( 'SKT', NOUT ) +#if defined(_OPENMP) + CALL OMP_SET_NUM_THREADS(N_THREADS) +#endif + END IF + DO 400 I = 1, NPARMS + CALL XLAENV( 1, NBVAL( I ) ) + CALL XLAENV( 2, NBMIN( I ) ) + CALL XLAENV( 3, NXVAL( I ) ) +* + IF( NEWSD.EQ.0 ) THEN + DO 390 K = 1, 4 + ISEED( K ) = IOLDSD( K ) + 390 CONTINUE + END IF + WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ), + $ NXVAL( I ) + IF( TSTCHK ) THEN + CALL SCHKKT( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), D( 1, 1 ), + $ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), D( 1, 5 ), + $ D( 1, 6 ), D( 1, 7 ), D( 1, 8 ), D( 1, 9 ), + $ D( 1, 10 ), D( 1, 11 ), A( 1, 3 ), NMAX, + $ A( 1, 4 ), A( 1, 5 ), D( 1, 12 ), A( 1, 6 ), + $ WORK, LWORK, IWORK, LIWORK, RESULT, INFO ) + IF( INFO.NE.0 ) + $ WRITE( NOUT, FMT = 9980 )'SCHKKT', INFO + END IF + IF( TSTDRV ) THEN + CALL SDRVKT( NN, NVAL, 18, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, D( 1, 3 ), D( 1, 4 ), + $ D( 1, 5 ), D( 1, 6 ), D( 1, 8 ), D( 1, 9 ), + $ D( 1, 10 ), D( 1, 11), A( 1, 2 ), NMAX, + $ A( 1, 3 ), D( 1, 12 ), A( 1, 4 ), WORK, + $ LWORK, IWORK, LIWORK, RESULT, INFO ) + IF( INFO.NE.0 ) + $ WRITE( NOUT, FMT = 9980 )'SDRVKT', INFO + END IF + 400 CONTINUE * ELSE IF( LSAMEN( 3, C3, 'SSG' ) ) THEN * @@ -1980,6 +2054,49 @@ PROGRAM SCHKEE $ WRITE( NOUT, FMT = 9980 )'SDRVSG', INFO END IF 310 CONTINUE +* + ELSE IF( LSAMEN( 3, C3, 'SKG' ) ) THEN +* +* ---------------------------------------------- +* SKG: Skew-symmetric Generalized Eigenvalue Problem +* ---------------------------------------------- +* Vary the parameters +* NB = block size +* NBMIN = minimum block size +* NX = crossover point +* + MAXTYP = 21 + NTYPES = MIN( MAXTYP, NTYPES ) + CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT ) + CALL XLAENV( 9, 25 ) + DO 420 I = 1, NPARMS + CALL XLAENV( 1, NBVAL( I ) ) + CALL XLAENV( 2, NBMIN( I ) ) + CALL XLAENV( 3, NXVAL( I ) ) +* + IF( NEWSD.EQ.0 ) THEN + DO 410 K = 1, 4 + ISEED( K ) = IOLDSD( K ) + 410 CONTINUE + END IF + WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ), + $ NXVAL( I ) + IF( TSTCHK ) THEN +* CALL SDRVSG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, +* $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, +* $ D( 1, 3 ), A( 1, 3 ), NMAX, A( 1, 4 ), +* $ A( 1, 5 ), A( 1, 6 ), A( 1, 7 ), WORK, +* $ LWORK, IWORK, LIWORK, RESULT, INFO ) + CALL SDRVKG2STG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, + $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX, + $ D( 1, 3 ), D( 1, 3 ), A( 1, 3 ), NMAX, + $ A( 1, 4 ), A( 1, 5 ), A( 1, 6 ), + $ A( 1, 7 ), WORK, LWORK, IWORK, LIWORK, + $ RESULT, INFO ) + IF( INFO.NE.0 ) + $ WRITE( NOUT, FMT = 9980 )'SDRVSG', INFO + END IF + 420 CONTINUE * ELSE IF( LSAMEN( 3, C3, 'SBD' ) .OR. LSAMEN( 3, C3, 'SVD' ) ) THEN * @@ -2534,6 +2651,8 @@ PROGRAM SCHKEE $ ', INWIN =', I4, ', INIBL =', I4, ', ISHFTS =', I4, $ ', IACC22 =', I4) 9960 FORMAT( / ' Tests of the CS Decomposition routines' ) + 9959 FORMAT( ' Tests of the Skew-symmetric Eigenvalue Problem ', + $ 'routines' ) * * End of SCHKEE * diff --git a/TESTING/EIG/schkkt.f b/TESTING/EIG/schkkt.f new file mode 100644 index 000000000..56b61467b --- /dev/null +++ b/TESTING/EIG/schkkt.f @@ -0,0 +1,1096 @@ +*> \brief \b SCHKKT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SCHKKT( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, +* WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, +* LWORK, IWORK, LIWORK, RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, +* $ NTYPES +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* REAL A( LDA, * ), AP( * ), D1( * ), D2( * ), +* $ D3( * ), D4( * ), D5( * ), RESULT( * ), +* $ SD( * ), SE( * ), TAU( * ), U( LDU, * ), +* $ V( LDU, * ), VP( * ), WA1( * ), WA2( * ), +* $ WA3( * ), WORK( * ), WR( * ), Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SCHKKT checks the skew-symmetric eigenvalue problem routines. +*> +*> SKYTRD factors A as U S U' , where ' means transpose, +*> S is skew-symmetric tridiagonal, and U is orthogonal. +*> SKYTRD can use either just the lower or just the upper triangle +*> of A; SCHKKT checks both cases. +*> U is represented as a product of Householder +*> transformations, whose vectors are stored in the first +*> n-1 columns of V, and whose scale factors are in TAU. +*> +*> SKTEQR factors S as Z D1 Z' , where Z is the orthogonal +*> matrix of eigenvectors and D1 is a diagonal matrix with +*> the eigenvalues on the diagonal. D2 is the matrix of +*> eigenvalues computed when Z is not computed. +*> +*> When SCHKKT is called, a number of matrix "sizes" ("n's") and a +*> number of matrix "types" are specified. For each size ("n") +*> and each type of matrix, one matrix will be generated and used +*> to test the skew-symmetric eigenroutines. For each matrix, a +*> number of tests will be performed: +*> +*> (1) | A - V S V' | / ( |A| n ulp ) SKYTRD( UPLO='U', ... ) +*> +*> (2) | I - UV' | / ( n ulp ) SORGTR( UPLO='U', ... ) +*> +*> (3) | A - V S V' | / ( |A| n ulp ) SKYTRD( UPLO='L', ... ) +*> +*> (4) | I - UV' | / ( n ulp ) SORGTR( UPLO='L', ... ) +*> +*> (5-8) Same as 1-4, but for SSPTRD and SOPGTR. +*> +*> (9) | S - Z D Z' | / ( |S| n ulp ) SKTEQR('V',...) +*> +*> (10) | I - ZZ' | / ( n ulp ) SKTEQR('V',...) +*> +*> (11) | D1 - D2 | / ( |D1| ulp ) SKTEQR('N',...) +*> +*> (12) | D1 - D3 | / ( |D1| ulp ) SSTERF +*> +*> (13) 0 if the true eigenvalues (computed by sturm count) +*> of S are within THRESH of +*> those in D1. 2*THRESH if they are not. (Tested using +*> SSTECH) +*> +*> For S positive definite, +*> +*> (14) | S - Z4 D4 Z4' | / ( |S| n ulp ) SPTEQR('V',...) +*> +*> (15) | I - Z4 Z4' | / ( n ulp ) SPTEQR('V',...) +*> +*> (16) | D4 - D5 | / ( 100 |D4| ulp ) SPTEQR('N',...) +*> +*> When S is also diagonally dominant by the factor gamma < 1, +*> +*> (17) max | D4(i) - WR(i) | / ( |D4(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> SSTEBZ( 'A', 'E', ...) +*> +*> (18) | WA1 - D3 | / ( |D3| ulp ) SSTEBZ( 'A', 'E', ...) +*> +*> (19) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> SSTEBZ( 'I', 'E', ...) +*> +*> (20) | S - Y WA1 Y' | / ( |S| n ulp ) SSTEBZ, SSTEIN +*> +*> (21) | I - Y Y' | / ( n ulp ) SSTEBZ, SSTEIN +*> +*> (22) | S - Z D Z' | / ( |S| n ulp ) SSTEDC('I') +*> +*> (23) | I - ZZ' | / ( n ulp ) SSTEDC('I') +*> +*> (24) | S - Z D Z' | / ( |S| n ulp ) SSTEDC('V') +*> +*> (25) | I - ZZ' | / ( n ulp ) SSTEDC('V') +*> +*> (26) | D1 - D2 | / ( |D1| ulp ) SSTEDC('V') and +*> SSTEDC('N') +*> +*> Test 27 is disabled at the moment because SSTEMR does not +*> guarantee high relatvie accuracy. +*> +*> (27) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> SSTEMR('V', 'A') +*> +*> (28) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , +*> i +*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 +*> SSTEMR('V', 'I') +*> +*> Tests 29 through 34 are disable at present because SSTEMR +*> does not handle partial spectrum requests. +*> +*> (29) | S - Z D Z' | / ( |S| n ulp ) SSTEMR('V', 'I') +*> +*> (30) | I - ZZ' | / ( n ulp ) SSTEMR('V', 'I') +*> +*> (31) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> SSTEMR('N', 'I') vs. SSTEMR('V', 'I') +*> +*> (32) | S - Z D Z' | / ( |S| n ulp ) SSTEMR('V', 'V') +*> +*> (33) | I - ZZ' | / ( n ulp ) SSTEMR('V', 'V') +*> +*> (34) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> SSTEMR('N', 'V') vs. SSTEMR('V', 'V') +*> +*> (35) | S - Z D Z' | / ( |S| n ulp ) SSTEMR('V', 'A') +*> +*> (36) | I - ZZ' | / ( n ulp ) SSTEMR('V', 'A') +*> +*> (37) ( max { min | WA2(i)-WA3(j) | } + +*> i j +*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) +*> i j +*> SSTEMR('N', 'A') vs. SSTEMR('V', 'A') +*> +*> The "sizes" are specified by an array NN(1:NSIZES); the value of +*> each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); +*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP +*> and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U' D U, where U is orthogonal and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U' D U, where U is orthogonal and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U' D U, where U is orthogonal and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) Symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> (16) Same as (8), but diagonal elements are all positive. +*> (17) Same as (9), but diagonal elements are all positive. +*> (18) Same as (10), but diagonal elements are all positive. +*> (19) Same as (16), but multiplied by SQRT( overflow threshold ) +*> (20) Same as (16), but multiplied by SQRT( underflow threshold ) +*> (21) A diagonally dominant tridiagonal matrix with geometrically +*> spaced diagonal entries 1, ..., ULP. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] NSIZES +*> \verbatim +*> NSIZES is INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> SCHKKT does nothing. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. The values must be at least +*> zero. +*> \endverbatim +*> +*> \param[in] NTYPES +*> \verbatim +*> NTYPES is INTEGER +*> The number of elements in DOTYPE. If it is zero, SCHKKT +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> \endverbatim +*> +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> \endverbatim +*> +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to SCHKKT to continue the same random number +*> sequence. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is REAL +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error +*> is scaled to be O(1), so THRESH should be a reasonably +*> small multiple of 1, e.g., 10 or 100. In particular, +*> it should not depend on the precision (single vs. double) +*> or the size of the matrix. It must be at least zero. +*> \endverbatim +*> +*> \param[in] NOUNIT +*> \verbatim +*> NOUNIT is INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array of +*> dimension ( LDA , max(NN) ) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> \endverbatim +*> +*> \param[out] AP +*> \verbatim +*> AP is REAL array of +*> dimension( max(NN)*max(NN+1)/2 ) +*> The matrix A stored in packed format. +*> \endverbatim +*> +*> \param[out] SD +*> \verbatim +*> SD is REAL array of +*> dimension( max(NN) ) +*> The diagonal of the tridiagonal matrix computed by SKYTRD. +*> On exit, SD and SE contain the tridiagonal form of the +*> matrix in A. +*> \endverbatim +*> +*> \param[out] SE +*> \verbatim +*> SE is REAL array of +*> dimension( max(NN) ) +*> The off-diagonal of the tridiagonal matrix computed by +*> SKYTRD. On exit, SD and SE contain the tridiagonal form of +*> the matrix in A. +*> \endverbatim +*> +*> \param[out] D1 +*> \verbatim +*> D1 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by SKTEQR simlutaneously +*> with Z. On exit, the eigenvalues in D1 correspond with the +*> matrix in A. +*> \endverbatim +*> +*> \param[out] D2 +*> \verbatim +*> D2 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by SKTEQR if Z is not +*> computed. On exit, the eigenvalues in D2 correspond with +*> the matrix in A. +*> \endverbatim +*> +*> \param[out] D3 +*> \verbatim +*> D3 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by SSTERF. On exit, the +*> eigenvalues in D3 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] D4 +*> \verbatim +*> D4 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by SPTEQR(V). +*> ZPTEQR factors S as Z4 D4 Z4* +*> On exit, the eigenvalues in D4 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] D5 +*> \verbatim +*> D5 is REAL array of +*> dimension( max(NN) ) +*> The eigenvalues of A, as computed by SPTEQR(N) +*> when Z is not computed. On exit, the +*> eigenvalues in D4 correspond with the matrix in A. +*> \endverbatim +*> +*> \param[out] WA1 +*> \verbatim +*> WA1 is REAL array of +*> dimension( max(NN) ) +*> All eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by SSTEBZ. +*> \endverbatim +*> +*> \param[out] WA2 +*> \verbatim +*> WA2 is REAL array of +*> dimension( max(NN) ) +*> Selected eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by SSTEBZ. +*> Choose random values for IL and IU, and ask for the +*> IL-th through IU-th eigenvalues. +*> \endverbatim +*> +*> \param[out] WA3 +*> \verbatim +*> WA3 is REAL array of +*> dimension( max(NN) ) +*> Selected eigenvalues of A, computed to high +*> absolute accuracy, with different range options. +*> as computed by SSTEBZ. +*> Determine the values VL and VU of the IL-th and IU-th +*> eigenvalues and ask for all eigenvalues in this range. +*> \endverbatim +*> +*> \param[out] WR +*> \verbatim +*> WR is REAL array of +*> dimension( max(NN) ) +*> All eigenvalues of A, computed to high +*> absolute accuracy, with different options. +*> as computed by SSTEBZ. +*> \endverbatim +*> +*> \param[out] U +*> \verbatim +*> U is REAL array of +*> dimension( LDU, max(NN) ). +*> The orthogonal matrix computed by SKYTRD + SORGTR. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of U, Z, and V. It must be at least 1 +*> and at least max( NN ). +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is REAL array of +*> dimension( LDU, max(NN) ). +*> The Housholder vectors computed by SKYTRD in reducing A to +*> tridiagonal form. The vectors computed with UPLO='U' are +*> in the upper triangle, and the vectors computed with UPLO='L' +*> are in the lower triangle. (As described in SKYTRD, the +*> sub- and superdiagonal are not set to 1, although the +*> true Householder vector has a 1 in that position. The +*> routines that use V, such as SORGTR, set those entries to +*> 1 before using them, and then restore them later.) +*> \endverbatim +*> +*> \param[out] VP +*> \verbatim +*> VP is REAL array of +*> dimension( max(NN)*max(NN+1)/2 ) +*> The matrix V stored in packed format. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is REAL array of +*> dimension( max(NN) ) +*> The Householder factors computed by SKYTRD in reducing A +*> to tridiagonal form. +*> \endverbatim +*> +*> \param[out] Z +*> \verbatim +*> Z is REAL array of +*> dimension( LDU, max(NN) ). +*> The orthogonal matrix of eigenvectors computed by SKTEQR, +*> SPTEQR, and SSTEIN. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array of +*> dimension( LWORK ) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The number of entries in WORK. This must be at least +*> 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 3 * Nmax**2 +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, +*> Workspace. +*> \endverbatim +*> +*> \param[out] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The number of entries in IWORK. This must be at least +*> 6 + 6*Nmax + 5 * Nmax * lg Nmax +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (26) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid +*> overflow. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -23: LDU < 1 or LDU < NMAX. +*> -29: LWORK too small. +*> If SLATMR, SLATMS, SKYTRD, SORGTR, SKTEQR, SSTERF, +*> or SORMC2 returns an error code, the +*> absolute value of it is returned. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NBLOCK Blocksize as returned by ENVIR. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far. +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup single_eig +* +* ===================================================================== + SUBROUTINE SCHKKT( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, + $ WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, + $ LWORK, IWORK, LIWORK, RESULT, INFO ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, + $ NTYPES + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + REAL A( LDA, * ), AP( * ), D1( * ), D2( * ), + $ D3( * ), D4( * ), D5( * ), RESULT( * ), + $ SD( * ), SE( * ), TAU( * ), U( LDU, * ), + $ V( LDU, * ), VP( * ), WA1( * ), WA2( * ), + $ WA3( * ), WORK( * ), WR( * ), Z( LDU, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE, TWO, EIGHT, TEN, HUN + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0, + $ EIGHT = 8.0E0, TEN = 10.0E0, HUN = 100.0E0 ) + REAL HALF + PARAMETER ( HALF = ONE / TWO ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 21 ) + LOGICAL SRANGE + PARAMETER ( SRANGE = .FALSE. ) + LOGICAL SREL + PARAMETER ( SREL = .FALSE. ) +* .. +* .. Local Scalars .. + LOGICAL BADNN, TRYRAC + INTEGER I, IINFO, IL, IMODE, ITEMP, ITYPE, IU, J, JC, + $ JR, JSIZE, JTYPE, LGN, LIWEDC, LOG2UI, LWEDC, + $ M, M2, M3, MTYPES, N, NAP, NBLOCK, NERRS, + $ NMATS, NMAX, NSPLIT, NTEST, NTESTT + REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, TEMP1, TEMP2, TEMP3, TEMP4, ULP, + $ ULPINV, UNFL, VL, VU +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) + REAL DUMMA( 1 ) +* .. +* .. External Functions .. + INTEGER ILAENV + REAL SLAMCH + EXTERNAL ILAENV, SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL SCOPY, SLABAD, SLACPY, SLASET, SLASUM, SLATMR, + $ SLATMS, SORGTR, SKTEQR, SKTT21, SKYT21, + $ SKYTRD, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, INT, LOG, MAX, MIN, REAL, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8, + $ 8, 8, 9, 9, 9, 9, 9, 10 / + DATA KMAGN / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 1, 1, 1, 2, 3, 1 / + DATA KMODE / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 4, 3, 1, 4, 4, 3 / +* .. +* .. Executable Statements .. +* +* Keep ftnchek happy + IDUMMA( 1 ) = 1 +* +* Check for errors +* + NTESTT = 0 + INFO = 0 +* +* Important constants +* + BADNN = .FALSE. + TRYRAC = .TRUE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* + NBLOCK = ILAENV( 1, 'SKYTRD', 'L', NMAX, -1, -1, -1 ) + NBLOCK = MIN( NMAX, MAX( 1, NBLOCK ) ) +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -23 + ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN + INFO = -29 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SCHKKT', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = SLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL SLABAD( UNFL, OVFL ) + ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) + ULPINV = ONE / ULP + LOG2UI = INT( LOG( ULPINV ) / LOG( TWO ) ) + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + 20 CONTINUE + NERRS = 0 + NMATS = 0 +* + DO 310 JSIZE = 1, NSIZES + N = NN( JSIZE ) + IF( N.GT.0 ) THEN + LGN = INT( LOG( REAL( N ) ) / LOG( TWO ) ) + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + LWEDC = 1 + 4*N + 2*N*LGN + 4*N**2 + LIWEDC = 6 + 6*N + 5*N*LGN + ELSE + LWEDC = 8 + LIWEDC = 12 + END IF + NAP = ( N*( N+1 ) ) / 2 + ANINV = ONE / REAL( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 300 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 300 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log symmetric, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random symmetric +* =9 positive definite +* =10 diagonally dominant tridiagonal +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 100 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + IINFO = 0 + IF( JTYPE.LE.15 ) THEN + COND = ULPINV + ELSE + COND = ULPINV*ANINV / TEN + END IF +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JC = 1, N + A( JC, JC ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* tridiagonal Matrix, [Eigen]values Specified +* + CALL SLATMS( N, N, 'S', ISEED, 'K', WORK, IMODE, COND, + $ ANORM, 1, 1, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* skew-ymmetric, eigenvalues specified +* + CALL SLATMS( N, N, 'S', ISEED, 'K', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* tridiagonal, random eigenvalues +* + CALL SLATMR( N, N, 'S', ISEED, 'K', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 1, 1, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* skew-ymmetric, random eigenvalues +* + CALL SLATMR( N, N, 'S', ISEED, 'K', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* skew-ymmetric, eigenvalues specified. +* + CALL SLATMS( N, N, 'S', ISEED, 'K', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.10 ) THEN +* +* skew-ymmetric tridiagonal, eigenvalues specified. +* + CALL SLATMS( N, N, 'S', ISEED, 'K', WORK, IMODE, COND, + $ ANORM, 1, 1, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) + DO 90 I = 2, N + TEMP1 = ABS( A( I-1, I ) ) / + $ SQRT( ABS( A( I-1, I-1 )*A( I, I ) ) ) + IF( TEMP1.GT.HALF ) THEN + A( I-1, I ) = HALF*SQRT( ABS( A( I-1, I-1 )*A( I, + $ I ) ) ) + A( I, I-1 ) = A( I-1, I ) + END IF + 90 CONTINUE +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 100 CONTINUE +* +* Call SKYTRD and SORGTR to compute S and U from +* upper triangle. +* + CALL SLACPY( 'U', N, N, A, LDA, V, LDU ) +* + NTEST = 1 + CALL SKYTRD( 'U', N, V, LDU, SE, TAU, WORK, LWORK, + $ IINFO ) + CALL SLASET( 'N', N, 1, ZERO, ZERO, SD, N) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SKYTRD(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL SLACPY( 'U', N, N, V, LDU, U, LDU ) +* + NTEST = 2 + CALL SORGTR( 'U', N, U, LDU, TAU, WORK, LWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SORGTR(U)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 2 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 1 and 2 +* + CALL SKYT21( 2, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RESULT( 1 ) ) + CALL SKYT21( 3, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RESULT( 2 ) ) +* +* Call SKYTRD and SORGTR to compute S and U from +* lower triangle, do tests. +* + CALL SLACPY( 'L', N, N, A, LDA, V, LDU ) +* + NTEST = 3 + CALL SKYTRD( 'L', N, V, LDU, SE, TAU, WORK, LWORK, + $ IINFO ) + CALL SLASET( 'N', N, 1, ZERO, ZERO, SD, N) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SKYTRD(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 280 + END IF + END IF +* + CALL SLACPY( 'L', N, N, V, LDU, U, LDU ) +* + NTEST = 4 + CALL SORGTR( 'L', N, U, LDU, TAU, WORK, LWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SORGTR(L)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 4 ) = ULPINV + GO TO 280 + END IF + END IF +* +* Do tests 3 and 4 +* + CALL SKYT21( 2, 'Lower', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RESULT( 3 ) ) + CALL SKYT21( 3, 'Lower', N, 1, A, LDA, SD, SE, U, LDU, V, + $ LDU, TAU, WORK, RESULT( 4 ) ) +* +* Call SKTEQR to compute D1, D2, and Z, do tests. +* +* Compute D1 and Z +* + CALL SCOPY( N, SD, 1, D1, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) + CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDU ) +* + NTEST = 5 + CALL SKTEQR( 'V', N, WORK, Z, LDU, WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SKTEQR(V)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 5 ) = ULPINV + GO TO 280 + END IF + END IF + IF( N.GT.0 ) + $ CALL SCOPY( N-1, WORK, 1, D1, 1 ) +* +* Compute D2 +* + CALL SCOPY( N, SD, 1, D2, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + NTEST = 7 + CALL SKTEQR( 'N', N, WORK, WORK( N+1 ), LDU, + $ WORK( N+1 ), IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SKTEQR(N)', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 6 ) = ULPINV + GO TO 280 + END IF + END IF + IF( N.GT.0 ) + $ CALL SCOPY( N-1, WORK, 1, D2, 1 ) +* +* Do Tests 5 and 6 +* + CALL SKTT21( N, 1, DUMMA, SE, DUMMA, D1, Z, LDU, WORK, + $ RESULT( 5 ) ) +* +* Do Tests 7 +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 150 J = 1, N-1 + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) + 150 CONTINUE +* + RESULT( 7 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) +* + 280 CONTINUE + NTESTT = NTESTT + NTEST +* +* End of Loop -- Check for RESULT(j) > THRESH +* +* +* Print out tests which fail. +* + DO 290 JR = 1, NTEST + IF( RESULT( JR ).GE.THRESH ) THEN +* +* If this is the first test to fail, +* print a header to the data file. +* + IF( NERRS.EQ.0 ) THEN + WRITE( NOUNIT, FMT = 9998 )'SKT' + WRITE( NOUNIT, FMT = 9997 ) + WRITE( NOUNIT, FMT = 9996 ) + WRITE( NOUNIT, FMT = 9995 )'Skew-symmetric' + WRITE( NOUNIT, FMT = 9994 ) +* +* Tests performed +* + WRITE( NOUNIT, FMT = 9988 ) + END IF + NERRS = NERRS + 1 + WRITE( NOUNIT, FMT = 9990 )N, IOLDSD, JTYPE, JR, + $ RESULT( JR ) + END IF + 290 CONTINUE + 300 CONTINUE + 310 CONTINUE +* +* Summary +* + CALL SLASUM( 'SKT', NOUNIT, NERRS, NTESTT ) + RETURN +* + 9999 FORMAT( ' SCHKKT: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', + $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* + 9998 FORMAT( / 1X, A3, ' -- Real Skew-symmetric eigenvalue problem' ) + 9997 FORMAT( ' Matrix types (see SCHKKT for details): ' ) +* + 9996 FORMAT( / ' Special Matrices:', + $ / ' 1=Zero matrix. ', + $ ' 5=Diagonal: clustered entries.', + $ / ' 2=Identity matrix. ', + $ ' 6=Diagonal: large, evenly spaced.', + $ / ' 3=Diagonal: evenly spaced entries. ', + $ ' 7=Diagonal: small, evenly spaced.', + $ / ' 4=Diagonal: geometr. spaced entries.' ) + 9995 FORMAT( ' Dense ', A, ' Matrices:', + $ / ' 8=Evenly spaced eigenvals. ', + $ ' 12=Small, evenly spaced eigenvals.', + $ / ' 9=Geometrically spaced eigenvals. ', + $ ' 13=Matrix with random O(1) entries.', + $ / ' 10=Clustered eigenvalues. ', + $ ' 14=Matrix with large random entries.', + $ / ' 11=Large, evenly spaced eigenvals. ', + $ ' 15=Matrix with small random entries.' ) + 9994 FORMAT( ' 16=Positive definite, evenly spaced eigenvalues', + $ / ' 17=Positive definite, geometrically spaced eigenvlaues', + $ / ' 18=Positive definite, clustered eigenvalues', + $ / ' 19=Positive definite, small evenly spaced eigenvalues', + $ / ' 20=Positive definite, large evenly spaced eigenvalues', + $ / ' 21=Diagonally dominant tridiagonal, geometrically', + $ ' spaced eigenvalues' ) +* + 9990 FORMAT( ' N=', I5, ', seed=', 4( I4, ',' ), ' type ', I2, + $ ', test(', I2, ')=', G10.3 ) +* + 9988 FORMAT( / 'Test performed: see SCHKKT for details.', / ) +* End of SCHKKT +* + END diff --git a/TESTING/EIG/sdrvkg2stg.f b/TESTING/EIG/sdrvkg2stg.f new file mode 100644 index 000000000..65f255831 --- /dev/null +++ b/TESTING/EIG/sdrvkg2stg.f @@ -0,0 +1,705 @@ +*> \brief \b SDRVKG2STG +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SDRVKG2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, B, LDB, D, D2, Z, LDZ, AB, +* BB, AP, BP, WORK, NWORK, IWORK, LIWORK, +* RESULT, INFO ) +* +* IMPLICIT NONE +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDB, LDZ, LIWORK, NOUNIT, NSIZES, +* $ NTYPES, NWORK +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* REAL A( LDA, * ), AB( LDA, * ), AP( * ), +* $ B( LDB, * ), BB( LDB, * ), BP( * ), D( * ), +* $ RESULT( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SDRVKG2STG checks the real skew-symmetric generalized eigenproblem +*> drivers. +*> +*> SKYGV computes all eigenvalues and, optionally, +*> eigenvectors of a real skew-symmetric-definite generalized +*> eigenproblem. +*> +*> When SDRVKG2STG is called, a number of matrix "sizes" ("n's") and a +*> number of matrix "types" are specified. For each size ("n") +*> and each type of matrix, one matrix A of the given type will be +*> generated; a random well-conditioned matrix B is also generated +*> and the pair (A,B) is used to test the drivers. +*> +*> For each pair (A,B), the following tests are performed: +*> +*> (1) SKYGV with ITYPE = 1 and UPLO ='U': +*> +*> | A Z - B Z D | / ( |A| |Z| n ulp ) +*> | D - D2 | / ( |D| ulp ) where D is computed by +*> SKYGV and D2 is computed by +*> SKYGV_2STAGE. This test is +*> only performed for SKYGV +*> +*> (2) as (1) but calling SSPGV +*> (3) as (1) but calling SSBGV +*> (4) as (1) but with UPLO = 'L' +*> (5) as (4) but calling SSPGV +*> (6) as (4) but calling SSBGV +*> +*> (7) SKYGV with ITYPE = 2 and UPLO ='U': +*> +*> | A B Z - Z D | / ( |A| |Z| n ulp ) +*> +*> (8) as (7) but calling SSPGV +*> (9) as (7) but with UPLO = 'L' +*> (10) as (9) but calling SSPGV +*> +*> (11) SKYGV with ITYPE = 3 and UPLO ='U': +*> +*> | B A Z - Z D | / ( |A| |Z| n ulp ) +*> +*> (12) as (11) but calling SSPGV +*> (13) as (11) but with UPLO = 'L' +*> (14) as (13) but calling SSPGV +*> +*> SKYGVD, SSPGVD and SSBGVD performed the same 14 tests. +*> +*> SKYGVX, SSPGVX and SSBGVX performed the above 14 tests with +*> the parameter RANGE = 'A', 'N' and 'I', respectively. +*> +*> The "sizes" are specified by an array NN(1:NSIZES); the value +*> of each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); +*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> This type is used for the matrix A which has half-bandwidth KA. +*> B is generated as a well-conditioned positive definite matrix +*> with half-bandwidth KB (<= KA). +*> Currently, the list of possible types for A is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced entries +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced entries +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" entries +*> 1, ULP, ..., ULP and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U* D U, where U is orthogonal and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U* D U, where U is orthogonal and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U* D U, where U is orthogonal and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) skew-symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold) +*> +*> (16) Same as (8), but with KA = 1 and KB = 1 +*> (17) Same as (8), but with KA = 2 and KB = 1 +*> (18) Same as (8), but with KA = 2 and KB = 2 +*> (19) Same as (8), but with KA = 3 and KB = 1 +*> (20) Same as (8), but with KA = 3 and KB = 2 +*> (21) Same as (8), but with KA = 3 and KB = 3 +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> NSIZES INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> SDRVKG2STG does nothing. It must be at least zero. +*> Not modified. +*> +*> NN INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. The values must be at least +*> zero. +*> Not modified. +*> +*> NTYPES INTEGER +*> The number of elements in DOTYPE. If it is zero, SDRVKG2STG +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> Not modified. +*> +*> DOTYPE LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> Not modified. +*> +*> ISEED INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to SDRVKG2STG to continue the same random number +*> sequence. +*> Modified. +*> +*> THRESH REAL +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error +*> is scaled to be O(1), so THRESH should be a reasonably +*> small multiple of 1, e.g., 10 or 100. In particular, +*> it should not depend on the precision (single vs. real) +*> or the size of the matrix. It must be at least zero. +*> Not modified. +*> +*> NOUNIT INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> Not modified. +*> +*> A REAL array, dimension (LDA , max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> Modified. +*> +*> LDA INTEGER +*> The leading dimension of A and AB. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> B REAL array, dimension (LDB , max(NN)) +*> Used to hold the symmetric positive definite matrix for +*> the generailzed problem. +*> On exit, B contains the last matrix actually +*> used. +*> Modified. +*> +*> LDB INTEGER +*> The leading dimension of B and BB. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> D REAL array, dimension (max(NN)) +*> The eigenvalues of A. On exit, the eigenvalues in D +*> correspond with the matrix in A. +*> Modified. +*> +*> Z REAL array, dimension (LDZ, max(NN)) +*> The matrix of eigenvectors. +*> Modified. +*> +*> LDZ INTEGER +*> The leading dimension of Z. It must be at least 1 and +*> at least max( NN ). +*> Not modified. +*> +*> AB REAL array, dimension (LDA, max(NN)) +*> Workspace. +*> Modified. +*> +*> BB REAL array, dimension (LDB, max(NN)) +*> Workspace. +*> Modified. +*> +*> AP REAL array, dimension (max(NN)**2) +*> Workspace. +*> Modified. +*> +*> BP REAL array, dimension (max(NN)**2) +*> Workspace. +*> Modified. +*> +*> WORK REAL array, dimension (NWORK) +*> Workspace. +*> Modified. +*> +*> NWORK INTEGER +*> The number of entries in WORK. This must be at least +*> 1+5*N+2*N*lg(N)+3*N**2 where N = max( NN(j) ) and +*> lg( N ) = smallest integer k such that 2**k >= N. +*> Not modified. +*> +*> IWORK INTEGER array, dimension (LIWORK) +*> Workspace. +*> Modified. +*> +*> LIWORK INTEGER +*> The number of entries in WORK. This must be at least 6*N. +*> Not modified. +*> +*> RESULT REAL array, dimension (70) +*> The values computed by the 70 tests described above. +*> Modified. +*> +*> INFO INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -16: LDZ < 1 or LDZ < NMAX. +*> -21: NWORK too small. +*> -23: LIWORK too small. +*> If SLATMR, SLATMS, SKYGV, SSPGV, SSBGV, SKYGVD, SSPGVD, +*> SSBGVD, SKYGVX, SSPGVX or SSBGVX returns an error code, +*> the absolute value of it is returned. +*> Modified. +*> +*> ---------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests that have been run +*> on this matrix. +*> NTESTT The total number of tests for this call. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far (computed by SLAFTS). +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup real_eig +* +* ===================================================================== + SUBROUTINE SDRVKG2STG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, B, LDB, D, D2, Z, LDZ, AB, + $ BB, AP, BP, WORK, NWORK, IWORK, LIWORK, + $ RESULT, INFO ) +* + IMPLICIT NONE +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDZ, LIWORK, NOUNIT, NSIZES, + $ NTYPES, NWORK + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + REAL A( LDA, * ), AB( LDA, * ), AP( * ), + $ B( LDB, * ), BB( LDB, * ), BP( * ), D( * ), + $ D2( * ), RESULT( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE, TEN + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TEN = 10.0E0 ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 21 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + CHARACTER UPLO + INTEGER I, IBTYPE, IBUPLO, IINFO, IJ, IL, IMODE, ITEMP, + $ ITYPE, IU, J, JCOL, JSIZE, JTYPE, KA, KA9, KB, + $ KB9, M, MTYPES, N, NERRS, NMATS, NMAX, NTEST, + $ NTESTT + REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, ULP, ULPINV, UNFL, VL, VU, TEMP1, TEMP2 +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SLAMCH, SLARND + EXTERNAL LSAME, SLAMCH, SLARND +* .. +* .. External Subroutines .. + EXTERNAL SLABAD, SLACPY, SLAFTS, SLASET, SLASUM, SLATMR, + $ SLATMS, SKYGV, SKGT01 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, MAX, MIN, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 6*9 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 6*1 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 6*4 / +* .. +* .. Executable Statements .. +* +* 1) Check for errors +* + NTESTT = 0 + INFO = 0 +* + BADNN = .FALSE. + NMAX = 0 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDZ.LE.1 .OR. LDZ.LT.NMAX ) THEN + INFO = -16 + ELSE IF( 2*MAX( NMAX, 3 )**2.GT.NWORK ) THEN + INFO = -21 + ELSE IF( 2*MAX( NMAX, 3 )**2.GT.LIWORK ) THEN + INFO = -23 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SDRVKG2STG', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = SLAMCH( 'Safe minimum' ) + OVFL = SLAMCH( 'Overflow' ) + CALL SLABAD( UNFL, OVFL ) + ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + 20 CONTINUE +* +* Loop over sizes, types +* + NERRS = 0 + NMATS = 0 +* + DO 650 JSIZE = 1, NSIZES + N = NN( JSIZE ) + ANINV = ONE / REAL( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + KA9 = 0 + KB9 = 0 + DO 640 JTYPE = 1, MTYPES + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 640 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* 2) Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, w/ eigenvalues +* =5 random log hermitian, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random hermitian +* =9 banded, w/ eigenvalues +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 90 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + IINFO = 0 + COND = ULPINV +* +* Special Matrices -- Identity & Jordan block +* + IF( ITYPE.EQ.1 ) THEN +* +* Zero +* + KA = 0 + KB = 0 + CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + KA = 0 + KB = 0 + CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + DO 80 JCOL = 1, N + A( JCOL, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* tridiagonal Matrix, [Eigen]values Specified +* + KA = 0 + KB = 0 + CALL SLATMS( N, N, 'S', ISEED, 'K', WORK, IMODE, COND, + $ ANORM, 1, 1, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* skew-symmetric, eigenvalues specified +* + KA = MAX( 0, N-1 ) + KB = KA + CALL SLATMS( N, N, 'S', ISEED, 'K', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* tridiagonal, random eigenvalues +* + KA = 0 + KB = 0 + CALL SLATMR( N, N, 'S', ISEED, 'K', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 1, 1, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* skew-symmetric, random eigenvalues +* + KA = MAX( 0, N-1 ) + KB = KA + CALL SLATMR( N, N, 'S', ISEED, 'K', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* skew-symmetric banded, eigenvalues specified +* +* The following values are used for the half-bandwidths: +* +* ka = 1 kb = 1 +* ka = 2 kb = 1 +* ka = 2 kb = 2 +* ka = 3 kb = 1 +* ka = 3 kb = 2 +* ka = 3 kb = 3 +* + KB9 = KB9 + 1 + IF( KB9.GT.KA9 ) THEN + KA9 = KA9 + 1 + KB9 = 1 + END IF + KA = MAX( 0, MIN( N-1, KA9 ) ) + KB = MAX( 0, MIN( N-1, KB9 ) ) + CALL SLATMS( N, N, 'S', ISEED, 'K', WORK, IMODE, COND, + $ ANORM, KA, KA, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE +* + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 90 CONTINUE +* + ABSTOL = UNFL + UNFL + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) ) + IU = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) ) + IF( IL.GT.IU ) THEN + ITEMP = IL + IL = IU + IU = ITEMP + END IF + END IF +* +* 3) Call SKYGV, SSPGV, SSBGV, SKYGVD, SSPGVD, SSBGVD, +* SKYGVX, SSPGVX, and SSBGVX, do tests. +* +* loop over the three generalized problems +* IBTYPE = 1: A*x = (lambda)*B*x +* IBTYPE = 2: A*B*x = (lambda)*x +* IBTYPE = 3: B*A*x = (lambda)*x +* + DO 630 IBTYPE = 1, 3 +* +* loop over the setting UPLO +* + DO 620 IBUPLO = 1, 2 + IF( IBUPLO.EQ.1 ) + $ UPLO = 'U' + IF( IBUPLO.EQ.2 ) + $ UPLO = 'L' +* +* Generate random well-conditioned positive definite +* matrix B, of bandwidth not greater than that of A. +* + CALL SLATMS( N, N, 'U', ISEED, 'P', WORK, 5, TEN, ONE, + $ KB, KB, UPLO, B, LDB, WORK( N+1 ), + $ IINFO ) +* +* Test SKYGV +* + NTEST = NTEST + 1 +* + CALL SLACPY( ' ', N, N, A, LDA, Z, LDZ ) + CALL SLACPY( UPLO, N, N, B, LDB, BB, LDB ) +* + CALL SKYGV( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D, + $ WORK, NWORK, IINFO ) +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SKYGV(V,' // UPLO // + $ ')', IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 100 + END IF + END IF +* +* Do Test +* + CALL SKGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z, + $ LDZ, D, WORK, RESULT( NTEST ) ) + 100 CONTINUE +* + 620 CONTINUE + 630 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + NTESTT = NTESTT + NTEST + CALL SLAFTS( 'SKG', N, N, JTYPE, NTEST, RESULT, IOLDSD, + $ THRESH, NOUNIT, NERRS ) + 640 CONTINUE + 650 CONTINUE +* +* Summary +* + CALL SLASUM( 'SKG', NOUNIT, NERRS, NTESTT ) +* + RETURN +* +* End of SDRVKG2STG +* + 9999 FORMAT( ' SDRVKG2STG: ', A, ' returned INFO=', I6, '.', / 9X, + $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) + END diff --git a/TESTING/EIG/sdrvkt.f b/TESTING/EIG/sdrvkt.f new file mode 100644 index 000000000..904b98ae1 --- /dev/null +++ b/TESTING/EIG/sdrvkt.f @@ -0,0 +1,897 @@ +*> \brief \b SDRVKT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SDRVKT( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, +* NOUNIT, A, LDA, D1, D2, D3, D4, EVEIGS, WA1, +* WA2, WA3, U, LDU, V, TAU, Z, WORK, LWORK, +* IWORK, LIWORK, RESULT, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, +* $ NTYPES +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) +* REAL A( LDA, * ), D1( * ), D2( * ), D3( * ), +* $ D4( * ), EVEIGS( * ), RESULT( * ), TAU( * ), +* $ U( LDU, * ), V( LDU, * ), WA1( * ), WA2( * ), +* $ WA3( * ), WORK( * ), Z( LDU, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SDRVKT checks the skew-symmetric eigenvalue problem drivers. +*> +*> SKTEV computes all eigenvalues and, optionally, +*> eigenvectors of a real skew-symmetric tridiagonal matrix. +*> +*> SKYEV computes all eigenvalues and, optionally, +*> eigenvectors of a real skew-symmetric matrix. +*> +*> When SDRVKT is called, a number of matrix "sizes" ("n's") and a +*> number of matrix "types" are specified. For each size ("n") +*> and each type of matrix, one matrix will be generated and used +*> to test the appropriate drivers. For each matrix and each +*> driver routine called, the following tests will be performed: +*> +*> (1) | A - Z D Z' | / ( |A| n ulp ) +*> +*> (2) | I - Z Z' | / ( n ulp ) +*> +*> (3) | D1 - D2 | / ( |D1| ulp ) +*> +*> where Z is the matrix of eigenvectors returned when the +*> eigenvector option is given and D1 and D2 are the eigenvalues +*> returned with and without the eigenvector option. +*> +*> The "sizes" are specified by an array NN(1:NSIZES); the value of +*> each element NN(j) specifies one size. +*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); +*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. +*> Currently, the list of possible types is: +*> +*> (1) The zero matrix. +*> (2) The identity matrix. +*> +*> (3) A diagonal matrix with evenly spaced eigenvalues +*> 1, ..., ULP and random signs. +*> (ULP = (first number larger than 1) - 1 ) +*> (4) A diagonal matrix with geometrically spaced eigenvalues +*> 1, ..., ULP and random signs. +*> (5) A diagonal matrix with "clustered" eigenvalues +*> 1, ULP, ..., ULP and random signs. +*> +*> (6) Same as (4), but multiplied by SQRT( overflow threshold ) +*> (7) Same as (4), but multiplied by SQRT( underflow threshold ) +*> +*> (8) A matrix of the form U' D U, where U is orthogonal and +*> D has evenly spaced entries 1, ..., ULP with random signs +*> on the diagonal. +*> +*> (9) A matrix of the form U' D U, where U is orthogonal and +*> D has geometrically spaced entries 1, ..., ULP with random +*> signs on the diagonal. +*> +*> (10) A matrix of the form U' D U, where U is orthogonal and +*> D has "clustered" entries 1, ULP,..., ULP with random +*> signs on the diagonal. +*> +*> (11) Same as (8), but multiplied by SQRT( overflow threshold ) +*> (12) Same as (8), but multiplied by SQRT( underflow threshold ) +*> +*> (13) skew-symmetric matrix with random entries chosen from (-1,1). +*> (14) Same as (13), but multiplied by SQRT( overflow threshold ) +*> (15) Same as (13), but multiplied by SQRT( underflow threshold ) +*> (16) A band matrix with half bandwidth randomly chosen between +*> 0 and N-1, with evenly spaced eigenvalues 1, ..., ULP +*> with random signs. +*> (17) Same as (16), but multiplied by SQRT( overflow threshold ) +*> (18) Same as (16), but multiplied by SQRT( underflow threshold ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \verbatim +*> NSIZES INTEGER +*> The number of sizes of matrices to use. If it is zero, +*> SDRVKT does nothing. It must be at least zero. +*> Not modified. +*> +*> NN INTEGER array, dimension (NSIZES) +*> An array containing the sizes to be used for the matrices. +*> Zero values will be skipped. The values must be at least +*> zero. +*> Not modified. +*> +*> NTYPES INTEGER +*> The number of elements in DOTYPE. If it is zero, SDRVKT +*> does nothing. It must be at least zero. If it is MAXTYP+1 +*> and NSIZES is 1, then an additional type, MAXTYP+1 is +*> defined, which is to use whatever matrix is in A. This +*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and +*> DOTYPE(MAXTYP+1) is .TRUE. . +*> Not modified. +*> +*> DOTYPE LOGICAL array, dimension (NTYPES) +*> If DOTYPE(j) is .TRUE., then for each size in NN a +*> matrix of that size and of type j will be generated. +*> If NTYPES is smaller than the maximum number of types +*> defined (PARAMETER MAXTYP), then types NTYPES+1 through +*> MAXTYP will not be generated. If NTYPES is larger +*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) +*> will be ignored. +*> Not modified. +*> +*> ISEED INTEGER array, dimension (4) +*> On entry ISEED specifies the seed of the random number +*> generator. The array elements should be between 0 and 4095; +*> if not they will be reduced mod 4096. Also, ISEED(4) must +*> be odd. The random number generator uses a linear +*> congruential sequence limited to small integers, and so +*> should produce machine independent random numbers. The +*> values of ISEED are changed on exit, and can be used in the +*> next call to SDRVKT to continue the same random number +*> sequence. +*> Modified. +*> +*> THRESH REAL +*> A test will count as "failed" if the "error", computed as +*> described above, exceeds THRESH. Note that the error +*> is scaled to be O(1), so THRESH should be a reasonably +*> small multiple of 1, e.g., 10 or 100. In particular, +*> it should not depend on the precision (single vs. double) +*> or the size of the matrix. It must be at least zero. +*> Not modified. +*> +*> NOUNIT INTEGER +*> The FORTRAN unit number for printing out error messages +*> (e.g., if a routine returns IINFO not equal to 0.) +*> Not modified. +*> +*> A REAL array, dimension (LDA , max(NN)) +*> Used to hold the matrix whose eigenvalues are to be +*> computed. On exit, A contains the last matrix actually +*> used. +*> Modified. +*> +*> LDA INTEGER +*> The leading dimension of A. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> D1 REAL array, dimension (max(NN)) +*> The eigenvalues of A, as computed by SSTEQR simlutaneously +*> with Z. On exit, the eigenvalues in D1 correspond with the +*> matrix in A. +*> Modified. +*> +*> D2 REAL array, dimension (max(NN)) +*> The eigenvalues of A, as computed by SSTEQR if Z is not +*> computed. On exit, the eigenvalues in D2 correspond with +*> the matrix in A. +*> Modified. +*> +*> D3 REAL array, dimension (max(NN)) +*> The eigenvalues of A, as computed by SSTERF. On exit, the +*> eigenvalues in D3 correspond with the matrix in A. +*> Modified. +*> +*> D4 REAL array, dimension +*> +*> EVEIGS REAL array, dimension (max(NN)) +*> The eigenvalues as computed by SKTEV('N', ... ) +*> (I reserve the right to change this to the output of +*> whichever algorithm computes the most accurate eigenvalues). +*> +*> WA1 REAL array, dimension +*> +*> WA2 REAL array, dimension +*> +*> WA3 REAL array, dimension +*> +*> U REAL array, dimension (LDU, max(NN)) +*> The orthogonal matrix computed by SSYTRD + SORGTR. +*> Modified. +*> +*> LDU INTEGER +*> The leading dimension of U, Z, and V. It must be at +*> least 1 and at least max( NN ). +*> Not modified. +*> +*> V REAL array, dimension (LDU, max(NN)) +*> The Housholder vectors computed by SSYTRD in reducing A to +*> tridiagonal form. +*> Modified. +*> +*> TAU REAL array, dimension (max(NN)) +*> The Householder factors computed by SSYTRD in reducing A +*> to tridiagonal form. +*> Modified. +*> +*> Z REAL array, dimension (LDU, max(NN)) +*> The orthogonal matrix of eigenvectors computed by SSTEQR, +*> SPTEQR, and SSTEIN. +*> Modified. +*> +*> WORK REAL array, dimension (LWORK) +*> Workspace. +*> Modified. +*> +*> LWORK INTEGER +*> The number of entries in WORK. This must be at least +*> 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 4 * Nmax**2 +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> Not modified. +*> +*> IWORK INTEGER array, +*> dimension (6 + 6*Nmax + 5 * Nmax * lg Nmax ) +*> where Nmax = max( NN(j), 2 ) and lg = log base 2. +*> Workspace. +*> Modified. +*> +*> RESULT REAL array, dimension (105) +*> The values computed by the tests described above. +*> The values are currently limited to 1/ulp, to avoid +*> overflow. +*> Modified. +*> +*> INFO INTEGER +*> If 0, then everything ran OK. +*> -1: NSIZES < 0 +*> -2: Some NN(j) < 0 +*> -3: NTYPES < 0 +*> -5: THRESH < 0 +*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). +*> -16: LDU < 1 or LDU < NMAX. +*> -21: LWORK too small. +*> If SLATMR, SLATMS, SSYTRD, SORGTR, SSTEQR, SSTERF, +*> or SORMTR returns an error code, the +*> absolute value of it is returned. +*> Modified. +*> +*>----------------------------------------------------------------------- +*> +*> Some Local Variables and Parameters: +*> ---- ----- --------- --- ---------- +*> ZERO, ONE Real 0 and 1. +*> MAXTYP The number of types defined. +*> NTEST The number of tests performed, or which can +*> be performed so far, for the current matrix. +*> NTESTT The total number of tests performed so far. +*> NMAX Largest value in NN. +*> NMATS The number of matrices generated so far. +*> NERRS The number of tests which have exceeded THRESH +*> so far (computed by SLAFTS). +*> COND, IMODE Values to be passed to the matrix generators. +*> ANORM Norm of A; passed to matrix generators. +*> +*> OVFL, UNFL Overflow and underflow thresholds. +*> ULP, ULPINV Finest relative precision and its inverse. +*> RTOVFL, RTUNFL Square roots of the previous 2 values. +*> The following four arrays decode JTYPE: +*> KTYPE(j) The general type (1-10) for type "j". +*> KMODE(j) The MODE value to be passed to the matrix +*> generator for type "j". +*> KMAGN(j) The order of magnitude ( O(1), +*> O(overflow^(1/2) ), O(underflow^(1/2) ) +*> +*> The tests performed are: Routine tested +*> 1= | A - U S U' | / ( |A| n ulp ) SKTEV('V', ... ) +*> 2= | I - U U' | / ( n ulp ) SKTEV('V', ... ) +*> 3= |D(with Z) - D(w/o Z)| / (|D| ulp) SKTEV('N', ... ) +*> 4= | A - U S U' | / ( |A| n ulp ) SSTEVX('V','A', ... ) +*> 5= | I - U U' | / ( n ulp ) SSTEVX('V','A', ... ) +*> 6= |D(with Z) - EVEIGS| / (|D| ulp) SSTEVX('N','A', ... ) +*> 7= | A - U S U' | / ( |A| n ulp ) SSTEVR('V','A', ... ) +*> 8= | I - U U' | / ( n ulp ) SSTEVR('V','A', ... ) +*> 9= |D(with Z) - EVEIGS| / (|D| ulp) SSTEVR('N','A', ... ) +*> 10= | A - U S U' | / ( |A| n ulp ) SSTEVX('V','I', ... ) +*> 11= | I - U U' | / ( n ulp ) SSTEVX('V','I', ... ) +*> 12= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVX('N','I', ... ) +*> 13= | A - U S U' | / ( |A| n ulp ) SSTEVX('V','V', ... ) +*> 14= | I - U U' | / ( n ulp ) SSTEVX('V','V', ... ) +*> 15= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVX('N','V', ... ) +*> 16= | A - U S U' | / ( |A| n ulp ) SSTEVD('V', ... ) +*> 17= | I - U U' | / ( n ulp ) SSTEVD('V', ... ) +*> 18= |D(with Z) - EVEIGS| / (|D| ulp) SSTEVD('N', ... ) +*> 19= | A - U S U' | / ( |A| n ulp ) SSTEVR('V','I', ... ) +*> 20= | I - U U' | / ( n ulp ) SSTEVR('V','I', ... ) +*> 21= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVR('N','I', ... ) +*> 22= | A - U S U' | / ( |A| n ulp ) SSTEVR('V','V', ... ) +*> 23= | I - U U' | / ( n ulp ) SSTEVR('V','V', ... ) +*> 24= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVR('N','V', ... ) +*> +*> 25= | A - U S U' | / ( |A| n ulp ) SKYEV('L','V', ... ) +*> 26= | I - U U' | / ( n ulp ) SKYEV('L','V', ... ) +*> 27= |D(with Z) - D(w/o Z)| / (|D| ulp) SKYEV('L','N', ... ) +*> 28= | A - U S U' | / ( |A| n ulp ) SSYEVX('L','V','A', ... ) +*> 29= | I - U U' | / ( n ulp ) SSYEVX('L','V','A', ... ) +*> 30= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVX('L','N','A', ... ) +*> 31= | A - U S U' | / ( |A| n ulp ) SSYEVX('L','V','I', ... ) +*> 32= | I - U U' | / ( n ulp ) SSYEVX('L','V','I', ... ) +*> 33= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVX('L','N','I', ... ) +*> 34= | A - U S U' | / ( |A| n ulp ) SSYEVX('L','V','V', ... ) +*> 35= | I - U U' | / ( n ulp ) SSYEVX('L','V','V', ... ) +*> 36= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVX('L','N','V', ... ) +*> 37= | A - U S U' | / ( |A| n ulp ) SSPEV('L','V', ... ) +*> 38= | I - U U' | / ( n ulp ) SSPEV('L','V', ... ) +*> 39= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEV('L','N', ... ) +*> 40= | A - U S U' | / ( |A| n ulp ) SSPEVX('L','V','A', ... ) +*> 41= | I - U U' | / ( n ulp ) SSPEVX('L','V','A', ... ) +*> 42= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVX('L','N','A', ... ) +*> 43= | A - U S U' | / ( |A| n ulp ) SSPEVX('L','V','I', ... ) +*> 44= | I - U U' | / ( n ulp ) SSPEVX('L','V','I', ... ) +*> 45= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVX('L','N','I', ... ) +*> 46= | A - U S U' | / ( |A| n ulp ) SSPEVX('L','V','V', ... ) +*> 47= | I - U U' | / ( n ulp ) SSPEVX('L','V','V', ... ) +*> 48= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVX('L','N','V', ... ) +*> 49= | A - U S U' | / ( |A| n ulp ) SSBEV('L','V', ... ) +*> 50= | I - U U' | / ( n ulp ) SSBEV('L','V', ... ) +*> 51= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEV('L','N', ... ) +*> 52= | A - U S U' | / ( |A| n ulp ) SSBEVX('L','V','A', ... ) +*> 53= | I - U U' | / ( n ulp ) SSBEVX('L','V','A', ... ) +*> 54= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVX('L','N','A', ... ) +*> 55= | A - U S U' | / ( |A| n ulp ) SSBEVX('L','V','I', ... ) +*> 56= | I - U U' | / ( n ulp ) SSBEVX('L','V','I', ... ) +*> 57= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVX('L','N','I', ... ) +*> 58= | A - U S U' | / ( |A| n ulp ) SSBEVX('L','V','V', ... ) +*> 59= | I - U U' | / ( n ulp ) SSBEVX('L','V','V', ... ) +*> 60= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVX('L','N','V', ... ) +*> 61= | A - U S U' | / ( |A| n ulp ) SSYEVD('L','V', ... ) +*> 62= | I - U U' | / ( n ulp ) SSYEVD('L','V', ... ) +*> 63= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVD('L','N', ... ) +*> 64= | A - U S U' | / ( |A| n ulp ) SSPEVD('L','V', ... ) +*> 65= | I - U U' | / ( n ulp ) SSPEVD('L','V', ... ) +*> 66= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVD('L','N', ... ) +*> 67= | A - U S U' | / ( |A| n ulp ) SSBEVD('L','V', ... ) +*> 68= | I - U U' | / ( n ulp ) SSBEVD('L','V', ... ) +*> 69= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVD('L','N', ... ) +*> 70= | A - U S U' | / ( |A| n ulp ) SSYEVR('L','V','A', ... ) +*> 71= | I - U U' | / ( n ulp ) SSYEVR('L','V','A', ... ) +*> 72= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVR('L','N','A', ... ) +*> 73= | A - U S U' | / ( |A| n ulp ) SSYEVR('L','V','I', ... ) +*> 74= | I - U U' | / ( n ulp ) SSYEVR('L','V','I', ... ) +*> 75= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVR('L','N','I', ... ) +*> 76= | A - U S U' | / ( |A| n ulp ) SSYEVR('L','V','V', ... ) +*> 77= | I - U U' | / ( n ulp ) SSYEVR('L','V','V', ... ) +*> 78= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVR('L','N','V', ... ) +*> +*> Tests 25 through 78 are repeated (as tests 79 through 132) +*> with UPLO='U' +*> +*> To be added in 1999 +*> +*> 79= | A - U S U' | / ( |A| n ulp ) SSPEVR('L','V','A', ... ) +*> 80= | I - U U' | / ( n ulp ) SSPEVR('L','V','A', ... ) +*> 81= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVR('L','N','A', ... ) +*> 82= | A - U S U' | / ( |A| n ulp ) SSPEVR('L','V','I', ... ) +*> 83= | I - U U' | / ( n ulp ) SSPEVR('L','V','I', ... ) +*> 84= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVR('L','N','I', ... ) +*> 85= | A - U S U' | / ( |A| n ulp ) SSPEVR('L','V','V', ... ) +*> 86= | I - U U' | / ( n ulp ) SSPEVR('L','V','V', ... ) +*> 87= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVR('L','N','V', ... ) +*> 88= | A - U S U' | / ( |A| n ulp ) SSBEVR('L','V','A', ... ) +*> 89= | I - U U' | / ( n ulp ) SSBEVR('L','V','A', ... ) +*> 90= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVR('L','N','A', ... ) +*> 91= | A - U S U' | / ( |A| n ulp ) SSBEVR('L','V','I', ... ) +*> 92= | I - U U' | / ( n ulp ) SSBEVR('L','V','I', ... ) +*> 93= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVR('L','N','I', ... ) +*> 94= | A - U S U' | / ( |A| n ulp ) SSBEVR('L','V','V', ... ) +*> 95= | I - U U' | / ( n ulp ) SSBEVR('L','V','V', ... ) +*> 96= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVR('L','N','V', ... ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup single_eig +* +* ===================================================================== + SUBROUTINE SDRVKT( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, + $ NOUNIT, A, LDA, D1, D2, D3, D4, EVEIGS, WA1, + $ WA2, WA3, U, LDU, V, TAU, Z, WORK, LWORK, + $ IWORK, LIWORK, RESULT, INFO ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES, + $ NTYPES + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER ISEED( 4 ), IWORK( * ), NN( * ) + REAL A( LDA, * ), D1( * ), D2( * ), D3( * ), + $ D4( * ), EVEIGS( * ), RESULT( * ), TAU( * ), + $ U( LDU, * ), V( LDU, * ), WA1( * ), WA2( * ), + $ WA3( * ), WORK( * ), Z( LDU, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE, TWO, TEN + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0, + $ TEN = 10.0E0 ) + REAL HALF + PARAMETER ( HALF = 0.5E0 ) + INTEGER MAXTYP + PARAMETER ( MAXTYP = 18 ) +* .. +* .. Local Scalars .. + LOGICAL BADNN + CHARACTER UPLO + INTEGER I, IDIAG, IHBW, IINFO, IL, IMODE, IROW, + $ ITEMP, ITYPE, IU, IUPLO, J, J1, J2, JCOL, + $ JSIZE, JTYPE, LGN, LIWEDC, LWEDC, + $ MTYPES, N, NERRS, NMATS, NMAX, NTEST, + $ NTESTT + REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, + $ RTUNFL, TEMP1, TEMP2, ULP, ULPINV, UNFL, + $ VL, VU +* .. +* .. Local Arrays .. + INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), + $ ISEED3( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ), + $ KTYPE( MAXTYP ) +* .. +* .. External Functions .. + REAL SLAMCH, SLARND, SSXT1 + EXTERNAL SLAMCH, SLARND, SSXT1 +* .. +* .. External Subroutines .. + EXTERNAL ALASVM, SLABAD, SLACPY, SLAFTS, SLASET, SLATMR, + $ SLATMS, SKTEV, SKTT21, SKYEV, SKYT21, XERBLA +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, INT, LOG, MAX, MIN, REAL, SQRT +* .. +* .. Data statements .. + DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 3*9 / + DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, + $ 2, 3, 1, 2, 3 / + DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, + $ 0, 0, 4, 4, 4 / +* .. +* .. Executable Statements .. +* +* Keep ftrnchek happy +* + VL = ZERO + VU = ZERO +* +* 1) Check for errors +* + NTESTT = 0 + INFO = 0 +* + BADNN = .FALSE. + NMAX = 1 + DO 10 J = 1, NSIZES + NMAX = MAX( NMAX, NN( J ) ) + IF( NN( J ).LT.0 ) + $ BADNN = .TRUE. + 10 CONTINUE +* +* Check for errors +* + IF( NSIZES.LT.0 ) THEN + INFO = -1 + ELSE IF( BADNN ) THEN + INFO = -2 + ELSE IF( NTYPES.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.NMAX ) THEN + INFO = -9 + ELSE IF( LDU.LT.NMAX ) THEN + INFO = -16 + ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN + INFO = -21 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SDRVKT', -INFO ) + RETURN + END IF +* +* Quick return if nothing to do +* + IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) + $ RETURN +* +* More Important constants +* + UNFL = SLAMCH( 'Safe minimum' ) + OVFL = SLAMCH( 'Overflow' ) + CALL SLABAD( UNFL, OVFL ) + ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) + ULPINV = ONE / ULP + RTUNFL = SQRT( UNFL ) + RTOVFL = SQRT( OVFL ) +* +* Loop over sizes, types +* + DO 20 I = 1, 4 + ISEED2( I ) = ISEED( I ) + ISEED3( I ) = ISEED( I ) + 20 CONTINUE +* + NERRS = 0 + NMATS = 0 +* +* + DO 1740 JSIZE = 1, NSIZES + N = NN( JSIZE ) + IF( N.GT.0 ) THEN + LGN = INT( LOG( REAL( N ) ) / LOG( TWO ) ) + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + IF( 2**LGN.LT.N ) + $ LGN = LGN + 1 + LWEDC = 1 + 4*N + 2*N*LGN + 4*N**2 +c LIWEDC = 6 + 6*N + 5*N*LGN + LIWEDC = 3 + 5*N + ELSE + LWEDC = 9 +c LIWEDC = 12 + LIWEDC = 8 + END IF + ANINV = ONE / REAL( MAX( 1, N ) ) +* + IF( NSIZES.NE.1 ) THEN + MTYPES = MIN( MAXTYP, NTYPES ) + ELSE + MTYPES = MIN( MAXTYP+1, NTYPES ) + END IF +* + DO 1730 JTYPE = 1, MTYPES +* + IF( .NOT.DOTYPE( JTYPE ) ) + $ GO TO 1730 + NMATS = NMATS + 1 + NTEST = 0 +* + DO 30 J = 1, 4 + IOLDSD( J ) = ISEED( J ) + 30 CONTINUE +* +* 2) Compute "A" +* +* Control parameters: +* +* KMAGN KMODE KTYPE +* =1 O(1) clustered 1 zero +* =2 large clustered 2 identity +* =3 small exponential (none) +* =4 arithmetic diagonal, (w/ eigenvalues) +* =5 random log skew-symmetric, w/ eigenvalues +* =6 random (none) +* =7 random diagonal +* =8 random skew-symmetric +* =9 band skew-symmetric, w/ eigenvalues +* + IF( MTYPES.GT.MAXTYP ) + $ GO TO 110 +* + ITYPE = KTYPE( JTYPE ) + IMODE = KMODE( JTYPE ) +* +* Compute norm +* + GO TO ( 40, 50, 60 )KMAGN( JTYPE ) +* + 40 CONTINUE + ANORM = ONE + GO TO 70 +* + 50 CONTINUE + ANORM = ( RTOVFL*ULP )*ANINV + GO TO 70 +* + 60 CONTINUE + ANORM = RTUNFL*N*ULPINV + GO TO 70 +* + 70 CONTINUE +* + CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + IINFO = 0 + COND = ULPINV +* +* Special Matrices -- Identity & Jordan block +* +* Zero +* + IF( ITYPE.EQ.1 ) THEN + IINFO = 0 +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Identity +* + DO 80 JCOL = 1, N + A( JCOL, JCOL ) = ANORM + 80 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* tridiagonal Matrix, [Eigen]values Specified +* + CALL SLATMS( N, N, 'S', ISEED, 'K', WORK, IMODE, COND, + $ ANORM, 1, 1, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* skew-symmetric, eigenvalues specified +* + CALL SLATMS( N, N, 'S', ISEED, 'K', WORK, IMODE, COND, + $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), + $ IINFO ) +* + ELSE IF( ITYPE.EQ.7 ) THEN +* +* tridiagonal, random eigenvalues +* + IDUMMA( 1 ) = 1 + CALL SLATMR( N, N, 'S', ISEED, 'K', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 1, 1, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.8 ) THEN +* +* skew-symmetric, random eigenvalues +* + IDUMMA( 1 ) = 1 + CALL SLATMR( N, N, 'S', ISEED, 'K', WORK, 6, ONE, ONE, + $ 'T', 'N', WORK( N+1 ), 1, ONE, + $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, + $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) +* + ELSE IF( ITYPE.EQ.9 ) THEN +* +* skew-symmetric banded, eigenvalues specified +* + IHBW = INT( ( N-1 )*SLARND( 1, ISEED3 ) ) + CALL SLATMS( N, N, 'S', ISEED, 'K', WORK, IMODE, COND, + $ ANORM, IHBW, IHBW, 'Z', U, LDU, WORK( N+1 ), + $ IINFO ) +* +* Store as dense matrix for most routines. +* + CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) + DO 100 IDIAG = -IHBW, IHBW + IROW = IHBW - IDIAG + 1 + J1 = MAX( 1, IDIAG+1 ) + J2 = MIN( N, N+IDIAG ) + DO 90 J = J1, J2 + I = J - IDIAG + A( I, J ) = U( IROW, J ) + 90 CONTINUE + 100 CONTINUE + ELSE + IINFO = 1 + END IF +* + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, + $ IOLDSD + INFO = ABS( IINFO ) + RETURN + END IF +* + 110 CONTINUE +* + ABSTOL = UNFL + UNFL + IF( N.LE.1 ) THEN + IL = 1 + IU = N + ELSE + IL = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) ) + IU = 1 + INT( ( N-1 )*SLARND( 1, ISEED2 ) ) + IF( IL.GT.IU ) THEN + ITEMP = IL + IL = IU + IU = ITEMP + END IF + END IF +* +* 3) If matrix is tridiagonal, call SKTEV and SSTEVX. +* + IF( JTYPE.LE.7 ) THEN + NTEST = 1 + DO 120 I = 1, N + D1( I ) = REAL( A( I, I ) ) + 120 CONTINUE + DO 130 I = 1, N - 1 + D2( I ) = REAL( A( I+1, I ) ) + 130 CONTINUE + SRNAMT = 'SKTEV' + CALL SKTEV( 'V', N, D1, D2, Z, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SKTEV(V)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 1 ) = ULPINV + RESULT( 2 ) = ULPINV + RESULT( 3 ) = ULPINV + GO TO 180 + END IF + END IF +* +* Do tests 1 and 2. +* + DO 140 I = 1, N + D3( I ) = REAL( A( I, I ) ) + 140 CONTINUE + DO 150 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 150 CONTINUE + CALL SKTT21( N, 1, D3, D4, D2, D1, Z, LDU, WORK, + $ RESULT( 1 ) ) +* + NTEST = 3 + DO 160 I = 1, N - 1 + D4( I ) = REAL( A( I+1, I ) ) + 160 CONTINUE + SRNAMT = 'SKTEV' + CALL SKTEV( 'N', N, D3, D4, Z, LDU, WORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SKTEV(N)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 3 ) = ULPINV + GO TO 180 + END IF + END IF +* +* Do test 3. +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 170 J = 1, N-1 + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 170 CONTINUE + RESULT( 3 ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 180 CONTINUE +* + ELSE +* + DO 640 I = 1, 3 + RESULT( I ) = ZERO + 640 CONTINUE + NTEST = 3 + END IF +* +* Perform remaining tests storing upper or lower triangular +* part of matrix. +* + DO 1720 IUPLO = 0, 1 + IF( IUPLO.EQ.0 ) THEN + UPLO = 'L' + ELSE + UPLO = 'U' + END IF +* +* 4) Call SKYEV and SSYEVX. +* + CALL SLACPY( ' ', N, N, A, LDA, V, LDU ) +* + NTEST = NTEST + 1 + SRNAMT = 'SKYEV' + CALL SKYEV( 'V', UPLO, N, A, LDU, D1, WORK, LWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SKYEV(V,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + RESULT( NTEST+1 ) = ULPINV + RESULT( NTEST+2 ) = ULPINV + GO TO 660 + END IF + END IF +* +* Do tests 25 and 26 (or +54) +* + CALL SKYT21( 1, UPLO, N, 1, V, LDU, D2, D1, A, LDU, Z, + $ LDU, TAU, WORK, RESULT( NTEST ) ) +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* + NTEST = NTEST + 2 + SRNAMT = 'SKYEV' + CALL SKYEV( 'N', UPLO, N, A, LDU, D3, WORK, LWORK, + $ IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SKYEV(N,' // UPLO // ')', + $ IINFO, N, JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( NTEST ) = ULPINV + GO TO 660 + END IF + END IF +* +* Do test 27 (or +54) +* + TEMP1 = ZERO + TEMP2 = ZERO + DO 650 J = 1, N-1 + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) ) + 650 CONTINUE + RESULT( NTEST ) = TEMP2 / MAX( UNFL, + $ ULP*MAX( TEMP1, TEMP2 ) ) +* + 660 CONTINUE +* + CALL SLACPY( ' ', N, N, V, LDU, A, LDA ) +* + 1720 CONTINUE +* +* End of Loop -- Check for RESULT(j) > THRESH +* + NTESTT = NTESTT + NTEST +* + CALL SLAFTS( 'SKT', N, N, JTYPE, NTEST, RESULT, IOLDSD, + $ THRESH, NOUNIT, NERRS ) +* + 1730 CONTINUE + 1740 CONTINUE +* +* Summary +* + CALL ALASVM( 'SKT', NOUNIT, NERRS, NTESTT, 0 ) +* + 9999 FORMAT( ' SDRVKT: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', + $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) +* + RETURN +* +* End of SDRVKT +* + END diff --git a/TESTING/EIG/serrkt.f b/TESTING/EIG/serrkt.f new file mode 100644 index 000000000..af495534b --- /dev/null +++ b/TESTING/EIG/serrkt.f @@ -0,0 +1,211 @@ +*> \brief \b SERRKT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SERRKT( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SERRKT tests the error exits for SKYTRD, SKTEQR and SKYEV. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup single_eig +* +* ===================================================================== + SUBROUTINE SERRKT( PATH, NUNIT ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* NMAX has to be at least 3 or LIW may be too small +* .. Parameters .. + INTEGER NMAX, LIW, LW + PARAMETER ( NMAX = 3, LIW = 12*NMAX, LW = 20*NMAX ) +* .. +* .. Local Scalars .. + CHARACTER*2 C2 + INTEGER I, INFO, J, M, N, NSPLIT, NT +* .. +* .. Local Arrays .. + INTEGER I1( NMAX ), I2( NMAX ), I3( NMAX ), IW( LIW ) + REAL A( NMAX, NMAX ), C( NMAX, NMAX ), D( NMAX ), + $ E( NMAX ), Q( NMAX, NMAX ), R( NMAX ), + $ TAU( NMAX ), W( LW ), X( NMAX ), + $ Z( NMAX, NMAX ) +* .. +* .. External Functions .. + LOGICAL LSAMEN + EXTERNAL LSAMEN +* .. +* .. External Subroutines .. + EXTERNAL CHKXER, SKTEQR, SKYEV, SKTEV, SKYTRD +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) + C2 = PATH( 2: 3 ) +* +* Set the variables to innocuous values. +* + DO 20 J = 1, NMAX + DO 10 I = 1, NMAX + A( I, J ) = 1. / REAL( I+J ) + 10 CONTINUE + 20 CONTINUE + DO 30 J = 1, NMAX + D( J ) = REAL( J ) + E( J ) = 0.0 + I1( J ) = J + I2( J ) = J + TAU( J ) = 1. + 30 CONTINUE + OK = .TRUE. + NT = 0 +* +* Test error exits for the KT path. +* + IF( LSAMEN( 2, C2, 'KT' ) ) THEN +* +* SKYTRD +* + SRNAMT = 'SKYTRD' + INFOT = 1 + CALL SKYTRD( '/', 0, A, 1, E, TAU, W, 1, INFO ) + CALL CHKXER( 'SKYTRD', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SKYTRD( 'U', -1, A, 1, E, TAU, W, 1, INFO ) + CALL CHKXER( 'SKYTRD', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SKYTRD( 'U', 2, A, 1, E, TAU, W, 1, INFO ) + CALL CHKXER( 'SKYTRD', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SKYTRD( 'U', 0, A, 1, E, TAU, W, 0, INFO ) + CALL CHKXER( 'SKYTRD', INFOT, NOUT, LERR, OK ) + NT = NT + 4 +* +* SKTEQR +* + SRNAMT = 'SKTEQR' + INFOT = 1 + CALL SKTEQR( '/', 0, E, Z, 1, W, INFO ) + CALL CHKXER( 'SKTEQR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SKTEQR( 'N', -1, E, Z, 1, W, INFO ) + CALL CHKXER( 'SKTEQR', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SKTEQR( 'V', 2, E, Z, 1, W, INFO ) + CALL CHKXER( 'SKTEQR', INFOT, NOUT, LERR, OK ) + NT = NT + 3 +* +* SKYEV +* + SRNAMT = 'SKYEV ' + INFOT = 1 + CALL SKYEV( '/', 'U', 0, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'SKYEV ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SKYEV( 'N', '/', 0, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'SKYEV ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SKYEV( 'N', 'U', -1, A, 1, X, W, 1, INFO ) + CALL CHKXER( 'SKYEV ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SKYEV( 'N', 'U', 2, A, 1, X, W, 3, INFO ) + CALL CHKXER( 'SKYEV ', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SKYEV( 'N', 'U', 2, A, 2, X, W, 2, INFO ) + CALL CHKXER( 'SKYEV ', INFOT, NOUT, LERR, OK ) + NT = NT + 5 +* +* SKTEV +* + SRNAMT = 'SKTEV ' + INFOT = 1 + CALL SKTEV( '/', 0, D, E, Z, 1, W, INFO ) + CALL CHKXER( 'SKTEV ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SKTEV( 'N', -1, D, E, Z, 1, W, INFO ) + CALL CHKXER( 'SKTEV ', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SKTEV( 'V', 2, D, E, Z, 1, W, INFO ) + CALL CHKXER( 'SKTEV ', INFOT, NOUT, LERR, OK ) + NT = NT + 3 + END IF +* +* Print a summary line. +* + IF( OK ) THEN + WRITE( NOUT, FMT = 9999 )PATH, NT + ELSE + WRITE( NOUT, FMT = 9998 )PATH + END IF +* + 9999 FORMAT( 1X, A3, ' routines passed the tests of the error exits', + $ ' (', I3, ' tests done)' ) + 9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ', + $ 'exits ***' ) +* + RETURN +* +* End of SERRKT +* + END diff --git a/TESTING/EIG/skgt01.f b/TESTING/EIG/skgt01.f new file mode 100644 index 000000000..94b68556c --- /dev/null +++ b/TESTING/EIG/skgt01.f @@ -0,0 +1,263 @@ +*> \brief \b SKGT01 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SKGT01( ITYPE, UPLO, N, M, A, LDA, B, LDB, Z, LDZ, D, +* WORK, RESULT ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER ITYPE, LDA, LDB, LDZ, M, N +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), B( LDB, * ), D( * ), RESULT( * ), +* $ WORK( * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SKGT01 checks a decomposition of the form +*> +*> A Z = B Z D or +*> A B Z = Z D or +*> B A Z = Z D +*> +*> where A is a skew-symmetric matrix, B is +*> skew-symmetric positive definite, Z is orthogonal, and D is diagonal. +*> +*> One of the following test ratios is computed: +*> +*> ITYPE = 1: RESULT(1) = | A Z - B Z D | / ( |A| |Z| n ulp ) +*> +*> ITYPE = 2: RESULT(1) = | A B Z - Z D | / ( |A| |Z| n ulp ) +*> +*> ITYPE = 3: RESULT(1) = | B A Z - Z D | / ( |A| |Z| n ulp ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is INTEGER +*> The form of the skew-symmetric generalized eigenproblem. +*> = 1: A*z = (lambda)*B*z +*> = 2: A*B*z = (lambda)*z +*> = 3: B*A*z = (lambda)*z +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> skew-symmetric matrices A and B is stored. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of eigenvalues found. 0 <= M <= N. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension (LDA, N) +*> The original skew-symmetric matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is REAL array, dimension (LDB, N) +*> The original symmetric positive definite matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[in] Z +*> \verbatim +*> Z is REAL array, dimension (LDZ, M) +*> The computed eigenvectors of the generalized eigenproblem. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of the array Z. LDZ >= max(1,N). +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is REAL array, dimension (M) +*> The computed eigenvalues of the generalized eigenproblem. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (N*N) +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (1) +*> The test ratio as described above. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup single_eig +* +* ===================================================================== + SUBROUTINE SKGT01( ITYPE, UPLO, N, M, A, LDA, B, LDB, Z, LDZ, D, + $ WORK, RESULT ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER ITYPE, LDA, LDB, LDZ, M, N +* .. +* .. Array Arguments .. + REAL A( LDA, * ), B( LDB, * ), D( * ), RESULT( * ), + $ WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) +* .. +* .. Local Scalars .. + INTEGER I + REAL ANORM, ULP +* .. +* .. External Functions .. + REAL SLAMCH, SLANGE, SLANKY + EXTERNAL SLAMCH, SLANGE, SLANKY +* .. +* .. External Subroutines .. + EXTERNAL SCOPY, SSCAL, SAXPY, SSYMM, SKYMM +* .. +* .. Executable Statements .. +* + RESULT( 1 ) = ZERO + IF( N.LE.0 ) + $ RETURN +* + ULP = SLAMCH( 'Epsilon' ) +* +* Compute product of 1-norms of A and Z. +* + ANORM = SLANKY( '1', UPLO, N, A, LDA, WORK )* + $ SLANGE( '1', N, M, Z, LDZ, WORK ) + IF( ANORM.EQ.ZERO ) + $ ANORM = ONE +* + IF( ITYPE.EQ.1 ) THEN +* +* Norm of AZ - BZD +* + CALL SKYMM( 'Left', UPLO, N, M, ONE, A, LDA, Z, LDZ, ZERO, + $ WORK, N ) + DO 10 I = 1, M-1 + CALL SCOPY( N, Z( 1, I+1 ), 1, WORK(N**2+(I-1)*N+1), 1 ) + CALL SSCAL( N, D( I ), WORK(N**2+(I-1)*N+1), 1 ) + 10 CONTINUE + DO 20 I = 2, M-1 + CALL SAXPY( N, -D( I-1 ), Z( 1, I-1 ), 1, + $ WORK(N**2+(I-1)*N+1), 1 ) + 20 CONTINUE + CALL SCOPY( N, Z( 1, M-1 ), 1, WORK(N**2+(M-1)*N+1), 1 ) + CALL SSCAL( N, -D( M-1 ), WORK(N**2+(M-1)*N+1), 1 ) + CALL SSYMM( 'Left', UPLO, N, M, ONE, B, LDB, WORK(N**2+1), + $ N, -ONE, WORK, N ) +* + RESULT( 1 ) = ( SLANGE( '1', N, M, WORK, N, WORK ) / ANORM ) / + $ ( N*ULP ) +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Norm of ABZ - ZD +* + CALL SSYMM( 'Left', UPLO, N, M, ONE, B, LDB, Z, LDZ, ZERO, + $ WORK, N ) + DO 30 I = 1, M-1 + CALL SCOPY( N, Z( 1, I+1 ), 1, WORK(N**2+(I-1)*N+1), 1 ) + CALL SSCAL( N, D( I ), WORK(N**2+(I-1)*N+1), 1 ) + 30 CONTINUE + DO 40 I = 2, M-1 + CALL SAXPY( N, -D( I-1 ), Z( 1, I-1 ), 1, + $ WORK(N**2+(I-1)*N+1), 1 ) + 40 CONTINUE + CALL SCOPY( N, Z( 1, M-1 ), 1, WORK(N**2+(M-1)*N+1), 1 ) + CALL SSCAL( N, -D( M-1 ), WORK(N**2+(M-1)*N+1), 1 ) + CALL SKYMM( 'Left', UPLO, N, M, ONE, A, LDA, WORK, N, -ONE, + $ WORK(N**2+1), N ) +* + RESULT( 1 ) = ( SLANGE( '1', N, M, WORK(N**2+1), N, WORK ) + $ / ANORM ) / ( N*ULP ) +* + ELSE IF( ITYPE.EQ.3 ) THEN +* +* Norm of BAZ - ZD +* + CALL SKYMM( 'Left', UPLO, N, M, ONE, A, LDA, Z, LDZ, ZERO, + $ WORK, N ) + DO 50 I = 1, M-1 + CALL SCOPY( N, Z( 1, I+1 ), 1, WORK(N**2+(I-1)*N+1), 1 ) + CALL SSCAL( N, D( I ), WORK(N**2+(I-1)*N+1), 1 ) + 50 CONTINUE + DO 60 I = 2, M-1 + CALL SAXPY( N, -D( I-1 ), Z( 1, I-1 ), 1, + $ WORK(N**2+(I-1)*N+1), 1 ) + 60 CONTINUE + CALL SCOPY( N, Z( 1, M-1 ), 1, WORK(N**2+(M-1)*N+1), 1 ) + CALL SSCAL( N, -D( M-1 ), WORK(N**2+(M-1)*N+1), 1 ) + CALL SSYMM( 'Left', UPLO, N, M, ONE, B, LDB, WORK, N, -ONE, + $ WORK(N**2+1), N ) +* + RESULT( 1 ) = ( SLANGE( '1', N, M, WORK(N**2+1), N, WORK ) + $ / ANORM ) / ( N*ULP ) + END IF +* + RETURN +* +* End of SKGT01 +* + END diff --git a/TESTING/EIG/sktt21.f b/TESTING/EIG/sktt21.f new file mode 100644 index 000000000..4a5b3ead9 --- /dev/null +++ b/TESTING/EIG/sktt21.f @@ -0,0 +1,230 @@ +*> \brief \b SKTT21 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SKTT21( N, KBAND, AD, AE, SD, SE, U, LDU, WORK, +* RESULT ) +* +* .. Scalar Arguments .. +* INTEGER KBAND, LDU, N +* .. +* .. Array Arguments .. +* REAL AD( * ), AE( * ), RESULT( 2 ), SD( * ), +* $ SE( * ), U( LDU, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SKTT21 checks a decomposition of the form +*> +*> A = U S U' +*> +*> where ' means transpose, A is skew-symmetric tridiagonal, U is orthogonal, +*> and S is diagonal (if KBAND=0) or skew-symmetric tridiagonal (if KBAND=1). +*> Two tests are performed: +*> +*> RESULT(1) = | A - U S U' | / ( |A| n ulp ) +*> +*> RESULT(2) = | I - UU' | / ( n ulp ) +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The size of the matrix. If it is zero, SKTT21 does nothing. +*> It must be at least zero. +*> \endverbatim +*> +*> \param[in] KBAND +*> \verbatim +*> KBAND is INTEGER +*> The bandwidth of the matrix S. It may only be zero or one. +*> If zero, then S is diagonal, and SE is not referenced. If +*> one, then S is skew-symmetric tri-diagonal. +*> \endverbatim +*> +*> \param[in] AD +*> \verbatim +*> AD is REAL array, dimension (N) +*> AD is not referenced. +*> \endverbatim +*> +*> \param[in] AE +*> \verbatim +*> AE is REAL array, dimension (N-1) +*> The off-diagonal of the original (unfactored) matrix A. A +*> is assumed to be skew-symmetric tridiagonal. AE(1) is the (1,2) +*> and (2,1) element, AE(2) is the (2,3) and (3,2) element, etc. +*> \endverbatim +*> +*> \param[in] SD +*> \verbatim +*> SD is REAL array, dimension (N) +*> SD is not referenced. +*> \endverbatim +*> +*> \param[in] SE +*> \verbatim +*> SE is REAL array, dimension (N-1) +*> The off-diagonal of the (skew-symmetric tri-) diagonal matrix S. +*> Not referenced if KBSND=0. If KBAND=1, then AE(1) is the +*> (1,2) and (2,1) element, SE(2) is the (2,3) and (3,2) +*> element, etc. +*> \endverbatim +*> +*> \param[in] U +*> \verbatim +*> U is REAL array, dimension (LDU, N) +*> The orthogonal matrix in the decomposition. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of U. LDU must be at least N. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (N*(N+1)) +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (2) +*> The values computed by the two tests described above. The +*> values are currently limited to 1/ulp, to avoid overflow. +*> RESULT(1) is always modified. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup single_eig +* +* ===================================================================== + SUBROUTINE SKTT21( N, KBAND, AD, AE, SD, SE, U, LDU, WORK, + $ RESULT ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER KBAND, LDU, N +* .. +* .. Array Arguments .. + REAL AD( * ), AE( * ), RESULT( 2 ), SD( * ), + $ SE( * ), U( LDU, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) +* .. +* .. Local Scalars .. + INTEGER J + REAL ANORM, TEMP1, TEMP2, ULP, UNFL, WNORM +* .. +* .. External Functions .. + REAL SLAMCH, SLANGE, SLANKY + EXTERNAL SLAMCH, SLANGE, SLANKY +* .. +* .. External Subroutines .. + EXTERNAL SGEMM, SLASET, SKYR2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, REAL +* .. +* .. Executable Statements .. +* +* 1) Constants +* + RESULT( 1 ) = ZERO + RESULT( 2 ) = ZERO + IF( N.LE.0 ) + $ RETURN +* + UNFL = SLAMCH( 'Safe minimum' ) + ULP = SLAMCH( 'Precision' ) +* +* Do Test 1 +* +* Copy A & Compute its 1-Norm: +* + CALL SLASET( 'Full', N, N, ZERO, ZERO, WORK, N ) +* + ANORM = ZERO + TEMP1 = ZERO +* + DO 10 J = 1, N - 1 + WORK( ( N+1 )*( J-1 )+1 ) = ZERO + WORK( ( N+1 )*( J-1 )+2 ) = AE( J ) + TEMP2 = ABS( AE( J ) ) + ANORM = MAX( ANORM, ABS( ZERO )+TEMP1+TEMP2 ) + TEMP1 = TEMP2 + 10 CONTINUE +* + WORK( N**2 ) = ZERO + ANORM = MAX( ANORM, ABS( ZERO )+TEMP1, UNFL ) +* +* Norm of A - USU' +* + IF( N.GT.1 .AND. KBAND.EQ.1 ) THEN + DO 30 J = 1, N - 1 + CALL SKYR2( 'L', N, -SE( J ), U( 1, J ), 1, U( 1, J+1 ), 1, + $ WORK, N ) + 30 CONTINUE + END IF +* + WNORM = SLANKY( '1', 'L', N, WORK, N, WORK( N**2+1 ) ) +* + IF( ANORM.GT.WNORM ) THEN + RESULT( 1 ) = ( WNORM / ANORM ) / ( N*ULP ) + ELSE + IF( ANORM.LT.ONE ) THEN + RESULT( 1 ) = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP ) + ELSE + RESULT( 1 ) = MIN( WNORM / ANORM, REAL( N ) ) / ( N*ULP ) + END IF + END IF +* +* Do Test 2 +* +* Compute UU' - I +* + CALL SGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK, + $ N ) +* + DO 40 J = 1, N + WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE + 40 CONTINUE +* + RESULT( 2 ) = MIN( REAL( N ), SLANGE( '1', N, N, WORK, N, + $ WORK( N**2+1 ) ) ) / ( N*ULP ) +* + RETURN +* +* End of SKTT21 +* + END diff --git a/TESTING/EIG/skyt21.f b/TESTING/EIG/skyt21.f new file mode 100644 index 000000000..c4a6239ae --- /dev/null +++ b/TESTING/EIG/skyt21.f @@ -0,0 +1,410 @@ +*> \brief \b SKYT21 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SKYT21( ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V, +* LDV, TAU, WORK, RESULT ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER ITYPE, KBAND, LDA, LDU, LDV, N +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), D( * ), E( * ), RESULT( 2 ), +* $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SKYT21 generally checks a decomposition of the form +*> +*> A = U S U**T +*> +*> where **T means transpose, A is skew-symmetric, U is orthogonal, and S is +*> diagonal (if KBAND=0) or skew-symmetric tridiagonal (if KBAND=1). +*> +*> If ITYPE=1, then U is represented as a dense matrix; otherwise U is +*> expressed as a product of Householder transformations, whose vectors +*> are stored in the array "V" and whose scaling constants are in "TAU". +*> We shall use the letter "V" to refer to the product of Householder +*> transformations (which should be equal to U). +*> +*> Specifically, if ITYPE=1, then: +*> +*> RESULT(1) = | A - U S U**T | / ( |A| n ulp ) and +*> RESULT(2) = | I - U U**T | / ( n ulp ) +*> +*> If ITYPE=2, then: +*> +*> RESULT(1) = | A - V S V**T | / ( |A| n ulp ) +*> +*> If ITYPE=3, then: +*> +*> RESULT(1) = | I - V U**T | / ( n ulp ) +*> +*> For ITYPE > 1, the transformation U is expressed as a product +*> V = H(1)...H(n-2), where H(j) = I - tau(j) v(j) v(j)**T and each +*> vector v(j) has its first j elements 0 and the remaining n-j elements +*> stored in V(j+1:n,j). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] ITYPE +*> \verbatim +*> ITYPE is INTEGER +*> Specifies the type of tests to be performed. +*> 1: U expressed as a dense orthogonal matrix: +*> RESULT(1) = | A - U S U**T | / ( |A| n ulp ) and +*> RESULT(2) = | I - U U**T | / ( n ulp ) +*> +*> 2: U expressed as a product V of Housholder transformations: +*> RESULT(1) = | A - V S V**T | / ( |A| n ulp ) +*> +*> 3: U expressed both as a dense orthogonal matrix and +*> as a product of Housholder transformations: +*> RESULT(1) = | I - V U**T | / ( n ulp ) +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER +*> If UPLO='U', the upper triangle of A and V will be used and +*> the (strictly) lower triangle will not be referenced. +*> If UPLO='L', the lower triangle of A and V will be used and +*> the (strictly) upper triangle will not be referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The size of the matrix. If it is zero, SKYT21 does nothing. +*> It must be at least zero. +*> \endverbatim +*> +*> \param[in] KBAND +*> \verbatim +*> KBAND is INTEGER +*> The bandwidth of the matrix. It may only be zero or one. +*> If zero, then S is diagonal, and E is not referenced. If +*> one, then S is skew-symmetric tri-diagonal. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension (LDA, N) +*> The original (unfactored) matrix. It is assumed to be +*> skew-symmetric, and only the upper (UPLO='U') or only the lower +*> (UPLO='L') will be referenced. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of A. It must be at least 1 +*> and at least N. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is REAL array, dimension (N) +*> D is not referenced. +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is REAL array, dimension (N-1) +*> The (n-1) lower subdiagonal elements of the block diagonal matrix. +*> The matrix consists of 2-by-2 skew-symmetric blocks, and zeros. +*> Not referenced if KBAND=0. +*> \endverbatim +*> +*> \param[in] U +*> \verbatim +*> U is REAL array, dimension (LDU, N) +*> If ITYPE=1 or 3, this contains the orthogonal matrix in +*> the decomposition, expressed as a dense matrix. If ITYPE=2, +*> then it is not referenced. +*> \endverbatim +*> +*> \param[in] LDU +*> \verbatim +*> LDU is INTEGER +*> The leading dimension of U. LDU must be at least N and +*> at least 1. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is REAL array, dimension (LDV, N) +*> If ITYPE=2 or 3, the columns of this array contain the +*> Householder vectors used to describe the orthogonal matrix +*> in the decomposition. If UPLO='L', then the vectors are in +*> the lower triangle, if UPLO='U', then in the upper +*> triangle. +*> *NOTE* If ITYPE=2 or 3, V is modified and restored. The +*> subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U') +*> is set to one, and later reset to its original value, during +*> the course of the calculation. +*> If ITYPE=1, then it is neither referenced nor modified. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of V. LDV must be at least N and +*> at least 1. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is REAL array, dimension (N) +*> If ITYPE >= 2, then TAU(j) is the scalar factor of +*> v(j) v(j)**T in the Householder transformation H(j) of +*> the product U = H(1)...H(n-2) +*> If ITYPE < 2, then TAU is not referenced. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (2*N**2) +*> \endverbatim +*> +*> \param[out] RESULT +*> \verbatim +*> RESULT is REAL array, dimension (2) +*> The values computed by the two tests described above. The +*> values are currently limited to 1/ulp, to avoid overflow. +*> RESULT(1) is always modified. RESULT(2) is modified only +*> if ITYPE=1. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup single_eig +* +* ===================================================================== + SUBROUTINE SKYT21( ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V, + $ LDV, TAU, WORK, RESULT ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER ITYPE, KBAND, LDA, LDU, LDV, N +* .. +* .. Array Arguments .. + REAL A( LDA, * ), D( * ), E( * ), RESULT( 2 ), + $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE, TEN + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TEN = 10.0E0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER + CHARACTER CUPLO + INTEGER IINFO, J, JCOL, JR, JROW + REAL ANORM, ULP, UNFL, VSAVE, WNORM +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SLAMCH, SLANGE, SLANKY + EXTERNAL LSAME, SLAMCH, SLANGE, SLANKY +* .. +* .. External Subroutines .. + EXTERNAL SGEMM, SLACPY, SLARFYK, SLASET, SORM2L, SORM2R, + $ SSYR, SKYR2 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, REAL +* .. +* .. Executable Statements .. +* + RESULT( 1 ) = ZERO + IF( ITYPE.EQ.1 ) + $ RESULT( 2 ) = ZERO + IF( N.LE.0 ) + $ RETURN +* + IF( LSAME( UPLO, 'U' ) ) THEN + LOWER = .FALSE. + CUPLO = 'U' + ELSE + LOWER = .TRUE. + CUPLO = 'L' + END IF +* + UNFL = SLAMCH( 'Safe minimum' ) + ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) +* +* Some Error Checks +* + IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN + RESULT( 1 ) = TEN / ULP + RETURN + END IF +* +* Do Test 1 +* +* Norm of A: +* + IF( ITYPE.EQ.3 ) THEN + ANORM = ONE + ELSE + ANORM = MAX( SLANKY( '1', CUPLO, N, A, LDA, WORK ), UNFL ) + END IF +* +* Compute error matrix: +* + IF( ITYPE.EQ.1 ) THEN +* +* ITYPE=1: error = A - U S U**T +* + CALL SLASET( 'Full', N, N, ZERO, ZERO, WORK, N ) + CALL SLACPY( CUPLO, N, N, A, LDA, WORK, N ) +* + IF( N.GT.1 .AND. KBAND.EQ.1 ) THEN + DO 20 J = 1, N - 1 + CALL SKYR2( CUPLO, N, -E( J ), U( 1, J ), 1, + $ U( 1, J+1 ), 1, WORK, N ) + 20 CONTINUE + END IF + WNORM = SLANKY( '1', CUPLO, N, WORK, N, WORK( N**2+1 ) ) +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* ITYPE=2: error = V S V**T - A +* + CALL SLASET( 'Full', N, N, ZERO, ZERO, WORK, N ) +* + IF( LOWER ) THEN + WORK( N**2 ) = ZERO + DO 40 J = N - 1, 1, -1 + IF( KBAND.EQ.1 ) THEN + WORK( ( N+1 )*( J-1 )+2 ) = ( ONE-TAU( J ) )*E( J ) + DO 30 JR = J + 2, N + WORK( ( J-1 )*N+JR ) = -TAU( J )*E( J )*V( JR, J ) + 30 CONTINUE + END IF +* + VSAVE = V( J+1, J ) + V( J+1, J ) = ONE + CALL SLARFYK( 'L', N-J, V( J+1, J ), 1, TAU( J ), + $ WORK( ( N+1 )*J+1 ), N, WORK( N**2+1 ) ) + V( J+1, J ) = VSAVE + WORK( ( N+1 )*( J-1 )+1 ) = ZERO + 40 CONTINUE + ELSE + WORK( 1 ) = ZERO + DO 60 J = 1, N - 1 + IF( KBAND.EQ.1 ) THEN + WORK( ( N+1 )*J ) = ( ONE-TAU( J ) )*E( J ) + DO 50 JR = 1, J - 1 + WORK( J*N+JR ) = -TAU( J )*E( J )*V( JR, J+1 ) + 50 CONTINUE + END IF +* + VSAVE = V( J, J+1 ) + V( J, J+1 ) = ONE + CALL SLARFYK( 'U', J, V( 1, J+1 ), 1, TAU( J ), WORK, N, + $ WORK( N**2+1 ) ) + V( J, J+1 ) = VSAVE + WORK( ( N+1 )*J+1 ) = ZERO + 60 CONTINUE + END IF +* + DO 90 JCOL = 1, N + IF( LOWER ) THEN + DO 70 JROW = JCOL+1, N + WORK( JROW+N*( JCOL-1 ) ) = WORK( JROW+N*( JCOL-1 ) ) + $ - A( JROW, JCOL ) + 70 CONTINUE + ELSE + DO 80 JROW = 1, JCOL-1 + WORK( JROW+N*( JCOL-1 ) ) = WORK( JROW+N*( JCOL-1 ) ) + $ - A( JROW, JCOL ) + 80 CONTINUE + END IF + 90 CONTINUE + WNORM = SLANKY( '1', CUPLO, N, WORK, N, WORK( N**2+1 ) ) +* + ELSE IF( ITYPE.EQ.3 ) THEN +* +* ITYPE=3: error = U V**T - I +* + IF( N.LT.2 ) + $ RETURN + CALL SLACPY( ' ', N, N, U, LDU, WORK, N ) + IF( LOWER ) THEN + CALL SORM2R( 'R', 'T', N, N-1, N-1, V( 2, 1 ), LDV, TAU, + $ WORK( N+1 ), N, WORK( N**2+1 ), IINFO ) + ELSE + CALL SORM2L( 'R', 'T', N, N-1, N-1, V( 1, 2 ), LDV, TAU, + $ WORK, N, WORK( N**2+1 ), IINFO ) + END IF + IF( IINFO.NE.0 ) THEN + RESULT( 1 ) = TEN / ULP + RETURN + END IF +* + DO 100 J = 1, N + WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE + 100 CONTINUE +* + WNORM = SLANGE( '1', N, N, WORK, N, WORK( N**2+1 ) ) + END IF +* + IF( ANORM.GT.WNORM ) THEN + RESULT( 1 ) = ( WNORM / ANORM ) / ( N*ULP ) + ELSE + IF( ANORM.LT.ONE ) THEN + RESULT( 1 ) = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP ) + ELSE + RESULT( 1 ) = MIN( WNORM / ANORM, REAL( N ) ) / ( N*ULP ) + END IF + END IF +* +* Do Test 2 +* +* Compute U U**T - I +* + IF( ITYPE.EQ.1 ) THEN + CALL SGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK, + $ N ) +* + DO 110 J = 1, N + WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE + 110 CONTINUE +* + RESULT( 2 ) = MIN( SLANGE( '1', N, N, WORK, N, + $ WORK( N**2+1 ) ), REAL( N ) ) / ( N*ULP ) + END IF +* + RETURN +* +* End of SKYT21 +* + END diff --git a/TESTING/EIG/slarfyk.f b/TESTING/EIG/slarfyk.f new file mode 100644 index 000000000..53e4a9e42 --- /dev/null +++ b/TESTING/EIG/slarfyk.f @@ -0,0 +1,158 @@ +*> \brief \b SLARFYK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SLARFYK( UPLO, N, V, INCV, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER INCV, LDC, N +* REAL TAU +* .. +* .. Array Arguments .. +* REAL C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLARFYK applies an elementary reflector, or Householder matrix, H, +*> to an n x n skew-symmetric matrix C, from both the left and the right. +*> +*> H is represented in the form +*> +*> H = I - tau * v * v' +*> +*> where tau is a scalar and v is a vector. +*> +*> If tau is zero, then H is taken to be the unit matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> skew-symmetric matrix C is stored. +*> = 'U': Upper triangle +*> = 'L': Lower triangle +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is REAL array, dimension +*> (1 + (N-1)*abs(INCV)) +*> The vector v as described above. +*> \endverbatim +*> +*> \param[in] INCV +*> \verbatim +*> INCV is INTEGER +*> The increment between successive elements of v. INCV must +*> not be zero. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is REAL +*> The value tau as described above. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is REAL array, dimension (LDC, N) +*> On entry, the matrix C. +*> On exit, C is overwritten by H * C * H'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max( 1, N ). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (N) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup single_eig +* +* ===================================================================== + SUBROUTINE SLARFYK( UPLO, N, V, INCV, TAU, C, LDC, WORK ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INCV, LDC, N + REAL TAU +* .. +* .. Array Arguments .. + REAL C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO, HALF + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0, HALF = 0.5E+0 ) +* .. +* .. Local Scalars .. + REAL ALPHA +* .. +* .. External Subroutines .. + EXTERNAL SAXPY, SKYMV, SKYR2 +* .. +* .. External Functions .. + REAL SDOT + EXTERNAL SDOT +* .. +* .. Executable Statements .. +* + IF( TAU.EQ.ZERO ) + $ RETURN +* +* Form w:= C * v +* + CALL SKYMV( UPLO, N, ONE, C, LDC, V, INCV, ZERO, WORK, 1 ) +* + ALPHA = -HALF*TAU*SDOT( N, WORK, 1, V, INCV ) + CALL SAXPY( N, ALPHA, V, INCV, WORK, 1 ) +* +* C := C - v * w' - w * v' +* + CALL SKYR2( UPLO, N, -TAU, V, INCV, WORK, 1, C, LDC ) +* + RETURN +* +* End of SLARFYK +* + END diff --git a/TESTING/LIN/CMakeLists.txt b/TESTING/LIN/CMakeLists.txt index e28818c76..1b01bb0ab 100644 --- a/TESTING/LIN/CMakeLists.txt +++ b/TESTING/LIN/CMakeLists.txt @@ -10,7 +10,7 @@ set(SLINTST schkaa.F schkeq.f schkgb.f schkge.f schkgt.f schklq.f schkpb.f schkpo.f schkps.f schkpp.f schkpt.f schkq3.f schkqp3rk.f schkql.f schkqr.f schkrq.f - schksp.f schksy.f schksy_rook.f schksy_rk.f + schksp.f schksy.f schkky.f schksy_rook.f schksy_rk.f schksy_aa.f schksy_aa_2stage.f schktb.f schktp.f schktr.f schktz.f @@ -24,15 +24,15 @@ set(SLINTST schkaa.F sgerqs.f sget01.f sget02.f sget03.f sget04.f sget06.f sget07.f sgtt01.f sgtt02.f sgtt05.f slaptm.f slarhs.f slatb4.f slatb5.f slattb.f slattp.f - slattr.f slavsp.f slavsy.f slavsy_rook.f slqt01.f slqt02.f + slattr.f slavsp.f slavsy.f slavky.f slavsy_rook.f slqt01.f slqt02.f slqt03.f spbt01.f spbt02.f spbt05.f spot01.f - spot02.f spot03.f spot05.f spst01.f sppt01.f + spot02.f spot03.f spot05.f spot07.f spot08.f spst01.f sppt01.f sppt02.f sppt03.f sppt05.f sptt01.f sptt02.f sptt05.f sqlt01.f sqlt02.f sqlt03.f sqpt01.f sqrt01.f sqrt01p.f sqrt02.f sqrt03.f sqrt11.f sqrt12.f sqrt13.f sqrt14.f sqrt15.f sqrt16.f sqrt17.f srqt01.f srqt02.f srqt03.f srzt01.f srzt02.f - sspt01.f ssyt01.f ssyt01_rook.f ssyt01_3.f + sspt01.f ssyt01.f skyt01.f ssyt01_rook.f ssyt01_3.f ssyt01_aa.f stbt02.f stbt03.f stbt05.f stbt06.f stpt01.f stpt02.f stpt03.f stpt05.f stpt06.f strt01.f @@ -43,12 +43,12 @@ set(SLINTST schkaa.F schkorhr_col.f serrorhr_col.f sorhr_col01.f sorhr_col02.f) if(USE_XBLAS) - list(APPEND SLINTST sdrvgbx.f sdrvgex.f sdrvsyx.f sdrvpox.f - serrvxx.f serrgex.f serrsyx.f serrpox.f + list(APPEND SLINTST sdrvgbx.f sdrvgex.f sdrvsyx.f sdrvky.f sdrvpox.f + serrvxx.f serrgex.f serrsyx.f serrkyx.f serrpox.f sebchvxx.f) else() - list(APPEND SLINTST sdrvgb.f sdrvge.f sdrvsy.f sdrvpo.f - serrvx.f serrge.f serrsy.f serrpo.f) + list(APPEND SLINTST sdrvgb.f sdrvge.f sdrvsy.f sdrvky.f sdrvpo.f + serrvx.f serrge.f serrsy.f serrky.f serrpo.f) endif() set(CLINTST cchkaa.F @@ -111,7 +111,7 @@ set(DLINTST dchkaa.F dchkeq.f dchkgb.f dchkge.f dchkgt.f dchklq.f dchkpb.f dchkpo.f dchkps.f dchkpp.f dchkpt.f dchkq3.f dchkqp3rk.f dchkql.f dchkqr.f dchkrq.f - dchksp.f dchksy.f dchksy_rook.f dchksy_rk.f + dchksp.f dchksy.f dchkky.f dchksy_rook.f dchksy_rk.f dchksy_aa.f dchksy_aa_2stage.f dchktb.f dchktp.f dchktr.f dchktz.f @@ -125,15 +125,15 @@ set(DLINTST dchkaa.F dgerqs.f dget01.f dget02.f dget03.f dget04.f dget06.f dget07.f dgtt01.f dgtt02.f dgtt05.f dlaptm.f dlarhs.f dlatb4.f dlatb5.f dlattb.f dlattp.f - dlattr.f dlavsp.f dlavsy.f dlavsy_rook.f dlqt01.f dlqt02.f + dlattr.f dlavsp.f dlavsy.f dlavky.f dlavsy_rook.f dlqt01.f dlqt02.f dlqt03.f dpbt01.f dpbt02.f dpbt05.f dpot01.f - dpot02.f dpot03.f dpot05.f dpst01.f dppt01.f + dpot02.f dpot03.f dpot05.f dpot07.f dpot08.f dpst01.f dppt01.f dppt02.f dppt03.f dppt05.f dptt01.f dptt02.f dptt05.f dqlt01.f dqlt02.f dqlt03.f dqpt01.f dqrt01.f dqrt01p.f dqrt02.f dqrt03.f dqrt11.f dqrt12.f dqrt13.f dqrt14.f dqrt15.f dqrt16.f dqrt17.f drqt01.f drqt02.f drqt03.f drzt01.f drzt02.f - dspt01.f dsyt01.f dsyt01_rook.f dsyt01_3.f + dspt01.f dsyt01.f dkyt01.f dsyt01_rook.f dsyt01_3.f dsyt01_aa.f dtbt02.f dtbt03.f dtbt05.f dtbt06.f dtpt01.f dtpt02.f dtpt03.f dtpt05.f dtpt06.f dtrt01.f @@ -145,12 +145,12 @@ set(DLINTST dchkaa.F dchkorhr_col.f derrorhr_col.f dorhr_col01.f dorhr_col02.f) if(USE_XBLAS) - list(APPEND DLINTST ddrvgbx.f ddrvgex.f ddrvsyx.f ddrvpox.f - derrvxx.f derrgex.f derrsyx.f derrpox.f + list(APPEND DLINTST ddrvgbx.f ddrvgex.f ddrvsyx.f ddrvky.f ddrvpox.f + derrvxx.f derrgex.f derrsyx.f derrkyx.f derrpox.f debchvxx.f) else() - list(APPEND DLINTST ddrvgb.f ddrvge.f ddrvsy.f ddrvpo.f - derrvx.f derrge.f derrsy.f derrpo.f) + list(APPEND DLINTST ddrvgb.f ddrvge.f ddrvsy.f ddrvky.f ddrvpo.f + derrvx.f derrge.f derrsy.f derrky.f derrpo.f) endif() set(ZLINTST zchkaa.F diff --git a/TESTING/LIN/Makefile b/TESTING/LIN/Makefile index 46e096c2f..f41484c24 100644 --- a/TESTING/LIN/Makefile +++ b/TESTING/LIN/Makefile @@ -46,7 +46,7 @@ SLINTST = schkaa.o \ schkeq.o schkgb.o schkge.o schkgt.o \ schklq.o schkpb.o schkpo.o schkps.o schkpp.o \ schkpt.o schkq3.o schkqp3rk.o schkql.o schkqr.o schkrq.o \ - schksp.o schksy.o schksy_rook.o schksy_rk.o \ + schksp.o schksy.o schkky.o schksy_rook.o schksy_rk.o \ schksy_aa.o schksy_aa_2stage.o schktb.o schktp.o schktr.o \ schktz.o \ sdrvgt.o sdrvls.o sdrvpb.o \ @@ -59,15 +59,15 @@ SLINTST = schkaa.o \ sgerqs.o sget01.o sget02.o \ sget03.o sget04.o sget06.o sget07.o sgtt01.o sgtt02.o \ sgtt05.o slaptm.o slarhs.o slatb4.o slatb5.o slattb.o slattp.o \ - slattr.o slavsp.o slavsy.o slavsy_rook.o slqt01.o slqt02.o \ + slattr.o slavsp.o slavsy.o slavky.o slavsy_rook.o slqt01.o slqt02.o \ slqt03.o spbt01.o spbt02.o spbt05.o spot01.o \ - spot02.o spot03.o spot05.o spst01.o sppt01.o \ + spot02.o spot03.o spot05.o spot07.o spot08.o spst01.o sppt01.o \ sppt02.o sppt03.o sppt05.o sptt01.o sptt02.o \ sptt05.o sqlt01.o sqlt02.o sqlt03.o sqpt01.o \ sqrt01.o sqrt01p.o sqrt02.o sqrt03.o sqrt11.o sqrt12.o \ sqrt13.o sqrt14.o sqrt15.o sqrt16.o sqrt17.o \ srqt01.o srqt02.o srqt03.o srzt01.o srzt02.o \ - sspt01.o ssyt01.o ssyt01_rook.o ssyt01_3.o ssyt01_aa.o \ + sspt01.o ssyt01.o skyt01.o ssyt01_rook.o ssyt01_3.o ssyt01_aa.o \ stbt02.o stbt03.o stbt05.o stbt06.o stpt01.o \ stpt02.o stpt03.o stpt05.o stpt06.o strt01.o \ strt02.o strt03.o strt05.o strt06.o \ @@ -77,12 +77,12 @@ SLINTST = schkaa.o \ schkorhr_col.o serrorhr_col.o sorhr_col01.o sorhr_col02.o ifdef USEXBLAS -SLINTST += sdrvgbx.o sdrvgex.o sdrvsyx.o sdrvpox.o \ - serrvxx.o serrgex.o serrsyx.o serrpox.o \ +SLINTST += sdrvgbx.o sdrvgex.o sdrvsyx.o sdrvky.o sdrvpox.o \ + serrvxx.o serrgex.o serrsyx.o serrkyx.o serrpox.o \ sebchvxx.o else -SLINTST += sdrvgb.o sdrvge.o sdrvsy.o sdrvpo.o \ - serrvx.o serrge.o serrsy.o serrpo.o +SLINTST += sdrvgb.o sdrvge.o sdrvsy.o sdrvky.o sdrvpo.o \ + serrvx.o serrge.o serrsy.o serrky.o serrpo.o endif CLINTST = cchkaa.o \ @@ -138,7 +138,7 @@ DLINTST = dchkaa.o \ dchkeq.o dchkgb.o dchkge.o dchkgt.o \ dchklq.o dchkpb.o dchkpo.o dchkps.o dchkpp.o \ dchkpt.o dchkq3.o dchkqp3rk.o dchkql.o dchkqr.o dchkrq.o \ - dchksp.o dchksy.o dchksy_rook.o dchksy_rk.o \ + dchksp.o dchksy.o dchkky.o dchksy_rook.o dchksy_rk.o \ dchksy_aa.o dchksy_aa_2stage.o dchktb.o dchktp.o dchktr.o \ dchktz.o \ ddrvgt.o ddrvls.o ddrvpb.o \ @@ -151,15 +151,15 @@ DLINTST = dchkaa.o \ dgerqs.o dget01.o dget02.o \ dget03.o dget04.o dget06.o dget07.o dgtt01.o dgtt02.o \ dgtt05.o dlaptm.o dlarhs.o dlatb4.o dlatb5.o dlattb.o dlattp.o \ - dlattr.o dlavsp.o dlavsy.o dlavsy_rook.o dlqt01.o dlqt02.o \ + dlattr.o dlavsp.o dlavsy.o dlavky.o dlavsy_rook.o dlqt01.o dlqt02.o \ dlqt03.o dpbt01.o dpbt02.o dpbt05.o dpot01.o \ - dpot02.o dpot03.o dpot05.o dpst01.o dppt01.o \ + dpot02.o dpot03.o dpot05.o dpot07.o dpot08.o dpst01.o dppt01.o \ dppt02.o dppt03.o dppt05.o dptt01.o dptt02.o \ dptt05.o dqlt01.o dqlt02.o dqlt03.o dqpt01.o \ dqrt01.o dqrt01p.o dqrt02.o dqrt03.o dqrt11.o dqrt12.o \ dqrt13.o dqrt14.o dqrt15.o dqrt16.o dqrt17.o \ drqt01.o drqt02.o drqt03.o drzt01.o drzt02.o \ - dspt01.o dsyt01.o dsyt01_rook.o dsyt01_3.o dsyt01_aa.o \ + dspt01.o dsyt01.o dkyt01.o dsyt01_rook.o dsyt01_3.o dsyt01_aa.o \ dtbt02.o dtbt03.o dtbt05.o dtbt06.o dtpt01.o \ dtpt02.o dtpt03.o dtpt05.o dtpt06.o dtrt01.o \ dtrt02.o dtrt03.o dtrt05.o dtrt06.o \ @@ -170,12 +170,12 @@ DLINTST = dchkaa.o \ dchkorhr_col.o derrorhr_col.o dorhr_col01.o dorhr_col02.o ifdef USEXBLAS -DLINTST += ddrvgbx.o ddrvgex.o ddrvsyx.o ddrvpox.o \ - derrvxx.o derrgex.o derrsyx.o derrpox.o \ +DLINTST += ddrvgbx.o ddrvgex.o ddrvsyx.o ddrvky.o ddrvpox.o \ + derrvxx.o derrgex.o derrsyx.o derrkyx.o derrpox.o \ debchvxx.o else -DLINTST += ddrvgb.o ddrvge.o ddrvsy.o ddrvpo.o \ - derrvx.o derrge.o derrsy.o derrpo.o +DLINTST += ddrvgb.o ddrvge.o ddrvsy.o ddrvky.o ddrvpo.o \ + derrvx.o derrge.o derrsy.o derrky.o derrpo.o endif ZLINTST = zchkaa.o \ diff --git a/TESTING/LIN/dchkaa.F b/TESTING/LIN/dchkaa.F index 6582cac13..3a4e4961b 100644 --- a/TESTING/LIN/dchkaa.F +++ b/TESTING/LIN/dchkaa.F @@ -50,6 +50,7 @@ *> DPB 8 List types on next line if 0 < NTYPES < 8 *> DPT 12 List types on next line if 0 < NTYPES < 12 *> DSY 10 List types on next line if 0 < NTYPES < 10 +*> DKY 10 List types on next line if 0 < NTYPES < 10 *> DSR 10 List types on next line if 0 < NTYPES < 10 *> DSK 10 List types on next line if 0 < NTYPES < 10 *> DSA 10 List types on next line if 0 < NTYPES < 10 @@ -171,7 +172,7 @@ PROGRAM DCHKAA $ DDRVGB, DDRVGE, DDRVGT, DDRVLS, DDRVPB, DDRVPO, $ DDRVPP, DDRVPT, DDRVSP, DDRVSY, DDRVSY_ROOK, $ DDRVSY_RK, DDRVSY_AA, ILAVER, DCHKLQTP, DCHKQRT, - $ DCHKQRTP, DCHKLQT,DCHKTSQR + $ DCHKQRTP, DCHKLQT,DCHKTSQR, DCHKKY * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -663,6 +664,32 @@ PROGRAM DCHKAA ELSE WRITE( NOUT, FMT = 9988 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'KY' ) ) THEN +* +* KY: skew-symmetric indefinite matrices, +* with Bunch-Kaufman diagonal pivoting algorithm +* + NTYPES = 10 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL DCHKKY( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), + $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL DDRVKY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, LDA, + $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ), + $ B( 1, 2 ), B( 1, 3 ), WORK, RWORK, IWORK, + $ NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * diff --git a/TESTING/LIN/dchkky.f b/TESTING/LIN/dchkky.f new file mode 100644 index 000000000..acdd84b5f --- /dev/null +++ b/TESTING/LIN/dchkky.f @@ -0,0 +1,627 @@ +*> \brief \b DCHKKY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DCHKKY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, +* XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), +* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DCHKKY tests DKYTRF, -TRI2, -TRS, -TRS2. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NNB) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is DOUBLE PRECISION array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX)) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DCHKKY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, + $ XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NNB, NNS, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), + $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 10 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 9 ) +* .. +* .. Local Scalars .. + LOGICAL TRFCON, ZEROT, LSAME + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE, + $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT + DOUBLE PRECISION ANORM, CNDNUM, RCOND, RCONDC +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, DERRSY, DGET04, DLACPY, + $ DLARHS, DLATB4, DLATMS, DPOT08, DPOT07, + $ DKYT01, DKYTRF, + $ DKYTRI2, DKYTRS, DKYTRS2, LSAME, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Double precision' + PATH( 2: 3 ) = 'KY' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL DERRKY( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 2 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT, except IMAT.EQ.1 +* + DO 170 IMAT = 2, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 + IF (MOD(N,2).NE.0) + $ ZEROT = .FALSE. +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with DLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, + $ CNDNUM, DIST ) +* +* Generate a matrix with DLATMS. +* + SRNAMT = 'DLATMS' + CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from DLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 160 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* +* Do for each value of NB in NBVAL +* + DO 150 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'DKYTRF' + CALL DKYTRF( UPLO, N, AFAC, LDA, IWORK, AINV, LWORK, + $ INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF (MOD(N,2).NE.0 .AND. LSAME( UPLO, 'U' )) THEN + K = 1 + ELSEIF (MOD(N,2).NE.0 .AND. LSAME( UPLO, 'L' )) THEN + K = N + ELSEIF( K.GT.0 ) THEN + 100 CONTINUE + IF(LSAME( UPLO, 'U' )) THEN + IF(MOD(N-K+1,2).NE.0 .AND. IWORK(K).LT.0) THEN + K = -IWORK( K ) + GO TO 100 + ELSEIF(MOD(N-K+1,2).EQ.0 .AND. IWORK(K+1).GT.0) + $ THEN + K = IWORK( K+1 ) + GO TO 100 + ELSEIF(MOD(N-K+1,2).EQ.0 .AND. IWORK(K+1).EQ.0) + $ THEN + K = K+1 + END IF + ELSE IF(LSAME( UPLO, 'L' )) THEN + IF(MOD(K,2).NE.0 .AND. IWORK(K).LT.0) THEN + K = -IWORK( K ) + GO TO 100 + ELSEIF(MOD(K,2).EQ.0 .AND. IWORK(K-1).GT.0) THEN + K = IWORK( K-1 ) + GO TO 100 + ELSEIF(MOD(K,2).EQ.0 .AND. IWORK(K-1).EQ.0) THEN + K = K-1 + END IF + END IF + END IF +* +* Check error code from DKYTRF and handle error. +* + IF( INFO.NE.K ) + $ CALL ALAERH( PATH, 'DKYTRF', INFO, K, UPLO, N, N, + $ -1, -1, NB, IMAT, NFAIL, NERRS, NOUT ) +* +* Set the condition estimate flag if the INFO is not 0. +* + IF( INFO.NE.0 ) THEN + TRFCON = .TRUE. + ELSE + TRFCON = .FALSE. + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL DKYT01( UPLO, N, A, LDA, AFAC, LDA, IWORK, AINV, + $ LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +*+ TEST 2 +* Form the inverse and compute the residual, +* if the factorization was competed without INFO > 0 +* (i.e. there is no zero rows and columns). +* + IF( .NOT.TRFCON ) THEN + CALL DLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + SRNAMT = 'DKYTRI2' + LWORK = (N+NB+1)*(NB+3) + CALL DKYTRI2( UPLO, N, AINV, LDA, IWORK, WORK, + $ LWORK, INFO ) +* +* Check error code from DKYTRI2 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'DKYTRI2', INFO, -1, UPLO, N, + $ N, -1, -1, -1, IMAT, NFAIL, NERRS, + $ NOUT ) +* +* Compute the residual for a skew-symmetric matrix times +* its inverse. +* + CALL DPOT08( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, + $ RWORK, RCONDC, RESULT( 2 ) ) + NT = 2 + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +* Skip the other tests if this is not the first block +* size. +* + IF( INB.GT.1 .OR. TRFCON ) + $ GO TO 150 +* +* Do for each value of NRHS in NSVAL. +* + DO 130 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 3 (Using DSYTRS) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'DLARHS' + CALL DLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, + $ ISEED, INFO ) + CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'DKYTRS' + CALL DKYTRS( UPLO, N, NRHS, AFAC, LDA, IWORK, X, + $ LDA, INFO ) +* +* Check error code from DKYTRS and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'DKYTRS', INFO, 0, UPLO, N, + $ N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) +* + CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL DPOT07( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 3 ) ) +* +*+ TEST 4 (Using DSYTRS2) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'DLARHS' + CALL DLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, + $ ISEED, INFO ) + CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'DSYTRS2' + CALL DKYTRS2( UPLO, N, NRHS, AFAC, LDA, IWORK, X, + $ LDA, WORK, INFO ) +* +* Check error code from DKYTRS2 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'DKYTRS2', INFO, 0, UPLO, N, + $ N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) +* + CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL DPOT07( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 4 ) ) +* +*+ TEST 5 +* Check solution from generated exact solution. +* + CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 5 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 120 K = 3, 5 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 120 CONTINUE + NRUN = NRUN + 3 +* +* End do for each value of NRHS in NSVAL. +* + 130 CONTINUE +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test(', I2, ') =', G12.5 ) + 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, + $ ', test(', I2, ') =', G12.5 ) + RETURN +* +* End of DCHKKY +* + END diff --git a/TESTING/LIN/ddrvky.f b/TESTING/LIN/ddrvky.f new file mode 100644 index 000000000..b6218a8fc --- /dev/null +++ b/TESTING/LIN/ddrvky.f @@ -0,0 +1,528 @@ +*> \brief \b DDRVKY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DDRVKY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, +* A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, +* NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), +* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DDRVKY tests the driver routines DKYSV. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is DOUBLE PRECISION array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (NMAX*max(2,NRHS)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DDRVKY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, + $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, + $ NOUT ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + LOGICAL TSTERR, LSAME + INTEGER NMAX, NN, NOUT, NRHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), + $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 6 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 PATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, K1, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCOND, RCONDC +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Functions .. + DOUBLE PRECISION DGET06, DLANKY + EXTERNAL DGET06, DLANKY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, DGET04, DLACPY, + $ DLARHS, DLASET, DLATB4, DLATMS, DPOT07, + $ DKYSV, DKYT01, DKYTRF, DKYTRI2, LSAME, XLAENV +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Double precision' + PATH( 2: 3 ) = 'KY' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL DERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for testing. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 2 +* +* Do for each value of matrix type IMAT, except IMAT.EQ.1 +* + DO 170 IMAT = 2, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 + IF (MOD(N,2).NE.0) + $ ZEROT = .FALSE. +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Set up parameters with DLATB4 and generate a test matrix +* with DLATMS. +* + CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, + $ CNDNUM, DIST ) +* + SRNAMT = 'DLATMS' + CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from DLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of the +* matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IOFF = 0 + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Compute the condition number. +* + IF( ZEROT ) THEN + IF( IFACT.EQ.1 ) + $ GO TO 150 + RCONDC = ZERO +* + ELSE IF( IFACT.EQ.1 ) THEN +* +* Compute the 1-norm of A. +* + ANORM = DLANKY( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* + CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL DKYTRF( UPLO, N, AFAC, LDA, IWORK, WORK, + $ LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* + CALL DLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + LWORK = (N+NB+1)*(NB+3) + CALL DKYTRI2( UPLO, N, AINV, LDA, IWORK, WORK, + $ LWORK, INFO ) + AINVNM = DLANKY( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'DLARHS' + CALL DLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test DKYSV --- +* + IF( IFACT.EQ.2 ) THEN + CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using DKYSV. +* + SRNAMT = 'DKYSV ' + CALL DKYSV( UPLO, N, NRHS, AFAC, LDA, IWORK, X, + $ LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF (MOD(N,2).NE.0 .AND. LSAME( UPLO, 'U' )) THEN + K = 1 + ELSEIF (MOD(N,2).NE.0 .AND. LSAME( UPLO, 'L' )) + $ THEN + K = N + ELSEIF( K.GT.0 ) THEN + 100 CONTINUE + IF(LSAME( UPLO, 'U' )) THEN + IF(MOD(N-K+1,2).NE.0 .AND. IWORK(K).LT.0) + $ THEN + K = -IWORK( K ) + GO TO 100 + ELSEIF(MOD(N-K+1,2).EQ.0 .AND. + $ IWORK(K+1).GT.0) THEN + K = IWORK( K+1 ) + GO TO 100 + ELSEIF(MOD(N-K+1,2).EQ.0 .AND. + $ IWORK(K+1).EQ.0) THEN + K = K+1 + END IF + ELSE IF(LSAME( UPLO, 'L' )) THEN + IF(MOD(K,2).NE.0 .AND. IWORK(K).LT.0) + $ THEN + K = -IWORK( K ) + GO TO 100 + ELSEIF(MOD(K,2).EQ.0 .AND. IWORK(K-1).GT.0) + $ THEN + K = IWORK( K-1 ) + GO TO 100 + ELSEIF(MOD(K,2).EQ.0 .AND. IWORK(K-1).EQ.0) + $ THEN + K = K-1 + END IF + END IF + END IF +* +* Check error code from DKYSV . +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'DKYSV ', INFO, K, UPLO, N, + $ N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL DKYT01( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) +* +* Compute residual of the computed solution. +* + CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL DPOT07( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 3 ) ) + NT = 3 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'DKYSV ', UPLO, N, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N =', I5, + $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of DDRVKY +* + END diff --git a/TESTING/LIN/derrky.f b/TESTING/LIN/derrky.f new file mode 100644 index 000000000..ad3eb275f --- /dev/null +++ b/TESTING/LIN/derrky.f @@ -0,0 +1,234 @@ +*> \brief \b DERRKY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DERRKY( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DERRKY tests the error exits for the DOUBLE PRECISION routines +*> for skew-symmetric indefinite matrices. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DERRKY( PATH, NUNIT ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 4 ) +* .. +* .. Local Scalars .. + CHARACTER*2 C2 + INTEGER I, INFO, J + DOUBLE PRECISION ANRM, RCOND +* .. +* .. Local Arrays .. + INTEGER IP( NMAX ), IW( NMAX ) + DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), + $ E( NMAX ), R1( NMAX ), R2( NMAX ), W( 3*NMAX ), + $ X( NMAX ) +* .. +* .. External Functions .. + LOGICAL LSAMEN + EXTERNAL LSAMEN +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, DKYTRI2X, DKYTF2, + $ DKYTRF, DKYTRI, DKYTRS, DKYTRI2 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) + C2 = PATH( 2: 3 ) +* +* Set the variables to innocuous values. +* + DO 20 J = 1, NMAX + DO 10 I = 1, NMAX + A( I, J ) = 1. / DBLE( I+J ) + AF( I, J ) = 1. / DBLE( I+J ) + 10 CONTINUE + B( J ) = 0.E+0 + E( J ) = 0.E+0 + R1( J ) = 0.E+0 + R2( J ) = 0.E+0 + W( J ) = 0.E+0 + X( J ) = 0.E+0 + IP( J ) = J + IW( J ) = J + 20 CONTINUE + ANRM = 1.0 + RCOND = 1.0 + OK = .TRUE. +* + IF( LSAMEN( 2, C2, 'KY' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a skew-symmetric indefinite matrix with patrial +* (Bunch-Kaufman) pivoting. +* +* DKYTRF +* + SRNAMT = 'DKYTRF' + INFOT = 1 + CALL DKYTRF( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DKYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DKYTRF( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DKYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DKYTRF( 'U', 2, A, 1, IP, W, 4, INFO ) + CALL CHKXER( 'DKYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DKYTRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'DKYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DKYTRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'DKYTRF', INFOT, NOUT, LERR, OK ) +* +* DKYTF2 +* + SRNAMT = 'DKYTF2' + INFOT = 1 + CALL DKYTF2( '/', 0, A, 1, IP, INFO ) + CALL CHKXER( 'DKYTF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DKYTF2( 'U', -1, A, 1, IP, INFO ) + CALL CHKXER( 'DKYTF2', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DKYTF2( 'U', 2, A, 1, IP, INFO ) + CALL CHKXER( 'DKYTF2', INFOT, NOUT, LERR, OK ) +* +* DKYTRI +* + SRNAMT = 'DKYTRI' + INFOT = 1 + CALL DKYTRI( '/', 0, A, 1, IP, W, INFO ) + CALL CHKXER( 'DKYTRI', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DKYTRI( 'U', -1, A, 1, IP, W, INFO ) + CALL CHKXER( 'DKYTRI', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DKYTRI( 'U', 2, A, 1, IP, W, INFO ) + CALL CHKXER( 'DKYTRI', INFOT, NOUT, LERR, OK ) +* +* DKYTRI2 +* + SRNAMT = 'DKYTRI2' + INFOT = 1 + CALL DKYTRI2( '/', 0, A, 1, IP, W, IW(1), INFO ) + CALL CHKXER( 'DKYTRI2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DKYTRI2( 'U', -1, A, 1, IP, W, IW(1), INFO ) + CALL CHKXER( 'DKYTRI2', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DKYTRI2( 'U', 2, A, 1, IP, W, IW(1), INFO ) + CALL CHKXER( 'DKYTRI2', INFOT, NOUT, LERR, OK ) +* +* DKYTRI2X +* + SRNAMT = 'DKYTRI2X' + INFOT = 1 + CALL DKYTRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DKYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DKYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DKYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DKYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DKYTRI2X', INFOT, NOUT, LERR, OK ) +* +* DKYTRS +* + SRNAMT = 'DKYTRS' + INFOT = 1 + CALL DKYTRS( '/', 0, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'DKYTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DKYTRS( 'U', -1, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'DKYTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DKYTRS( 'U', 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'DKYTRS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DKYTRS( 'U', 2, 1, A, 1, IP, B, 2, INFO ) + CALL CHKXER( 'DKYTRS', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DKYTRS( 'U', 2, 1, A, 2, IP, B, 1, INFO ) + CALL CHKXER( 'DKYTRS', INFOT, NOUT, LERR, OK ) +* + END IF +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of DERRKY +* + END diff --git a/TESTING/LIN/derrkyx.f b/TESTING/LIN/derrkyx.f new file mode 100644 index 000000000..c34eed423 --- /dev/null +++ b/TESTING/LIN/derrkyx.f @@ -0,0 +1,238 @@ +*> \brief \b DERRKYX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SERRKY( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SERRKY tests the error exits for the DOUBLE PRECISION routines +*> for symmetric indefinite matrices. +*> +*> Note that this file is used only when the XBLAS are available, +*> otherwise serrsy.f defines this subroutine. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE SERRKY( PATH, NUNIT ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 4 ) +* .. +* .. Local Scalars .. + CHARACTER EQ + CHARACTER*2 C2 + INTEGER I, INFO, J, N_ERR_BNDS, NPARAMS + DOUBLE PRECISION ANRM, RCOND, BERR +* .. +* .. Local Arrays .. + INTEGER IP( NMAX ), IW( NMAX ) + DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), + $ E( NMAX ), R1( NMAX ), R2( NMAX ), W( 3*NMAX ), + $ X( NMAX ), S( NMAX ), ERR_BNDS_N( NMAX, 3 ), + $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) +* .. +* .. External Functions .. + LOGICAL LSAMEN + EXTERNAL LSAMEN +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, DKYTF2, DKYTRF, + $ DKYTRI, DKYTRI2, DKYTRI2X, DKYTRS +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC DOUBLE PRECISION +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) + C2 = PATH( 2: 3 ) +* +* Set the variables to innocuous values. +* + DO 20 J = 1, NMAX + DO 10 I = 1, NMAX + A( I, J ) = 1. / DOUBLE PRECISION( I+J ) + AF( I, J ) = 1. / DOUBLE PRECISION( I+J ) + 10 CONTINUE + B( J ) = 0.E+0 + E( J ) = 0.E+0 + R1( J ) = 0.E+0 + R2( J ) = 0.E+0 + W( J ) = 0.E+0 + X( J ) = 0.E+0 + IP( J ) = J + IW( J ) = J + 20 CONTINUE + ANRM = 1.0 + RCOND = 1.0 + OK = .TRUE. +* + IF( LSAMEN( 2, C2, 'KY' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with patrial +* (Bunch-Kaufman) pivoting. +* +* DKYTRF +* + SRNAMT = 'DKYTRF' + INFOT = 1 + CALL DKYTRF( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DKYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DKYTRF( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DKYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DKYTRF( 'U', 2, A, 1, IP, W, 4, INFO ) + CALL CHKXER( 'DKYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DKYTRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'DKYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DKYTRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'DKYTRF', INFOT, NOUT, LERR, OK ) +* +* DKYTF2 +* + SRNAMT = 'DKYTF2' + INFOT = 1 + CALL DKYTF2( '/', 0, A, 1, IP, INFO ) + CALL CHKXER( 'DKYTF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DKYTF2( 'U', -1, A, 1, IP, INFO ) + CALL CHKXER( 'DKYTF2', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DKYTF2( 'U', 2, A, 1, IP, INFO ) + CALL CHKXER( 'DKYTF2', INFOT, NOUT, LERR, OK ) +* +* DKYTRI +* + SRNAMT = 'DKYTRI' + INFOT = 1 + CALL DKYTRI( '/', 0, A, 1, IP, W, INFO ) + CALL CHKXER( 'DKYTRI', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DKYTRI( 'U', -1, A, 1, IP, W, INFO ) + CALL CHKXER( 'DKYTRI', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DKYTRI( 'U', 2, A, 1, IP, W, INFO ) + CALL CHKXER( 'DKYTRI', INFOT, NOUT, LERR, OK ) +* +* DKYTRI2 +* + SRNAMT = 'DKYTRI2' + INFOT = 1 + CALL DKYTRI2( '/', 0, A, 1, IP, W, IW, INFO ) + CALL CHKXER( 'DKYTRI', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DKYTRI2( 'U', -1, A, 1, IP, W, IW, INFO ) + CALL CHKXER( 'DKYTRI', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DKYTRI2( 'U', 2, A, 1, IP, W, IW, INFO ) + CALL CHKXER( 'DKYTRI', INFOT, NOUT, LERR, OK ) +* +* DKYTRI2X +* + SRNAMT = 'DKYTRI2X' + INFOT = 1 + CALL DKYTRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DKYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DKYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DKYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DKYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DKYTRI2X', INFOT, NOUT, LERR, OK ) +* +* DKYTRS +* + SRNAMT = 'DKYTRS' + INFOT = 1 + CALL DKYTRS( '/', 0, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'DKYTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DKYTRS( 'U', -1, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'DKYTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DKYTRS( 'U', 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'DKYTRS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DKYTRS( 'U', 2, 1, A, 1, IP, B, 2, INFO ) + CALL CHKXER( 'DKYTRS', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DKYTRS( 'U', 2, 1, A, 2, IP, B, 1, INFO ) + CALL CHKXER( 'DKYTRS', INFOT, NOUT, LERR, OK ) + END IF +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of DERRKYX +* + END diff --git a/TESTING/LIN/derrvx.f b/TESTING/LIN/derrvx.f index f2d29f7a3..132182438 100644 --- a/TESTING/LIN/derrvx.f +++ b/TESTING/LIN/derrvx.f @@ -89,7 +89,7 @@ SUBROUTINE DERRVX( PATH, NUNIT ) $ DGTSVX, DPBSV, DPBSVX, DPOSV, DPOSVX, DPPSV, $ DPPSVX, DPTSV, DPTSVX, DSPSV, DSPSVX, DSYSV, $ DSYSV_AA, DSYSV_RK, DSYSV_ROOK, DSYSVX, - $ DSYSV_AA_2STAGE + $ DSYSV_AA_2STAGE, DKYSV * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -634,6 +634,33 @@ SUBROUTINE DERRVX( PATH, NUNIT ) CALL DSYSVX( 'N', 'U', 2, 0, A, 2, AF, 2, IP, B, 2, X, 2, $ RCOND, R1, R2, W, 3, IW, INFO ) CALL CHKXER( 'DSYSVX', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'KY' ) ) THEN +* +* DKYSV +* + SRNAMT = 'DKYSV ' + INFOT = 1 + CALL DKYSV( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DKYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DKYSV( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DKYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DKYSV( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DKYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DKYSV( 'U', 2, 0, A, 1, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'DKYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DKYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DKYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DKYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'DKYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DKYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'DKYSV ', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * diff --git a/TESTING/LIN/dkyt01.f b/TESTING/LIN/dkyt01.f new file mode 100644 index 000000000..aa7dcd019 --- /dev/null +++ b/TESTING/LIN/dkyt01.f @@ -0,0 +1,220 @@ +*> \brief \b DKYT01 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DKYT01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, +* RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), +* $ RWORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DKYT01 reconstructs a skew-symmetric indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix and EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> skew-symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The original skew-symmetric matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is DOUBLE PRECISION array, dimension (LDAFAC,N) +*> The factored form of the matrix A. AFAC contains the block +*> diagonal matrix D and the multipliers used to obtain the +*> factor L or U from the block L*D*L' or U*D*U' factorization +*> as computed by SKYTRF. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from SKYTRF. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is DOUBLE PRECISION +*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) +*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DKYT01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, + $ RWORK, RESID ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), + $ RWORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + DOUBLE PRECISION ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANKY + EXTERNAL LSAME, DLAMCH, DLANKY +* .. +* .. External Subroutines .. + EXTERNAL DLASET, DLAVKY +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* Determine EPS and the norm of A. +* + EPS = DLAMCH( 'Epsilon' ) + ANORM = DLANKY( '1', UPLO, N, A, LDA, RWORK ) +* +* Initialize C to the identity matrix. +* + CALL DLASET( 'Full', N, N, ZERO, ONE, C, LDC ) +* +* Call DLAVKY to form the product D * U' (or D * L' ). +* + CALL DLAVKY( UPLO, 'Transpose', 'Non-unit', N, N, AFAC, LDAFAC, + $ IPIV, C, LDC, INFO ) +* +* Call DLAVKY again to multiply by U (or L ). +* + CALL DLAVKY( UPLO, 'No transpose', 'Unit', N, N, AFAC, LDAFAC, + $ IPIV, C, LDC, INFO ) +* +* Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF +* +* Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = DLANKY( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS + END IF +* + RETURN +* +* End of DKYT01 +* + END diff --git a/TESTING/LIN/dlarhs.f b/TESTING/LIN/dlarhs.f index 48a1d54a6..5e7322232 100644 --- a/TESTING/LIN/dlarhs.f +++ b/TESTING/LIN/dlarhs.f @@ -47,6 +47,7 @@ *> xPP: Symmetric positive definite packed *> xPB: Symmetric positive definite banded *> xSY: Symmetric indefinite, 2-D storage +*> xKY: Skew-symmetric indefinite, 2-D storage *> xSP: Symmetric indefinite packed *> xSB: Symmetric indefinite banded *> xTR: Triangular @@ -252,6 +253,7 @@ SUBROUTINE DLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, GEN = LSAME( PATH( 2: 2 ), 'G' ) QRS = LSAME( PATH( 2: 2 ), 'Q' ) .OR. LSAME( PATH( 3: 3 ), 'Q' ) SYM = LSAME( PATH( 2: 2 ), 'P' ) .OR. LSAME( PATH( 2: 2 ), 'S' ) + $ .OR. LSAME( PATH( 2: 2 ), 'K' ) TRI = LSAME( PATH( 2: 2 ), 'T' ) BAND = LSAME( PATH( 3: 3 ), 'B' ) IF( .NOT.LSAME( C1, 'Double precision' ) ) THEN @@ -324,6 +326,13 @@ SUBROUTINE DLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, * CALL DSYMM( 'Left', UPLO, N, NRHS, ONE, A, LDA, X, LDX, ZERO, $ B, LDB ) +* + ELSE IF( LSAMEN( 2, C2, 'KY' ) ) THEN +* +* Skew-symmetric matrix, 2-D storage +* + CALL DKYMM( 'Left', UPLO, N, NRHS, ONE, A, LDA, X, LDX, ZERO, + $ B, LDB ) * ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN * diff --git a/TESTING/LIN/dlatb4.f b/TESTING/LIN/dlatb4.f index f3bccd45b..edf20cb1a 100644 --- a/TESTING/LIN/dlatb4.f +++ b/TESTING/LIN/dlatb4.f @@ -488,6 +488,42 @@ SUBROUTINE DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, KU = KL * * Set the condition number and norm. +* + IF( IMAT.EQ.7 ) THEN + CNDNUM = BADC1 + ELSE IF( IMAT.EQ.8 ) THEN + CNDNUM = BADC2 + ELSE + CNDNUM = TWO + END IF +* + IF( IMAT.EQ.9 ) THEN + ANORM = SMALL + ELSE IF( IMAT.EQ.10 ) THEN + ANORM = LARGE + ELSE + ANORM = ONE + END IF +* + ELSE IF( LSAMEN( 2, C2, 'KY' ) ) THEN +* +* xKY: Set parameters to generate a +* skew-symmetric matrix. +* +* Set TYPE, the type of matrix to be generated. +* + TYPE = C2( 1: 1 ) +* +* Set the lower and upper bandwidths. +* + IF( IMAT.EQ.1 ) THEN + KL = 0 + ELSE + KL = MAX( N-1, 0 ) + END IF + KU = KL +* +* Set the condition number and norm. * IF( IMAT.EQ.7 ) THEN CNDNUM = BADC1 diff --git a/TESTING/LIN/dlavky.f b/TESTING/LIN/dlavky.f new file mode 100644 index 000000000..e6e9cbd1b --- /dev/null +++ b/TESTING/LIN/dlavky.f @@ -0,0 +1,467 @@ +*> \brief \b DLAVKY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DLAVKY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, +* LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, TRANS, UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAVKY performs one of the matrix-vector operations +*> x := A*x or x := A'*x, +*> where x is an N element vector and A is one of the factors +*> from the block U*D*U' or L*D*L' factorization computed by SKYTRF. +*> +*> If TRANS = 'N', multiplies by U or U * D (or L or L * D) +*> If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L') +*> If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L') +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the factor stored in A is upper or lower +*> triangular. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> Specifies the operation to be performed: +*> = 'N': x := A*x +*> = 'T': x := A'*x +*> = 'C': x := A'*x +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> Specifies whether or not the diagonal blocks are unit +*> matrices. If the diagonal blocks are assumed to be unit, +*> then A = U or A = L, otherwise A = U*D or A = L*D. +*> = 'U': Diagonal blocks are assumed to be unit matrices. +*> = 'N': Diagonal blocks are assumed to be non-unit matrices. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of vectors +*> x to be multiplied by A. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by SKYTRF. +*> Stored as a 2-D triangular matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, +*> as determined by SKYTRF. +*> +*> The elements of array IPIV are combined in pair, and the first +*> (if UPLO = 'U') or the second (if UPLO = 'L') element in +*> the pair always keeps the value 0. If N is odd, the first +*> (if UPLO = 'U') or the last (if UPLO = 'L') element of IPIV is +*> 0, which is the only element not in pair. So we only use the +*> first (if UPLO = 'L') or the second (if UPLO = 'U') element in +*> the pair to determine the interchanges. +*> +*> If IPIV(k) +*> = 0: there was no interchange. +*> > 0: rows and columns k-1 and IPIV(k) were interchanged, if +*> UPLO = 'U', and rows and columns k+1 and IPIV(k) were +*> interchanged, if UPLO = 'L'. +*> < 0: rows and columns k and k-1 were interchanged, +*> then rows and columns k-1 and -IPIV(k) were interchanged, if +*> UPLO = 'U', and rows and columns k and k+1 were interchanged, +*> then rows and columns k+1 and -IPIV(k) were interchanged, if +*> UPLO = 'L'. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, B contains NRHS vectors of length N. +*> On exit, B is overwritten with the product A * B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DLAVKY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, + $ LDB, INFO ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER DIAG, TRANS, UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOUNIT + INTEGER J, K, KP + DOUBLE PRECISION D11, D12, D21, D22, T1, T2 +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DGER, DSCAL, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( .NOT.LSAME( UPLO, 'U' ) .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( .NOT.LSAME( DIAG, 'U' ) .AND. .NOT.LSAME( DIAG, 'N' ) ) + $ THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAVKY ', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* + NOUNIT = LSAME( DIAG, 'N' ) +*------------------------------------------ +* +* Compute B := A * B (No transpose) +* +*------------------------------------------ + IF( LSAME( TRANS, 'N' ) ) THEN +* +* Compute B := U*B +* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Loop forward applying the transformations. +* + K = MOD(N, 2) + 1 + 10 CONTINUE + IF( K.GE.N ) + $ GO TO 30 +* +* 2 x 2 pivot block +* +* Multiply by the diagonal block if forming U * D. +* + IF( NOUNIT ) THEN + D11 = ZERO + D22 = ZERO + D12 = A( K, K+1 ) + D21 = -D12 + DO 20 J = 1, NRHS + T1 = B( K, J ) + T2 = B( K+1, J ) + B( K, J ) = D11*T1 + D12*T2 + B( K+1, J ) = D21*T1 + D22*T2 + 20 CONTINUE + END IF +* +* Multiply by P(K) * inv(U(K)) if K > 1. +* + IF( K.GT.1 ) THEN +* +* Apply the transformations. +* + CALL DGER( K-1, NRHS, ONE, A( 1, K ), 1, B( K, 1 ), + $ LDB, B( 1, 1 ), LDB ) + CALL DGER( K-1, NRHS, ONE, A( 1, K+1 ), 1, + $ B( K+1, 1 ), LDB, B( 1, 1 ), LDB ) +* +* Interchange if P(K) .ne. I. +* + KP = IPIV( K+1 ) + IF( KP.GT.0 ) THEN + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + ELSEIF( KP.LT.0 ) THEN + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( -KP, 1 ), LDB ) + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( K+1, 1 ), LDB ) + END IF + END IF + K = K + 2 + GO TO 10 + 30 CONTINUE +* +* Compute B := L*B +* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . +* + ELSE +* +* Loop backward applying the transformations to B. +* + K = N - MOD(N, 2) + 40 CONTINUE + IF( K.LE.1 ) + $ GO TO 60 +* +* Test the pivot index. A 2 x 2 pivot was used. +* +* 2 x 2 pivot block: +* +* Multiply by the diagonal block if forming L * D. +* + IF( NOUNIT ) THEN + D11 = ZERO + D22 = ZERO + D21 = A( K, K-1 ) + D12 = -D21 + DO 50 J = 1, NRHS + T1 = B( K-1, J ) + T2 = B( K, J ) + B( K-1, J ) = D11*T1 + D12*T2 + B( K, J ) = D21*T1 + D22*T2 + 50 CONTINUE + END IF +* +* Multiply by P(K) * inv(L(K)) if K < N. +* + IF( K.NE.N ) THEN +* +* Apply the transformation. +* + CALL DGER( N-K, NRHS, ONE, A( K+1, K ), 1, B( K, 1 ), + $ LDB, B( K+1, 1 ), LDB ) + CALL DGER( N-K, NRHS, ONE, A( K+1, K-1 ), 1, + $ B( K-1, 1 ), LDB, B( K+1, 1 ), LDB ) +* +* Interchange if a permutation was applied at the +* K-th step of the factorization. +* + KP = IPIV( K-1 ) + IF( KP.GT.0 ) THEN + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + ELSEIF( KP.LT.0 ) THEN + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( -KP, 1 ), LDB ) + CALL DSWAP( NRHS, B( K, 1 ), LDB, B( K-1, 1 ), LDB ) + END IF + END IF + K = K - 2 + GO TO 40 + 60 CONTINUE + END IF +*---------------------------------------- +* +* Compute B := A' * B (transpose) +* +*---------------------------------------- + ELSE +* +* Form B := U'*B +* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) +* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Loop backward applying the transformations. +* + K = N + 70 CONTINUE + IF( K.LE.1 ) + $ GO TO 90 +* +* 2 x 2 pivot block. +* + IF( K.GT.2 ) THEN +* +* Interchange if P(K) .ne. I. +* + KP = IPIV( K ) + IF( KP.GT.0 ) THEN + CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), + $ LDB ) + ELSEIF( KP.LT.0 ) THEN + CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( K, 1 ), + $ LDB ) + CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( -KP, 1 ), + $ LDB ) + ENDIF +* +* Apply the transformations +* + CALL DGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB, + $ A( 1, K ), 1, ONE, B( K, 1 ), LDB ) + CALL DGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB, + $ A( 1, K-1 ), 1, ONE, B( K-1, 1 ), LDB ) + END IF +* +* Multiply by the diagonal block if non-unit. +* + IF( NOUNIT ) THEN + D11 = ZERO + D22 = ZERO + D12 = A( K-1, K ) + D21 = -D12 + DO 80 J = 1, NRHS + T1 = B( K-1, J ) + T2 = B( K, J ) + B( K-1, J ) = D11*T1 + D12*T2 + B( K, J ) = D21*T1 + D22*T2 + 80 CONTINUE + END IF + K = K - 2 + GO TO 70 + 90 CONTINUE +* +* Form B := L'*B +* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) +* and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1) +* + ELSE +* +* Loop forward applying the L-transformations. +* + K = 1 + 100 CONTINUE + IF( K.GE.N ) + $ GO TO 120 +* +* 2 x 2 pivot block +* + IF( K.LT.N-1 ) THEN +* +* Interchange if P(K) .ne. I. +* + KP = IPIV( K ) + IF( KP.GT.0 ) THEN + CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), + $ LDB ) + ELSEIF( KP.LT.0 ) THEN + CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( K, 1 ), + $ LDB ) + CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( -KP, 1 ), + $ LDB ) + ENDIF +* +* Apply the transformation +* + CALL DGEMV( 'Transpose', N-K-1, NRHS, ONE, + $ B( K+2, 1 ), LDB, A( K+2, K+1 ), 1, ONE, + $ B( K+1, 1 ), LDB ) + CALL DGEMV( 'Transpose', N-K-1, NRHS, ONE, + $ B( K+2, 1 ), LDB, A( K+2, K ), 1, ONE, + $ B( K, 1 ), LDB ) + END IF +* +* Multiply by the diagonal block if non-unit. +* + IF( NOUNIT ) THEN + D11 = ZERO + D22 = ZERO + D21 = A( K+1, K ) + D12 = -D21 + DO 110 J = 1, NRHS + T1 = B( K, J ) + T2 = B( K+1, J ) + B( K, J ) = D11*T1 + D12*T2 + B( K+1, J ) = D21*T1 + D22*T2 + 110 CONTINUE + END IF + K = K + 2 + GO TO 100 + 120 CONTINUE + END IF +* + END IF + RETURN +* +* End of DLAVKY +* + END diff --git a/TESTING/LIN/dpot07.f b/TESTING/LIN/dpot07.f new file mode 100644 index 000000000..33b66fbd8 --- /dev/null +++ b/TESTING/LIN/dpot07.f @@ -0,0 +1,203 @@ +*> \brief \b DPOT07 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DPOT07( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, +* RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDB, LDX, N, NRHS +* DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), RWORK( * ), +* $ X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPOT07 computes the residual for the solution of a skew-symmetric system +*> of linear equations A*x = b: +*> +*> RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ), +*> +*> where EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> skew-symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of columns of B, the matrix of right hand sides. +*> NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The original skew-symmetric matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (LDX,NRHS) +*> The computed solution vectors for the system of linear +*> equations. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (LDB,NRHS) +*> On entry, the right hand side vectors for the system of +*> linear equations. +*> On exit, B is overwritten with the difference B - A*X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is DOUBLE PRECISION +*> The maximum over the number of right hand sides of +*> norm(B - A*X) / ( norm(A) * norm(X) * EPS ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DPOT07( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, + $ RESID ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDB, LDX, N, NRHS + DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), RWORK( * ), + $ X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER J + DOUBLE PRECISION ANORM, BNORM, EPS, XNORM +* .. +* .. External Functions .. + DOUBLE PRECISION DASUM, DLAMCH, DLANKY + EXTERNAL DASUM, DLAMCH, DLANKY +* .. +* .. External Subroutines .. + EXTERNAL DKYMM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0 or NRHS = 0. +* + IF( N.LE.0 .OR. NRHS.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* Exit with RESID = 1/EPS if ANORM = 0. +* + EPS = DLAMCH( 'Epsilon' ) + ANORM = DLANKY( '1', UPLO, N, A, LDA, RWORK ) + IF( ANORM.LE.ZERO ) THEN + RESID = ONE / EPS + RETURN + END IF +* +* Compute B - A*X +* + CALL DKYMM( 'Left', UPLO, N, NRHS, -ONE, A, LDA, X, LDX, ONE, B, + $ LDB ) +* +* Compute the maximum over the number of right hand sides of +* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) . +* + RESID = ZERO + DO 10 J = 1, NRHS + BNORM = DASUM( N, B( 1, J ), 1 ) + XNORM = DASUM( N, X( 1, J ), 1 ) + IF( XNORM.LE.ZERO ) THEN + RESID = ONE / EPS + ELSE + RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS ) + END IF + 10 CONTINUE +* + RETURN +* +* End of DPOT07 +* + END diff --git a/TESTING/LIN/dpot08.f b/TESTING/LIN/dpot08.f new file mode 100644 index 000000000..1bceb76c8 --- /dev/null +++ b/TESTING/LIN/dpot08.f @@ -0,0 +1,218 @@ +*> \brief \b DPOT08 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DPOT08( UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, +* RWORK, RCOND, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAINV, LDWORK, N +* DOUBLE PRECISION RCOND, RESID +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), AINV( LDAINV, * ), RWORK( * ), +* $ WORK( LDWORK, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DPOT08 computes the residual for a skew-symmetric matrix times its +*> inverse: +*> norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), +*> where EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> skew-symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The original skew-symmetric matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in,out] AINV +*> \verbatim +*> AINV is DOUBLE PRECISION array, dimension (LDAINV,N) +*> On entry, the inverse of the matrix A, stored as a skew-symmetric +*> matrix in the same format as A. +*> In this version, AINV is expanded into a full matrix and +*> multiplied by A, so the opposing triangle of AINV will be +*> changed; i.e., if the upper triangular part of AINV is +*> stored, the lower triangular part will be used as work space. +*> \endverbatim +*> +*> \param[in] LDAINV +*> \verbatim +*> LDAINV is INTEGER +*> The leading dimension of the array AINV. LDAINV >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LDWORK,N) +*> \endverbatim +*> +*> \param[in] LDWORK +*> \verbatim +*> LDWORK is INTEGER +*> The leading dimension of the array WORK. LDWORK >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is DOUBLE PRECISION +*> The reciprocal of the condition number of A, computed as +*> ( 1/norm(A) ) / norm(AINV). +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is DOUBLE PRECISION +*> norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DPOT08( UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, + $ RWORK, RCOND, RESID ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDAINV, LDWORK, N + DOUBLE PRECISION RCOND, RESID +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), AINV( LDAINV, * ), RWORK( * ), + $ WORK( LDWORK, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION AINVNM, ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE, DLANKY + EXTERNAL LSAME, DLAMCH, DLANGE, DLANKY +* .. +* .. External Subroutines .. + EXTERNAL DKYMM +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RCOND = ONE + RESID = ZERO + RETURN + END IF +* +* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. +* + EPS = DLAMCH( 'Epsilon' ) + ANORM = DLANKY( '1', UPLO, N, A, LDA, RWORK ) + AINVNM = DLANKY( '1', UPLO, N, AINV, LDAINV, RWORK ) + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCOND = ZERO + RESID = ONE / EPS + RETURN + END IF + RCOND = ( ONE / ANORM ) / AINVNM +* +* Expand AINV into a full matrix and call DKYMM to multiply +* AINV on the left by A. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, J - 1 + AINV( J, I ) = -AINV( I, J ) + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = J + 1, N + AINV( J, I ) = -AINV( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + CALL DKYMM( 'Left', UPLO, N, N, -ONE, A, LDA, AINV, LDAINV, ZERO, + $ WORK, LDWORK ) +* +* Add the identity matrix to WORK . +* + DO 50 I = 1, N + WORK( I, I ) = WORK( I, I ) + ONE + 50 CONTINUE +* +* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) +* + RESID = DLANGE( '1', N, N, WORK, LDWORK, RWORK ) +* + RESID = ( ( RESID*RCOND ) / EPS ) / DBLE( N ) +* + RETURN +* +* End of DPOT08 +* + END diff --git a/TESTING/LIN/schkaa.F b/TESTING/LIN/schkaa.F index 036b13924..30757f42b 100644 --- a/TESTING/LIN/schkaa.F +++ b/TESTING/LIN/schkaa.F @@ -50,6 +50,7 @@ *> SPB 8 List types on next line if 0 < NTYPES < 8 *> SPT 12 List types on next line if 0 < NTYPES < 12 *> SSY 10 List types on next line if 0 < NTYPES < 10 +*> SKY 10 List types on next line if 0 < NTYPES < 10 *> SSR 10 List types on next line if 0 < NTYPES < 10 *> SSK 10 List types on next line if 0 < NTYPES < 10 *> SSA 10 List types on next line if 0 < NTYPES < 10 @@ -169,7 +170,7 @@ PROGRAM SCHKAA $ SDRVGB, SDRVGE, SDRVGT, SDRVLS, SDRVPB, SDRVPO, $ SDRVPP, SDRVPT, SDRVSP, SDRVSY, SDRVSY_ROOK, $ SDRVSY_RK, SDRVSY_AA, ILAVER, SCHKLQTP, SCHKQRT, - $ SCHKQRTP, SCHKLQT, SCHKTSQR + $ SCHKQRTP, SCHKLQT, SCHKTSQR, SCHKKY * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -660,6 +661,32 @@ PROGRAM SCHKAA ELSE WRITE( NOUT, FMT = 9988 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'KY' ) ) THEN +* +* KY: skew-symmetric indefinite matrices, +* with Bunch-Kaufman diagonal pivoting algorithm +* + NTYPES = 10 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL SCHKKY( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), + $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL SDRVKY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, LDA, + $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ), + $ B( 1, 2 ), B( 1, 3 ), WORK, RWORK, IWORK, + $ NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * diff --git a/TESTING/LIN/schkky.f b/TESTING/LIN/schkky.f new file mode 100644 index 000000000..788ec71ca --- /dev/null +++ b/TESTING/LIN/schkky.f @@ -0,0 +1,627 @@ +*> \brief \b SCHKKY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SCHKKY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, +* XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* REAL A( * ), AFAC( * ), AINV( * ), B( * ), +* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SCHKKY tests SKYTRF, -TRI2, -TRS, -TRS2. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NNB) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is REAL +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is REAL array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is REAL array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is REAL array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX)) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup single_lin +* +* ===================================================================== + SUBROUTINE SCHKKY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, + $ XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NNB, NNS, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + REAL A( * ), AFAC( * ), AINV( * ), B( * ), + $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER ( ZERO = 0.0E+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 10 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 9 ) +* .. +* .. Local Scalars .. + LOGICAL TRFCON, ZEROT, LSAME + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE, + $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT + REAL ANORM, CNDNUM, RCOND, RCONDC +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, SERRSY, SGET04, SLACPY, + $ SLARHS, SLATB4, SLATMS, SPOT08, SPOT07, + $ SKYT01, SKYTRF, + $ SKYTRI2, SKYTRS, SKYTRS2, LSAME, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Single precision' + PATH( 2: 3 ) = 'KY' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL SERRKY( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 2 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT, except IMAT.EQ.1 +* + DO 170 IMAT = 2, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 + IF (MOD(N,2).NE.0) + $ ZEROT = .FALSE. +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with SLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, + $ CNDNUM, DIST ) +* +* Generate a matrix with SLATMS. +* + SRNAMT = 'SLATMS' + CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from SLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 160 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* +* Do for each value of NB in NBVAL +* + DO 150 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'SKYTRF' + CALL SKYTRF( UPLO, N, AFAC, LDA, IWORK, AINV, LWORK, + $ INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF (MOD(N,2).NE.0 .AND. LSAME( UPLO, 'U' )) THEN + K = 1 + ELSEIF (MOD(N,2).NE.0 .AND. LSAME( UPLO, 'L' )) THEN + K = N + ELSEIF( K.GT.0 ) THEN + 100 CONTINUE + IF(LSAME( UPLO, 'U' )) THEN + IF(MOD(N-K+1,2).NE.0 .AND. IWORK(K).LT.0) THEN + K = -IWORK( K ) + GO TO 100 + ELSEIF(MOD(N-K+1,2).EQ.0 .AND. IWORK(K+1).GT.0) + $ THEN + K = IWORK( K+1 ) + GO TO 100 + ELSEIF(MOD(N-K+1,2).EQ.0 .AND. IWORK(K+1).EQ.0) + $ THEN + K = K+1 + END IF + ELSE IF(LSAME( UPLO, 'L' )) THEN + IF(MOD(K,2).NE.0 .AND. IWORK(K).LT.0) THEN + K = -IWORK( K ) + GO TO 100 + ELSEIF(MOD(K,2).EQ.0 .AND. IWORK(K-1).GT.0) THEN + K = IWORK( K-1 ) + GO TO 100 + ELSEIF(MOD(K,2).EQ.0 .AND. IWORK(K-1).EQ.0) THEN + K = K-1 + END IF + END IF + END IF +* +* Check error code from SKYTRF and handle error. +* + IF( INFO.NE.K ) + $ CALL ALAERH( PATH, 'SKYTRF', INFO, K, UPLO, N, N, + $ -1, -1, NB, IMAT, NFAIL, NERRS, NOUT ) +* +* Set the condition estimate flag if the INFO is not 0. +* + IF( INFO.NE.0 ) THEN + TRFCON = .TRUE. + ELSE + TRFCON = .FALSE. + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL SKYT01( UPLO, N, A, LDA, AFAC, LDA, IWORK, AINV, + $ LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +*+ TEST 2 +* Form the inverse and compute the residual, +* if the factorization was competed without INFO > 0 +* (i.e. there is no zero rows and columns). +* + IF( .NOT.TRFCON ) THEN + CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + SRNAMT = 'SKYTRI2' + LWORK = (N+NB+1)*(NB+3) + CALL SKYTRI2( UPLO, N, AINV, LDA, IWORK, WORK, + $ LWORK, INFO ) +* +* Check error code from SKYTRI2 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'SKYTRI2', INFO, -1, UPLO, N, + $ N, -1, -1, -1, IMAT, NFAIL, NERRS, + $ NOUT ) +* +* Compute the residual for a skew-symmetric matrix times +* its inverse. +* + CALL SPOT08( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, + $ RWORK, RCONDC, RESULT( 2 ) ) + NT = 2 + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +* Skip the other tests if this is not the first block +* size. +* + IF( INB.GT.1 .OR. TRFCON ) + $ GO TO 150 +* +* Do for each value of NRHS in NSVAL. +* + DO 130 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 3 (Using DSYTRS) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'SLARHS' + CALL SLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, + $ ISEED, INFO ) + CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'SKYTRS' + CALL SKYTRS( UPLO, N, NRHS, AFAC, LDA, IWORK, X, + $ LDA, INFO ) +* +* Check error code from SKYTRS and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'SKYTRS', INFO, 0, UPLO, N, + $ N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) +* + CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL SPOT07( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 3 ) ) +* +*+ TEST 4 (Using DSYTRS2) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'SLARHS' + CALL SLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, + $ ISEED, INFO ) + CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'DSYTRS2' + CALL SKYTRS2( UPLO, N, NRHS, AFAC, LDA, IWORK, X, + $ LDA, WORK, INFO ) +* +* Check error code from SKYTRS2 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'SKYTRS2', INFO, 0, UPLO, N, + $ N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) +* + CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL SPOT07( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 4 ) ) +* +*+ TEST 5 +* Check solution from generated exact solution. +* + CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 5 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 120 K = 3, 5 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 120 CONTINUE + NRUN = NRUN + 3 +* +* End do for each value of NRHS in NSVAL. +* + 130 CONTINUE +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test(', I2, ') =', G12.5 ) + 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, + $ ', test(', I2, ') =', G12.5 ) + RETURN +* +* End of SCHKKY +* + END diff --git a/TESTING/LIN/sdrvky.f b/TESTING/LIN/sdrvky.f new file mode 100644 index 000000000..f8f8727b2 --- /dev/null +++ b/TESTING/LIN/sdrvky.f @@ -0,0 +1,528 @@ +*> \brief \b SDRVKY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SDRVKY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, +* A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, +* NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* REAL A( * ), AFAC( * ), AINV( * ), B( * ), +* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SDRVKY tests the driver routines SKYSV. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is REAL +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is REAL array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is REAL array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is REAL array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (NMAX*max(2,NRHS)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup single_lin +* +* ===================================================================== + SUBROUTINE SDRVKY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, + $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, + $ NOUT ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + LOGICAL TSTERR, LSAME + INTEGER NMAX, NN, NOUT, NRHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + REAL A( * ), AFAC( * ), AINV( * ), B( * ), + $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 6 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 PATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, K1, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + REAL AINVNM, ANORM, CNDNUM, RCOND, RCONDC +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) +* .. +* .. External Functions .. + REAL SGET06, SLANKY + EXTERNAL SGET06, SLANKY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, SERRVX, SGET04, SLACPY, + $ SLARHS, SLASET, SLATB4, SLATMS, SPOT07, + $ SKYSV, SKYT01, SKYTRF, SKYTRI2, LSAME, XLAENV +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Single precision' + PATH( 2: 3 ) = 'KY' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL SERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for testing. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 2 +* +* Do for each value of matrix type IMAT, except IMAT.EQ.1 +* + DO 170 IMAT = 2, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 + IF (MOD(N,2).NE.0) + $ ZEROT = .FALSE. +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Set up parameters with SLATB4 and generate a test matrix +* with SLATMS. +* + CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, + $ CNDNUM, DIST ) +* + SRNAMT = 'SLATMS' + CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from SLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of the +* matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IOFF = 0 + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Compute the condition number. +* + IF( ZEROT ) THEN + IF( IFACT.EQ.1 ) + $ GO TO 150 + RCONDC = ZERO +* + ELSE IF( IFACT.EQ.1 ) THEN +* +* Compute the 1-norm of A. +* + ANORM = SLANKY( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* + CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL SKYTRF( UPLO, N, AFAC, LDA, IWORK, WORK, + $ LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* + CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + LWORK = (N+NB+1)*(NB+3) + CALL SKYTRI2( UPLO, N, AINV, LDA, IWORK, WORK, + $ LWORK, INFO ) + AINVNM = SLANKY( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'SLARHS' + CALL SLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test SKYSV --- +* + IF( IFACT.EQ.2 ) THEN + CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using SKYSV. +* + SRNAMT = 'SKYSV ' + CALL SKYSV( UPLO, N, NRHS, AFAC, LDA, IWORK, X, + $ LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF (MOD(N,2).NE.0 .AND. LSAME( UPLO, 'U' )) THEN + K = 1 + ELSEIF (MOD(N,2).NE.0 .AND. LSAME( UPLO, 'L' )) + $ THEN + K = N + ELSEIF( K.GT.0 ) THEN + 100 CONTINUE + IF(LSAME( UPLO, 'U' )) THEN + IF(MOD(N-K+1,2).NE.0 .AND. IWORK(K).LT.0) + $ THEN + K = -IWORK( K ) + GO TO 100 + ELSEIF(MOD(N-K+1,2).EQ.0 .AND. + $ IWORK(K+1).GT.0) THEN + K = IWORK( K+1 ) + GO TO 100 + ELSEIF(MOD(N-K+1,2).EQ.0 .AND. + $ IWORK(K+1).EQ.0) THEN + K = K+1 + END IF + ELSE IF(LSAME( UPLO, 'L' )) THEN + IF(MOD(K,2).NE.0 .AND. IWORK(K).LT.0) + $ THEN + K = -IWORK( K ) + GO TO 100 + ELSEIF(MOD(K,2).EQ.0 .AND. IWORK(K-1).GT.0) + $ THEN + K = IWORK( K-1 ) + GO TO 100 + ELSEIF(MOD(K,2).EQ.0 .AND. IWORK(K-1).EQ.0) + $ THEN + K = K-1 + END IF + END IF + END IF +* +* Check error code from SKYSV . +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'SKYSV ', INFO, K, UPLO, N, + $ N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL SKYT01( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) +* +* Compute residual of the computed solution. +* + CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL SPOT07( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 3 ) ) + NT = 3 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'SKYSV ', UPLO, N, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N =', I5, + $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of SDRVKY +* + END diff --git a/TESTING/LIN/serrky.f b/TESTING/LIN/serrky.f new file mode 100644 index 000000000..eeca1b370 --- /dev/null +++ b/TESTING/LIN/serrky.f @@ -0,0 +1,234 @@ +*> \brief \b SERRKY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SERRKY( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SERRKY tests the error exits for the REAL routines +*> for skew-symmetric indefinite matrices. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup single_lin +* +* ===================================================================== + SUBROUTINE SERRKY( PATH, NUNIT ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 4 ) +* .. +* .. Local Scalars .. + CHARACTER*2 C2 + INTEGER I, INFO, J + REAL ANRM, RCOND +* .. +* .. Local Arrays .. + INTEGER IP( NMAX ), IW( NMAX ) + REAL A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), + $ E( NMAX ), R1( NMAX ), R2( NMAX ), W( 3*NMAX ), + $ X( NMAX ) +* .. +* .. External Functions .. + LOGICAL LSAMEN + EXTERNAL LSAMEN +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, SKYTRI2X, SKYTF2, + $ SKYTRF, SKYTRI, SKYTRS, SKYTRI2 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) + C2 = PATH( 2: 3 ) +* +* Set the variables to innocuous values. +* + DO 20 J = 1, NMAX + DO 10 I = 1, NMAX + A( I, J ) = 1. / REAL( I+J ) + AF( I, J ) = 1. / REAL( I+J ) + 10 CONTINUE + B( J ) = 0.E+0 + E( J ) = 0.E+0 + R1( J ) = 0.E+0 + R2( J ) = 0.E+0 + W( J ) = 0.E+0 + X( J ) = 0.E+0 + IP( J ) = J + IW( J ) = J + 20 CONTINUE + ANRM = 1.0 + RCOND = 1.0 + OK = .TRUE. +* + IF( LSAMEN( 2, C2, 'KY' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a skew-symmetric indefinite matrix with patrial +* (Bunch-Kaufman) pivoting. +* +* SKYTRF +* + SRNAMT = 'SKYTRF' + INFOT = 1 + CALL SKYTRF( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SKYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SKYTRF( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SKYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SKYTRF( 'U', 2, A, 1, IP, W, 4, INFO ) + CALL CHKXER( 'SKYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SKYTRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'SKYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SKYTRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'SKYTRF', INFOT, NOUT, LERR, OK ) +* +* SKYTF2 +* + SRNAMT = 'SKYTF2' + INFOT = 1 + CALL SKYTF2( '/', 0, A, 1, IP, INFO ) + CALL CHKXER( 'SKYTF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SKYTF2( 'U', -1, A, 1, IP, INFO ) + CALL CHKXER( 'SKYTF2', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SKYTF2( 'U', 2, A, 1, IP, INFO ) + CALL CHKXER( 'SKYTF2', INFOT, NOUT, LERR, OK ) +* +* SKYTRI +* + SRNAMT = 'SKYTRI' + INFOT = 1 + CALL SKYTRI( '/', 0, A, 1, IP, W, INFO ) + CALL CHKXER( 'SKYTRI', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SKYTRI( 'U', -1, A, 1, IP, W, INFO ) + CALL CHKXER( 'SKYTRI', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SKYTRI( 'U', 2, A, 1, IP, W, INFO ) + CALL CHKXER( 'SKYTRI', INFOT, NOUT, LERR, OK ) +* +* SKYTRI2 +* + SRNAMT = 'SKYTRI2' + INFOT = 1 + CALL SKYTRI2( '/', 0, A, 1, IP, W, IW(1), INFO ) + CALL CHKXER( 'SKYTRI2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SKYTRI2( 'U', -1, A, 1, IP, W, IW(1), INFO ) + CALL CHKXER( 'SKYTRI2', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SKYTRI2( 'U', 2, A, 1, IP, W, IW(1), INFO ) + CALL CHKXER( 'SKYTRI2', INFOT, NOUT, LERR, OK ) +* +* SKYTRI2X +* + SRNAMT = 'SKYTRI2X' + INFOT = 1 + CALL SKYTRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SKYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SKYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SKYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SKYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SKYTRI2X', INFOT, NOUT, LERR, OK ) +* +* SKYTRS +* + SRNAMT = 'SKYTRS' + INFOT = 1 + CALL SKYTRS( '/', 0, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'SKYTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SKYTRS( 'U', -1, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'SKYTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SKYTRS( 'U', 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'SKYTRS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SKYTRS( 'U', 2, 1, A, 1, IP, B, 2, INFO ) + CALL CHKXER( 'SKYTRS', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SKYTRS( 'U', 2, 1, A, 2, IP, B, 1, INFO ) + CALL CHKXER( 'SKYTRS', INFOT, NOUT, LERR, OK ) +* + END IF +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of SERRKY +* + END diff --git a/TESTING/LIN/serrkyx.f b/TESTING/LIN/serrkyx.f new file mode 100644 index 000000000..e6645983e --- /dev/null +++ b/TESTING/LIN/serrkyx.f @@ -0,0 +1,238 @@ +*> \brief \b SERRKYX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SERRKY( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SERRKY tests the error exits for the REAL routines +*> for symmetric indefinite matrices. +*> +*> Note that this file is used only when the XBLAS are available, +*> otherwise serrsy.f defines this subroutine. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup single_lin +* +* ===================================================================== + SUBROUTINE SERRKY( PATH, NUNIT ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 4 ) +* .. +* .. Local Scalars .. + CHARACTER EQ + CHARACTER*2 C2 + INTEGER I, INFO, J, N_ERR_BNDS, NPARAMS + REAL ANRM, RCOND, BERR +* .. +* .. Local Arrays .. + INTEGER IP( NMAX ), IW( NMAX ) + REAL A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), + $ E( NMAX ), R1( NMAX ), R2( NMAX ), W( 3*NMAX ), + $ X( NMAX ), S( NMAX ), ERR_BNDS_N( NMAX, 3 ), + $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) +* .. +* .. External Functions .. + LOGICAL LSAMEN + EXTERNAL LSAMEN +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, SKYTF2, SKYTRF, + $ SKYTRI, SKYTRI2, SKYTRI2X, SKYTRS +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) + C2 = PATH( 2: 3 ) +* +* Set the variables to innocuous values. +* + DO 20 J = 1, NMAX + DO 10 I = 1, NMAX + A( I, J ) = 1. / REAL( I+J ) + AF( I, J ) = 1. / REAL( I+J ) + 10 CONTINUE + B( J ) = 0.E+0 + E( J ) = 0.E+0 + R1( J ) = 0.E+0 + R2( J ) = 0.E+0 + W( J ) = 0.E+0 + X( J ) = 0.E+0 + IP( J ) = J + IW( J ) = J + 20 CONTINUE + ANRM = 1.0 + RCOND = 1.0 + OK = .TRUE. +* + IF( LSAMEN( 2, C2, 'KY' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with patrial +* (Bunch-Kaufman) pivoting. +* +* SKYTRF +* + SRNAMT = 'SKYTRF' + INFOT = 1 + CALL SKYTRF( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SKYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SKYTRF( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SKYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SKYTRF( 'U', 2, A, 1, IP, W, 4, INFO ) + CALL CHKXER( 'SKYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SKYTRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'SKYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SKYTRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'SKYTRF', INFOT, NOUT, LERR, OK ) +* +* SKYTF2 +* + SRNAMT = 'SKYTF2' + INFOT = 1 + CALL SKYTF2( '/', 0, A, 1, IP, INFO ) + CALL CHKXER( 'SKYTF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SKYTF2( 'U', -1, A, 1, IP, INFO ) + CALL CHKXER( 'SKYTF2', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SKYTF2( 'U', 2, A, 1, IP, INFO ) + CALL CHKXER( 'SKYTF2', INFOT, NOUT, LERR, OK ) +* +* SKYTRI +* + SRNAMT = 'SKYTRI' + INFOT = 1 + CALL SKYTRI( '/', 0, A, 1, IP, W, INFO ) + CALL CHKXER( 'SKYTRI', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SKYTRI( 'U', -1, A, 1, IP, W, INFO ) + CALL CHKXER( 'SKYTRI', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SKYTRI( 'U', 2, A, 1, IP, W, INFO ) + CALL CHKXER( 'SKYTRI', INFOT, NOUT, LERR, OK ) +* +* SKYTRI2 +* + SRNAMT = 'SKYTRI2' + INFOT = 1 + CALL SKYTRI2( '/', 0, A, 1, IP, W, IW, INFO ) + CALL CHKXER( 'SKYTRI', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SKYTRI2( 'U', -1, A, 1, IP, W, IW, INFO ) + CALL CHKXER( 'SKYTRI', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SKYTRI2( 'U', 2, A, 1, IP, W, IW, INFO ) + CALL CHKXER( 'SKYTRI', INFOT, NOUT, LERR, OK ) +* +* SKYTRI2X +* + SRNAMT = 'SKYTRI2X' + INFOT = 1 + CALL SKYTRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SKYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SKYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SKYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SKYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SKYTRI2X', INFOT, NOUT, LERR, OK ) +* +* SKYTRS +* + SRNAMT = 'SKYTRS' + INFOT = 1 + CALL SKYTRS( '/', 0, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'SKYTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SKYTRS( 'U', -1, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'SKYTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SKYTRS( 'U', 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'SKYTRS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SKYTRS( 'U', 2, 1, A, 1, IP, B, 2, INFO ) + CALL CHKXER( 'SKYTRS', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SKYTRS( 'U', 2, 1, A, 2, IP, B, 1, INFO ) + CALL CHKXER( 'SKYTRS', INFOT, NOUT, LERR, OK ) + END IF +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of SERRKYX +* + END diff --git a/TESTING/LIN/serrvx.f b/TESTING/LIN/serrvx.f index 440f9113e..b6dced91d 100644 --- a/TESTING/LIN/serrvx.f +++ b/TESTING/LIN/serrvx.f @@ -89,7 +89,7 @@ SUBROUTINE SERRVX( PATH, NUNIT ) $ SGTSVX, SPBSV, SPBSVX, SPOSV, SPOSVX, SPPSV, $ SPPSVX, SPTSV, SPTSVX, SSPSV, SSPSVX, SSYSV, $ SSYSV_AA, SSYSV_RK, SSYSV_ROOK, SSYSVX, - $ SSYSV_AA_2STAGE + $ SSYSV_AA_2STAGE, SKYSV * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -635,6 +635,32 @@ SUBROUTINE SERRVX( PATH, NUNIT ) $ RCOND, R1, R2, W, 3, IW, INFO ) CALL CHKXER( 'SSYSVX', INFOT, NOUT, LERR, OK ) * + ELSE IF( LSAMEN( 2, C2, 'KY' ) ) THEN +* +* SKYSV +* + SRNAMT = 'SKYSV ' + INFOT = 1 + CALL SKYSV( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SKYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SKYSV( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SKYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SKYSV( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SKYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SKYSV( 'U', 2, 0, A, 1, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'SKYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SKYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SKYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SKYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'SKYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SKYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'SKYSV ', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * diff --git a/TESTING/LIN/skyt01.f b/TESTING/LIN/skyt01.f new file mode 100644 index 000000000..63387d68f --- /dev/null +++ b/TESTING/LIN/skyt01.f @@ -0,0 +1,220 @@ +*> \brief \b SKYT01 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SKYT01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, +* RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* REAL RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), +* $ RWORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SKYT01 reconstructs a skew-symmetric indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix and EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> skew-symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> The original skew-symmetric matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is REAL array, dimension (LDAFAC,N) +*> The factored form of the matrix A. AFAC contains the block +*> diagonal matrix D and the multipliers used to obtain the +*> factor L or U from the block L*D*L' or U*D*U' factorization +*> as computed by SKYTRF. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from SKYTRF. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is REAL array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is REAL +*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) +*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup single_lin +* +* ===================================================================== + SUBROUTINE SKYT01( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, + $ RWORK, RESID ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + REAL RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), + $ RWORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + REAL ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SLAMCH, SLANKY + EXTERNAL LSAME, SLAMCH, SLANKY +* .. +* .. External Subroutines .. + EXTERNAL SLASET, SLAVKY +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* Determine EPS and the norm of A. +* + EPS = SLAMCH( 'Epsilon' ) + ANORM = SLANKY( '1', UPLO, N, A, LDA, RWORK ) +* +* Initialize C to the identity matrix. +* + CALL SLASET( 'Full', N, N, ZERO, ONE, C, LDC ) +* +* Call SLAVKY to form the product D * U' (or D * L' ). +* + CALL SLAVKY( UPLO, 'Transpose', 'Non-unit', N, N, AFAC, LDAFAC, + $ IPIV, C, LDC, INFO ) +* +* Call SLAVKY again to multiply by U (or L ). +* + CALL SLAVKY( UPLO, 'No transpose', 'Unit', N, N, AFAC, LDAFAC, + $ IPIV, C, LDC, INFO ) +* +* Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF +* +* Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = SLANKY( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID / REAL( N ) ) / ANORM ) / EPS + END IF +* + RETURN +* +* End of SKYT01 +* + END diff --git a/TESTING/LIN/slarhs.f b/TESTING/LIN/slarhs.f index 6a8a592c8..b075b9735 100644 --- a/TESTING/LIN/slarhs.f +++ b/TESTING/LIN/slarhs.f @@ -47,6 +47,7 @@ *> xPP: Symmetric positive definite packed *> xPB: Symmetric positive definite banded *> xSY: Symmetric indefinite, 2-D storage +*> xKY: Skew-symmetric indefinite, 2-D storage *> xSP: Symmetric indefinite packed *> xSB: Symmetric indefinite banded *> xTR: Triangular @@ -252,6 +253,7 @@ SUBROUTINE SLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, GEN = LSAME( PATH( 2: 2 ), 'G' ) QRS = LSAME( PATH( 2: 2 ), 'Q' ) .OR. LSAME( PATH( 3: 3 ), 'Q' ) SYM = LSAME( PATH( 2: 2 ), 'P' ) .OR. LSAME( PATH( 2: 2 ), 'S' ) + $ .OR. LSAME( PATH( 2: 2 ), 'K' ) TRI = LSAME( PATH( 2: 2 ), 'T' ) BAND = LSAME( PATH( 3: 3 ), 'B' ) IF( .NOT.LSAME( C1, 'Single precision' ) ) THEN @@ -324,6 +326,13 @@ SUBROUTINE SLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, * CALL SSYMM( 'Left', UPLO, N, NRHS, ONE, A, LDA, X, LDX, ZERO, $ B, LDB ) +* + ELSE IF( LSAMEN( 2, C2, 'KY' ) ) THEN +* +* Skew-symmetric matrix, 2-D storage +* + CALL SKYMM( 'Left', UPLO, N, NRHS, ONE, A, LDA, X, LDX, ZERO, + $ B, LDB ) * ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN * diff --git a/TESTING/LIN/slatb4.f b/TESTING/LIN/slatb4.f index 72a310727..d354b5dea 100644 --- a/TESTING/LIN/slatb4.f +++ b/TESTING/LIN/slatb4.f @@ -488,6 +488,42 @@ SUBROUTINE SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, KU = KL * * Set the condition number and norm. +* + IF( IMAT.EQ.7 ) THEN + CNDNUM = BADC1 + ELSE IF( IMAT.EQ.8 ) THEN + CNDNUM = BADC2 + ELSE + CNDNUM = TWO + END IF +* + IF( IMAT.EQ.9 ) THEN + ANORM = SMALL + ELSE IF( IMAT.EQ.10 ) THEN + ANORM = LARGE + ELSE + ANORM = ONE + END IF +* + ELSE IF( LSAMEN( 2, C2, 'KY' ) ) THEN +* +* xKY: Set parameters to generate a +* skew-symmetric matrix. +* +* Set TYPE, the type of matrix to be generated. +* + TYPE = C2( 1: 1 ) +* +* Set the lower and upper bandwidths. +* + IF( IMAT.EQ.1 ) THEN + KL = 0 + ELSE + KL = MAX( N-1, 0 ) + END IF + KU = KL +* +* Set the condition number and norm. * IF( IMAT.EQ.7 ) THEN CNDNUM = BADC1 diff --git a/TESTING/LIN/slavky.f b/TESTING/LIN/slavky.f new file mode 100644 index 000000000..91d3557be --- /dev/null +++ b/TESTING/LIN/slavky.f @@ -0,0 +1,467 @@ +*> \brief \b SLAVKY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SLAVKY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, +* LDB, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER DIAG, TRANS, UPLO +* INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), B( LDB, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLAVKY performs one of the matrix-vector operations +*> x := A*x or x := A'*x, +*> where x is an N element vector and A is one of the factors +*> from the block U*D*U' or L*D*L' factorization computed by SKYTRF. +*> +*> If TRANS = 'N', multiplies by U or U * D (or L or L * D) +*> If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L') +*> If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L') +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the factor stored in A is upper or lower +*> triangular. +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> Specifies the operation to be performed: +*> = 'N': x := A*x +*> = 'T': x := A'*x +*> = 'C': x := A'*x +*> \endverbatim +*> +*> \param[in] DIAG +*> \verbatim +*> DIAG is CHARACTER*1 +*> Specifies whether or not the diagonal blocks are unit +*> matrices. If the diagonal blocks are assumed to be unit, +*> then A = U or A = L, otherwise A = U*D or A = L*D. +*> = 'U': Diagonal blocks are assumed to be unit matrices. +*> = 'N': Diagonal blocks are assumed to be non-unit matrices. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of vectors +*> x to be multiplied by A. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> The block diagonal matrix D and the multipliers used to +*> obtain the factor U or L as computed by SKYTRF. +*> Stored as a 2-D triangular matrix. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> Details of the interchanges and the block structure of D, +*> as determined by SKYTRF. +*> +*> The elements of array IPIV are combined in pair, and the first +*> (if UPLO = 'U') or the second (if UPLO = 'L') element in +*> the pair always keeps the value 0. If N is odd, the first +*> (if UPLO = 'U') or the last (if UPLO = 'L') element of IPIV is +*> 0, which is the only element not in pair. So we only use the +*> first (if UPLO = 'L') or the second (if UPLO = 'U') element in +*> the pair to determine the interchanges. +*> +*> If IPIV(k) +*> = 0: there was no interchange. +*> > 0: rows and columns k-1 and IPIV(k) were interchanged, if +*> UPLO = 'U', and rows and columns k+1 and IPIV(k) were +*> interchanged, if UPLO = 'L'. +*> < 0: rows and columns k and k-1 were interchanged, +*> then rows and columns k-1 and -IPIV(k) were interchanged, if +*> UPLO = 'U', and rows and columns k and k+1 were interchanged, +*> then rows and columns k+1 and -IPIV(k) were interchanged, if +*> UPLO = 'L'. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB,NRHS) +*> On entry, B contains NRHS vectors of length N. +*> On exit, B is overwritten with the product A * B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -k, the k-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup single_lin +* +* ===================================================================== + SUBROUTINE SLAVKY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, + $ LDB, INFO ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER DIAG, TRANS, UPLO + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOUNIT + INTEGER J, K, KP + REAL D11, D12, D21, D22, T1, T2 +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SGEMV, SGER, SSCAL, SSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( .NOT.LSAME( UPLO, 'U' ) .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( .NOT.LSAME( DIAG, 'U' ) .AND. .NOT.LSAME( DIAG, 'N' ) ) + $ THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SLAVKY ', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* + NOUNIT = LSAME( DIAG, 'N' ) +*------------------------------------------ +* +* Compute B := A * B (No transpose) +* +*------------------------------------------ + IF( LSAME( TRANS, 'N' ) ) THEN +* +* Compute B := U*B +* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Loop forward applying the transformations. +* + K = MOD(N, 2) + 1 + 10 CONTINUE + IF( K.GE.N ) + $ GO TO 30 +* +* 2 x 2 pivot block +* +* Multiply by the diagonal block if forming U * D. +* + IF( NOUNIT ) THEN + D11 = ZERO + D22 = ZERO + D12 = A( K, K+1 ) + D21 = -D12 + DO 20 J = 1, NRHS + T1 = B( K, J ) + T2 = B( K+1, J ) + B( K, J ) = D11*T1 + D12*T2 + B( K+1, J ) = D21*T1 + D22*T2 + 20 CONTINUE + END IF +* +* Multiply by P(K) * inv(U(K)) if K > 1. +* + IF( K.GT.1 ) THEN +* +* Apply the transformations. +* + CALL SGER( K-1, NRHS, ONE, A( 1, K ), 1, B( K, 1 ), + $ LDB, B( 1, 1 ), LDB ) + CALL SGER( K-1, NRHS, ONE, A( 1, K+1 ), 1, + $ B( K+1, 1 ), LDB, B( 1, 1 ), LDB ) +* +* Interchange if P(K) .ne. I. +* + KP = IPIV( K+1 ) + IF( KP.GT.0 ) THEN + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + ELSEIF( KP.LT.0 ) THEN + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( -KP, 1 ), LDB ) + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( K+1, 1 ), LDB ) + END IF + END IF + K = K + 2 + GO TO 10 + 30 CONTINUE +* +* Compute B := L*B +* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . +* + ELSE +* +* Loop backward applying the transformations to B. +* + K = N - MOD(N, 2) + 40 CONTINUE + IF( K.LE.1 ) + $ GO TO 60 +* +* Test the pivot index. A 2 x 2 pivot was used. +* +* 2 x 2 pivot block: +* +* Multiply by the diagonal block if forming L * D. +* + IF( NOUNIT ) THEN + D11 = ZERO + D22 = ZERO + D21 = A( K, K-1 ) + D12 = -D21 + DO 50 J = 1, NRHS + T1 = B( K-1, J ) + T2 = B( K, J ) + B( K-1, J ) = D11*T1 + D12*T2 + B( K, J ) = D21*T1 + D22*T2 + 50 CONTINUE + END IF +* +* Multiply by P(K) * inv(L(K)) if K < N. +* + IF( K.NE.N ) THEN +* +* Apply the transformation. +* + CALL SGER( N-K, NRHS, ONE, A( K+1, K ), 1, B( K, 1 ), + $ LDB, B( K+1, 1 ), LDB ) + CALL SGER( N-K, NRHS, ONE, A( K+1, K-1 ), 1, + $ B( K-1, 1 ), LDB, B( K+1, 1 ), LDB ) +* +* Interchange if a permutation was applied at the +* K-th step of the factorization. +* + KP = IPIV( K-1 ) + IF( KP.GT.0 ) THEN + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + ELSEIF( KP.LT.0 ) THEN + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( -KP, 1 ), LDB ) + CALL SSWAP( NRHS, B( K, 1 ), LDB, B( K-1, 1 ), LDB ) + END IF + END IF + K = K - 2 + GO TO 40 + 60 CONTINUE + END IF +*---------------------------------------- +* +* Compute B := A' * B (transpose) +* +*---------------------------------------- + ELSE +* +* Form B := U'*B +* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) +* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m) +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Loop backward applying the transformations. +* + K = N + 70 CONTINUE + IF( K.LE.1 ) + $ GO TO 90 +* +* 2 x 2 pivot block. +* + IF( K.GT.2 ) THEN +* +* Interchange if P(K) .ne. I. +* + KP = IPIV( K ) + IF( KP.GT.0 ) THEN + CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), + $ LDB ) + ELSEIF( KP.LT.0 ) THEN + CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( K, 1 ), + $ LDB ) + CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( -KP, 1 ), + $ LDB ) + ENDIF +* +* Apply the transformations +* + CALL SGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB, + $ A( 1, K ), 1, ONE, B( K, 1 ), LDB ) + CALL SGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB, + $ A( 1, K-1 ), 1, ONE, B( K-1, 1 ), LDB ) + END IF +* +* Multiply by the diagonal block if non-unit. +* + IF( NOUNIT ) THEN + D11 = ZERO + D22 = ZERO + D12 = A( K-1, K ) + D21 = -D12 + DO 80 J = 1, NRHS + T1 = B( K-1, J ) + T2 = B( K, J ) + B( K-1, J ) = D11*T1 + D12*T2 + B( K, J ) = D21*T1 + D22*T2 + 80 CONTINUE + END IF + K = K - 2 + GO TO 70 + 90 CONTINUE +* +* Form B := L'*B +* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) +* and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1) +* + ELSE +* +* Loop forward applying the L-transformations. +* + K = 1 + 100 CONTINUE + IF( K.GE.N ) + $ GO TO 120 +* +* 2 x 2 pivot block +* + IF( K.LT.N-1 ) THEN +* +* Interchange if P(K) .ne. I. +* + KP = IPIV( K ) + IF( KP.GT.0 ) THEN + CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), + $ LDB ) + ELSEIF( KP.LT.0 ) THEN + CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( K, 1 ), + $ LDB ) + CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( -KP, 1 ), + $ LDB ) + ENDIF +* +* Apply the transformation +* + CALL SGEMV( 'Transpose', N-K-1, NRHS, ONE, + $ B( K+2, 1 ), LDB, A( K+2, K+1 ), 1, ONE, + $ B( K+1, 1 ), LDB ) + CALL SGEMV( 'Transpose', N-K-1, NRHS, ONE, + $ B( K+2, 1 ), LDB, A( K+2, K ), 1, ONE, + $ B( K, 1 ), LDB ) + END IF +* +* Multiply by the diagonal block if non-unit. +* + IF( NOUNIT ) THEN + D11 = ZERO + D22 = ZERO + D21 = A( K+1, K ) + D12 = -D21 + DO 110 J = 1, NRHS + T1 = B( K, J ) + T2 = B( K+1, J ) + B( K, J ) = D11*T1 + D12*T2 + B( K+1, J ) = D21*T1 + D22*T2 + 110 CONTINUE + END IF + K = K + 2 + GO TO 100 + 120 CONTINUE + END IF +* + END IF + RETURN +* +* End of SLAVKY +* + END diff --git a/TESTING/LIN/spot07.f b/TESTING/LIN/spot07.f new file mode 100644 index 000000000..65be55fd3 --- /dev/null +++ b/TESTING/LIN/spot07.f @@ -0,0 +1,203 @@ +*> \brief \b SPOT07 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SPOT07( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, +* RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDB, LDX, N, NRHS +* REAL RESID +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), B( LDB, * ), RWORK( * ), +* $ X( LDX, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SPOT07 computes the residual for the solution of a skew-symmetric system +*> of linear equations A*x = b: +*> +*> RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ), +*> +*> where EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> skew-symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of columns of B, the matrix of right hand sides. +*> NRHS >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> The original skew-symmetric matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is REAL array, dimension (LDX,NRHS) +*> The computed solution vectors for the system of linear +*> equations. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. LDX >= max(1,N). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is REAL array, dimension (LDB,NRHS) +*> On entry, the right hand side vectors for the system of +*> linear equations. +*> On exit, B is overwritten with the difference B - A*X. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> The leading dimension of the array B. LDB >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is REAL +*> The maximum over the number of right hand sides of +*> norm(B - A*X) / ( norm(A) * norm(X) * EPS ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup single_lin +* +* ===================================================================== + SUBROUTINE SPOT07( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, + $ RESID ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDB, LDX, N, NRHS + REAL RESID +* .. +* .. Array Arguments .. + REAL A( LDA, * ), B( LDB, * ), RWORK( * ), + $ X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER J + REAL ANORM, BNORM, EPS, XNORM +* .. +* .. External Functions .. + REAL SASUM, SLAMCH, SLANKY + EXTERNAL SASUM, SLAMCH, SLANKY +* .. +* .. External Subroutines .. + EXTERNAL SKYMM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0 or NRHS = 0. +* + IF( N.LE.0 .OR. NRHS.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* Exit with RESID = 1/EPS if ANORM = 0. +* + EPS = SLAMCH( 'Epsilon' ) + ANORM = SLANKY( '1', UPLO, N, A, LDA, RWORK ) + IF( ANORM.LE.ZERO ) THEN + RESID = ONE / EPS + RETURN + END IF +* +* Compute B - A*X +* + CALL SKYMM( 'Left', UPLO, N, NRHS, -ONE, A, LDA, X, LDX, ONE, B, + $ LDB ) +* +* Compute the maximum over the number of right hand sides of +* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) . +* + RESID = ZERO + DO 10 J = 1, NRHS + BNORM = SASUM( N, B( 1, J ), 1 ) + XNORM = SASUM( N, X( 1, J ), 1 ) + IF( XNORM.LE.ZERO ) THEN + RESID = ONE / EPS + ELSE + RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS ) + END IF + 10 CONTINUE +* + RETURN +* +* End of SPOT07 +* + END diff --git a/TESTING/LIN/spot08.f b/TESTING/LIN/spot08.f new file mode 100644 index 000000000..1a6385055 --- /dev/null +++ b/TESTING/LIN/spot08.f @@ -0,0 +1,218 @@ +*> \brief \b SPOT08 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SPOT08( UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, +* RWORK, RCOND, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAINV, LDWORK, N +* REAL RCOND, RESID +* .. +* .. Array Arguments .. +* REAL A( LDA, * ), AINV( LDAINV, * ), RWORK( * ), +* $ WORK( LDWORK, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SPOT08 computes the residual for a skew-symmetric matrix times its +*> inverse: +*> norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), +*> where EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> skew-symmetric matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> The original skew-symmetric matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in,out] AINV +*> \verbatim +*> AINV is REAL array, dimension (LDAINV,N) +*> On entry, the inverse of the matrix A, stored as a skew-symmetric +*> matrix in the same format as A. +*> In this version, AINV is expanded into a full matrix and +*> multiplied by A, so the opposing triangle of AINV will be +*> changed; i.e., if the upper triangular part of AINV is +*> stored, the lower triangular part will be used as work space. +*> \endverbatim +*> +*> \param[in] LDAINV +*> \verbatim +*> LDAINV is INTEGER +*> The leading dimension of the array AINV. LDAINV >= max(1,N). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (LDWORK,N) +*> \endverbatim +*> +*> \param[in] LDWORK +*> \verbatim +*> LDWORK is INTEGER +*> The leading dimension of the array WORK. LDWORK >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (N) +*> \endverbatim +*> +*> \param[out] RCOND +*> \verbatim +*> RCOND is REAL +*> The reciprocal of the condition number of A, computed as +*> ( 1/norm(A) ) / norm(AINV). +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is REAL +*> norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup single_lin +* +* ===================================================================== + SUBROUTINE SPOT08( UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, + $ RWORK, RCOND, RESID ) +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDAINV, LDWORK, N + REAL RCOND, RESID +* .. +* .. Array Arguments .. + REAL A( LDA, * ), AINV( LDAINV, * ), RWORK( * ), + $ WORK( LDWORK, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + REAL AINVNM, ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SLAMCH, SLANGE, SLANKY + EXTERNAL LSAME, SLAMCH, SLANGE, SLANKY +* .. +* .. External Subroutines .. + EXTERNAL SKYMM +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RCOND = ONE + RESID = ZERO + RETURN + END IF +* +* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. +* + EPS = SLAMCH( 'Epsilon' ) + ANORM = SLANKY( '1', UPLO, N, A, LDA, RWORK ) + AINVNM = SLANKY( '1', UPLO, N, AINV, LDAINV, RWORK ) + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCOND = ZERO + RESID = ONE / EPS + RETURN + END IF + RCOND = ( ONE / ANORM ) / AINVNM +* +* Expand AINV into a full matrix and call SKYMM to multiply +* AINV on the left by A. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, J - 1 + AINV( J, I ) = -AINV( I, J ) + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = J + 1, N + AINV( J, I ) = -AINV( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + CALL SKYMM( 'Left', UPLO, N, N, -ONE, A, LDA, AINV, LDAINV, ZERO, + $ WORK, LDWORK ) +* +* Add the identity matrix to WORK . +* + DO 50 I = 1, N + WORK( I, I ) = WORK( I, I ) + ONE + 50 CONTINUE +* +* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) +* + RESID = SLANGE( '1', N, N, WORK, LDWORK, RWORK ) +* + RESID = ( ( RESID*RCOND ) / EPS ) / REAL( N ) +* + RETURN +* +* End of SPOT08 +* + END diff --git a/TESTING/MATGEN/CMakeLists.txt b/TESTING/MATGEN/CMakeLists.txt index 02e05a86d..72c2abd5f 100644 --- a/TESTING/MATGEN/CMakeLists.txt +++ b/TESTING/MATGEN/CMakeLists.txt @@ -14,7 +14,7 @@ set(SCATGEN slatm1.f slatm7.f slaran.f slarnd.f) set(SMATGEN slatms.f slatme.f slatmr.f slatmt.f - slagge.f slagsy.f slakf2.f slarge.f slaror.f slarot.f slatm2.f + slagge.f slagsy.f slagky.f slakf2.f slarge.f slaror.f slarot.f slatm2.f slatm3.f slatm5.f slatm6.f slahilb.f) set(CMATGEN clatms.f clatme.f clatmr.f clatmt.f @@ -24,7 +24,7 @@ set(CMATGEN clatms.f clatme.f clatmr.f clatmt.f set(DZATGEN dlatm1.f dlatm7.f dlaran.f dlarnd.f) set(DMATGEN dlatms.f dlatme.f dlatmr.f dlatmt.f - dlagge.f dlagsy.f dlakf2.f dlarge.f dlaror.f dlarot.f dlatm2.f + dlagge.f dlagsy.f dlagky.f dlakf2.f dlarge.f dlaror.f dlarot.f dlatm2.f dlatm3.f dlatm5.f dlatm6.f dlahilb.f) set(ZMATGEN zlatms.f zlatme.f zlatmr.f zlatmt.f diff --git a/TESTING/MATGEN/Makefile b/TESTING/MATGEN/Makefile index e8a915086..96e66b7d6 100644 --- a/TESTING/MATGEN/Makefile +++ b/TESTING/MATGEN/Makefile @@ -36,7 +36,7 @@ include $(TOPSRCDIR)/make.inc SCATGEN = slatm1.o slatm7.o slaran.o slarnd.o SMATGEN = slatms.o slatme.o slatmr.o slatmt.o \ - slagge.o slagsy.o slakf2.o slarge.o slaror.o slarot.o slatm2.o \ + slagge.o slagsy.o slagky.o slakf2.o slarge.o slaror.o slarot.o slatm2.o \ slatm3.o slatm5.o slatm6.o slahilb.o CMATGEN = clatms.o clatme.o clatmr.o clatmt.o \ @@ -46,7 +46,7 @@ CMATGEN = clatms.o clatme.o clatmr.o clatmt.o \ DZATGEN = dlatm1.o dlatm7.o dlaran.o dlarnd.o DMATGEN = dlatms.o dlatme.o dlatmr.o dlatmt.o \ - dlagge.o dlagsy.o dlakf2.o dlarge.o dlaror.o dlarot.o dlatm2.o \ + dlagge.o dlagsy.o dlagky.o dlakf2.o dlarge.o dlaror.o dlarot.o dlatm2.o \ dlatm3.o dlatm5.o dlatm6.o dlahilb.o ZMATGEN = zlatms.o zlatme.o zlatmr.o zlatmt.o \ diff --git a/TESTING/MATGEN/dlagky.f b/TESTING/MATGEN/dlagky.f new file mode 100644 index 000000000..4fafea6b5 --- /dev/null +++ b/TESTING/MATGEN/dlagky.f @@ -0,0 +1,261 @@ +*> \brief \b DLAGKY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DLAGKY( N, K, D, A, LDA, ISEED, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDA, N +* .. +* .. Array Arguments .. +* INTEGER ISEED( 4 ) +* DOUBLE PRECISION A( LDA, * ), D( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAGKY generates a real skew-symmetric matrix A, by pre- and post- +*> multiplying a real diagonal matrix D with a random orthogonal matrix: +*> A = U*D*U'. The semi-bandwidth may then be reduced to k by additional +*> orthogonal transformations. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of nonzero subdiagonals within the band of A. +*> 0 <= K <= N-1. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The diagonal elements of the diagonal matrix D. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The generated n by n skew-symmetric matrix A (the full matrix is +*> stored). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= N. +*> \endverbatim +*> +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry, the seed of the random number generator; the array +*> elements must be between 0 and 4095, and ISEED(4) must be +*> odd. +*> On exit, the seed is updated. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_matgen +* +* ===================================================================== + SUBROUTINE DLAGKY( N, K, D, A, LDA, ISEED, WORK, INFO ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, N +* .. +* .. Array Arguments .. + INTEGER ISEED( 4 ) + DOUBLE PRECISION A( LDA, * ), D( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION ALPHA, TAU, WA, WB, WN +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DGEMV, DGER, DLARNV, DSCAL, DKYMV, + $ DKYR2, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DDOT, DNRM2 + EXTERNAL DDOT, DNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SIGN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( K.LT.0 .OR. K.GT.N-1 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.LT.0 ) THEN + CALL XERBLA( 'DLAGKY', -INFO ) + RETURN + END IF +* +* initialize lower triangle of A to diagonal matrix +* + DO 20 J = 1, N + DO 10 I = J, N + A( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + DO 30 I = 1, N-1 + IF (MOD(I, 2).EQ.1) THEN + A( I+1, I ) = D(I) + END IF + 30 CONTINUE +* +* Generate lower triangle of skew-symmetric matrix +* + DO 40 I = N - 1, 1, -1 +* +* generate random reflection +* + CALL DLARNV( 3, ISEED, N-I+1, WORK ) + WN = DNRM2( N-I+1, WORK, 1 ) + WA = SIGN( WN, WORK( 1 ) ) + IF( WN.EQ.ZERO ) THEN + TAU = ZERO + ELSE + WB = WORK( 1 ) + WA + CALL DSCAL( N-I, ONE / WB, WORK( 2 ), 1 ) + WORK( 1 ) = ONE + TAU = WB / WA + END IF +* +* apply random reflection to A(i:n,i:n) from the left +* and the right +* +* compute y := tau * A * u +* + CALL DKYMV( 'Lower', N-I+1, TAU, A( I, I ), LDA, WORK, 1, ZERO, + $ WORK( N+1 ), 1 ) +* +* compute v := y - 1/2 * tau * ( y, u ) * u +* + ALPHA = -HALF*TAU*DDOT( N-I+1, WORK( N+1 ), 1, WORK, 1 ) + CALL DAXPY( N-I+1, ALPHA, WORK, 1, WORK( N+1 ), 1 ) +* +* apply the transformation as a rank-2 update to A(i:n,i:n) +* + CALL DKYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1, + $ A( I, I ), LDA ) + 40 CONTINUE +* +* Reduce number of subdiagonals to K +* + DO 60 I = 1, N - 1 - K +* +* generate reflection to annihilate A(k+i+1:n,i) +* + WN = DNRM2( N-K-I+1, A( K+I, I ), 1 ) + WA = SIGN( WN, A( K+I, I ) ) + IF( WN.EQ.ZERO ) THEN + TAU = ZERO + ELSE + WB = A( K+I, I ) + WA + CALL DSCAL( N-K-I, ONE / WB, A( K+I+1, I ), 1 ) + A( K+I, I ) = ONE + TAU = WB / WA + END IF +* +* apply reflection to A(k+i:n,i+1:k+i-1) from the left +* + CALL DGEMV( 'Transpose', N-K-I+1, K-1, ONE, A( K+I, I+1 ), LDA, + $ A( K+I, I ), 1, ZERO, WORK, 1 ) + CALL DGER( N-K-I+1, K-1, -TAU, A( K+I, I ), 1, WORK, 1, + $ A( K+I, I+1 ), LDA ) +* +* apply reflection to A(k+i:n,k+i:n) from the left and the right +* +* compute y := tau * A * u +* + CALL DKYMV( 'Lower', N-K-I+1, TAU, A( K+I, K+I ), LDA, + $ A( K+I, I ), 1, ZERO, WORK, 1 ) +* +* compute v := y - 1/2 * tau * ( y, u ) * u +* + ALPHA = -HALF*TAU*DDOT( N-K-I+1, WORK, 1, A( K+I, I ), 1 ) + CALL DAXPY( N-K-I+1, ALPHA, A( K+I, I ), 1, WORK, 1 ) +* +* apply skew-symmetric rank-2 update to A(k+i:n,k+i:n) +* + CALL DKYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1, + $ A( K+I, K+I ), LDA ) +* + A( K+I, I ) = -WA + DO 50 J = K + I + 1, N + A( J, I ) = ZERO + 50 CONTINUE + 60 CONTINUE +* +* Store full skew-symmetric matrix +* + DO 80 J = 1, N + DO 70 I = J + 1, N + A( J, I ) = -A( I, J ) + 70 CONTINUE + A( J, J ) = ZERO + 80 CONTINUE + RETURN +* +* End of DLAGKY +* + END diff --git a/TESTING/MATGEN/dlatmr.f b/TESTING/MATGEN/dlatmr.f index 4bcc12f36..a25f0577c 100644 --- a/TESTING/MATGEN/dlatmr.f +++ b/TESTING/MATGEN/dlatmr.f @@ -36,8 +36,8 @@ *> operations: *> *> Generate a matrix A with random entries of distribution DIST -*> which is symmetric if SYM='S', and nonsymmetric -*> if SYM='N'. +*> which is symmetric if SYM='S', skew-symmetric if SYM='K', +*> and nonsymmetric if SYM='N'. *> *> Set the diagonal to D, where D may be input or *> computed according to MODE, COND, DMAX and RSIGN @@ -61,8 +61,8 @@ *> *> Pack the matrix if desired. Options specified by PACK are: *> no packing -*> zero out upper half (if symmetric) -*> zero out lower half (if symmetric) +*> zero out upper half (if symmetric/skew-symmetric) +*> zero out lower half (if symmetric/skew-symmetric) *> store the upper half columnwise (if symmetric or *> square upper triangular) *> store the lower half columnwise (if symmetric or @@ -104,7 +104,7 @@ *> On entry, DIST specifies the type of distribution to be used *> to generate a random matrix . *> 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) -*> 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) +*> 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric/skew-symmetric ) *> 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) *> Not modified. *> \endverbatim @@ -128,6 +128,7 @@ *> SYM is CHARACTER*1 *> If SYM='S' or 'H', generated matrix is symmetric. *> If SYM='N', generated matrix is nonsymmetric. +*> If SYM='K', generated matrix is skew-symmetric. *> Not modified. *> \endverbatim *> @@ -203,6 +204,9 @@ *> 'S' or 'H' => matrix premultiplied by diag( DL ) and *> postmultiplied by diag( DL ) *> ('S' for symmetric, or 'H' for Hermitian) +*> 'K' => matrix premultiplied by diag( DL ) and +*> postmultiplied by diag( DL ) +*> ('K' for skew-symmetric) *> 'E' => matrix premultiplied by diag( DL ) and *> postmultiplied by inv( diag( DL ) ) *> ( 'E' for eigenvalue invariance) @@ -309,7 +313,7 @@ *> On entry specifies the lower bandwidth of the matrix. For *> example, KL=0 implies upper triangular, KL=1 implies upper *> Hessenberg, and KL at least M-1 implies the matrix is not -*> banded. Must equal KU if matrix is symmetric. +*> banded. Must equal KU if matrix is symmetric/skew-symmetric. *> Not modified. *> \endverbatim *> @@ -319,7 +323,7 @@ *> On entry specifies the upper bandwidth of the matrix. For *> example, KU=0 implies lower triangular, KU=1 implies lower *> Hessenberg, and KU at least N-1 implies the matrix is not -*> banded. Must equal KL if matrix is symmetric. +*> banded. Must equal KL if matrix is symmetric/skew-symmetric. *> Not modified. *> \endverbatim *> @@ -352,8 +356,8 @@ *> PACK is CHARACTER*1 *> On entry specifies packing of matrix as follows: *> 'N' => no packing -*> 'U' => zero out all subdiagonal entries (if symmetric) -*> 'L' => zero out all superdiagonal entries (if symmetric) +*> 'U' => zero out all subdiagonal entries (if symmetric/skew-symmetric) +*> 'L' => zero out all superdiagonal entries (if symmetric/skew-symmetric) *> 'C' => store the upper triangle columnwise *> (only if matrix symmetric or square upper triangular) *> 'R' => store the lower triangle columnwise @@ -548,6 +552,8 @@ SUBROUTINE DLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, ISYM = 1 ELSE IF( LSAME( SYM, 'H' ) ) THEN ISYM = 0 + ELSE IF( LSAME( SYM, 'K' ) ) THEN + ISYM = 2 ELSE ISYM = -1 END IF @@ -654,7 +660,7 @@ SUBROUTINE DLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, * IF( M.LT.0 ) THEN INFO = -1 - ELSE IF( M.NE.N .AND. ISYM.EQ.0 ) THEN + ELSE IF( M.NE.N .AND. (ISYM.EQ.0 .OR. ISYM.EQ.2) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 @@ -671,8 +677,8 @@ SUBROUTINE DLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ IRSIGN.EQ.-1 ) THEN INFO = -10 ELSE IF( IGRADE.EQ.-1 .OR. ( IGRADE.EQ.4 .AND. M.NE.N ) .OR. - $ ( ( IGRADE.GE.1 .AND. IGRADE.LE.4 ) .AND. ISYM.EQ.0 ) ) - $ THEN + $ ( ( IGRADE.GE.1 .AND. IGRADE.LE.4 ) .AND. + $ ( ISYM.EQ.0 .OR. ISYM.EQ.2 ) ) ) THEN INFO = -11 ELSE IF( IGRADE.EQ.4 .AND. DZERO ) THEN INFO = -12 @@ -692,14 +698,15 @@ SUBROUTINE DLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ CONDR.LT.ONE ) THEN INFO = -17 ELSE IF( IPVTNG.EQ.-1 .OR. ( IPVTNG.EQ.3 .AND. M.NE.N ) .OR. - $ ( ( IPVTNG.EQ.1 .OR. IPVTNG.EQ.2 ) .AND. ISYM.EQ.0 ) ) - $ THEN + $ ( ( IPVTNG.EQ.1 .OR. IPVTNG.EQ.2 ) .AND. + $ ( ISYM.EQ.0 .OR. ISYM.EQ.2 ) ) ) THEN INFO = -18 ELSE IF( IPVTNG.NE.0 .AND. BADPVT ) THEN INFO = -19 ELSE IF( KL.LT.0 ) THEN INFO = -20 - ELSE IF( KU.LT.0 .OR. ( ISYM.EQ.0 .AND. KL.NE.KU ) ) THEN + ELSE IF( KU.LT.0 .OR. ( ( ISYM.EQ.0 .OR. ISYM.EQ.2 ) .AND. + $ KL.NE.KU ) ) THEN INFO = -21 ELSE IF( SPARSE.LT.ZERO .OR. SPARSE.GT.ONE ) THEN INFO = -22 @@ -813,8 +820,8 @@ SUBROUTINE DLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, END IF * * 4) Generate matrices for each kind of PACKing -* Always sweep matrix columnwise (if symmetric, upper -* half only) so that matrix generated does not depend +* Always sweep matrix columnwise (if symmetric/skew-symmetric, +* upper half only) so that matrix generated does not depend * on PACK * IF( FULBND ) THEN @@ -823,7 +830,7 @@ SUBROUTINE DLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, * differ only in the order of their rows and/or columns. * IF( IPACK.EQ.0 ) THEN - IF( ISYM.EQ.0 ) THEN + IF( ( ISYM.EQ.0 .OR. ISYM.EQ.2 ) ) THEN DO 100 J = 1, N DO 90 I = 1, J TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, @@ -996,7 +1003,7 @@ SUBROUTINE DLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, * Use DLATM2 * IF( IPACK.EQ.0 ) THEN - IF( ISYM.EQ.0 ) THEN + IF( (ISYM.EQ.0 .OR. ISYM.EQ.2 ) ) THEN DO 300 J = 1, N DO 290 I = 1, J A( I, J ) = DLATM2( M, N, I, J, KL, KU, IDIST, diff --git a/TESTING/MATGEN/dlatms.f b/TESTING/MATGEN/dlatms.f index 0cb6cf243..291dac3f3 100644 --- a/TESTING/MATGEN/dlatms.f +++ b/TESTING/MATGEN/dlatms.f @@ -28,7 +28,7 @@ *> \verbatim *> *> DLATMS generates random matrices with specified singular values -*> (or symmetric/hermitian with specified eigenvalues) +*> (or symmetric/hermitian/skew-symmetric with specified eigenvalues) *> for testing LAPACK programs. *> *> DLATMS operates by applying the following sequence of @@ -67,8 +67,8 @@ *> *> Pack the matrix if desired. Options specified by PACK are: *> no packing -*> zero out upper half (if symmetric) -*> zero out lower half (if symmetric) +*> zero out upper half (if symmetric/skew-symmetric) +*> zero out lower half (if symmetric/skew-symmetric) *> store the upper half columnwise (if symmetric or upper *> triangular) *> store the lower half columnwise (if symmetric or lower @@ -104,7 +104,7 @@ *> On entry, DIST specifies the type of distribution to be used *> to generate the random eigen-/singular values. *> 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) -*> 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) +*> 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric/skew-symmetric ) *> 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) *> Not modified. *> \endverbatim @@ -129,6 +129,9 @@ *> If SYM='S' or 'H', the generated matrix is symmetric, with *> eigenvalues specified by D, COND, MODE, and DMAX; they *> may be positive, negative, or zero. +*> If SYM='K', the generated matrix is skew-symmetric, with +*> eigenvalues specified by D, COND, MODE, and DMAX; they +*> may be positive, negative, or zero. *> If SYM='P', the generated matrix is symmetric, with *> eigenvalues (= singular values) specified by D, COND, *> MODE, and DMAX; they will not be negative. @@ -200,7 +203,7 @@ *> example, KL=0 implies upper triangular, KL=1 implies upper *> Hessenberg, and KL being at least M-1 means that the matrix *> has full lower bandwidth. KL must equal KU if the matrix -*> is symmetric. +*> is symmetric/skew-symmetric. *> Not modified. *> \endverbatim *> @@ -211,7 +214,7 @@ *> example, KU=0 implies lower triangular, KU=1 implies lower *> Hessenberg, and KU being at least N-1 means that the matrix *> has full upper bandwidth. KL must equal KU if the matrix -*> is symmetric. +*> is symmetric/skew-symmetric. *> Not modified. *> \endverbatim *> @@ -220,8 +223,8 @@ *> PACK is CHARACTER*1 *> This specifies packing of matrix as follows: *> 'N' => no packing -*> 'U' => zero out all subdiagonal entries (if symmetric) -*> 'L' => zero out all superdiagonal entries (if symmetric) +*> 'U' => zero out all subdiagonal entries (if symmetric/skew-symmetric) +*> 'L' => zero out all superdiagonal entries (if symmetric/skew-symmetric) *> 'C' => store the upper triangle columnwise *> (only if the matrix is symmetric or upper triangular) *> 'R' => store the lower triangle columnwise @@ -285,7 +288,7 @@ *> Error code. On exit, INFO will be set to one of the *> following values: *> 0 => normal return -*> -1 => M negative or unequal to N and SYM='S', 'H', or 'P' +*> -1 => M negative or unequal to N and SYM='S', 'H', 'K', or 'P' *> -2 => N negative *> -3 => DIST illegal string *> -5 => SYM illegal string @@ -349,7 +352,7 @@ SUBROUTINE DLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ IOFFG, IOFFST, IPACK, IPACKG, IR, IR1, IR2, $ IROW, IRSIGN, ISKEW, ISYM, ISYMPK, J, JC, JCH, $ JKL, JKU, JR, K, LLB, MINLDA, MNMIN, MR, NC, - $ UUB + $ UUB, MNMINNEW DOUBLE PRECISION ALPHA, ANGLE, C, DUMMY, EXTRA, S, TEMP * .. * .. External Functions .. @@ -358,7 +361,7 @@ SUBROUTINE DLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, EXTERNAL LSAME, DLARND * .. * .. External Subroutines .. - EXTERNAL DCOPY, DLAGGE, DLAGSY, + EXTERNAL DCOPY, DLAGGE, DLAGSY, DLAGKY, $ DLAROT, DLARTG, DLASET, $ DLATM1, DSCAL, XERBLA * .. @@ -403,6 +406,9 @@ SUBROUTINE DLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, ELSE IF( LSAME( SYM, 'H' ) ) THEN ISYM = 2 IRSIGN = 1 + ELSE IF( LSAME( SYM, 'K' ) ) THEN + ISYM = 3 + IRSIGN = 1 ELSE ISYM = -1 END IF @@ -465,6 +471,9 @@ SUBROUTINE DLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, END IF IF( LDA.LT.M .AND. LDA.GE.MINLDA ) $ GIVENS = .TRUE. + IF( ISYM.EQ.3 ) THEN + GIVENS = .FALSE. + END IF * * Set INFO if an error * @@ -514,17 +523,25 @@ SUBROUTINE DLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, * * Compute D according to COND and MODE * - CALL DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, MNMIN, - $ IINFO ) + IF( ISYM.EQ.3 ) THEN + MNMINNEW = MNMIN / 2 + ELSE + MNMINNEW = MNMIN + END IF + CALL DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, + $ MNMINNEW, IINFO ) IF( IINFO.NE.0 ) THEN INFO = 1 RETURN END IF + IF( ISYM.EQ.3 .AND. MNMIN.EQ.1 ) THEN + D(1) = ONE + END IF * * Choose Top-Down if D is (apparently) increasing, * Bottom-Up if D is (apparently) decreasing. * - IF( ABS( D( 1 ) ).LE.ABS( D( MNMIN ) ) ) THEN + IF( ABS( D( 1 ) ).LE.ABS( D( MNMINNEW ) ) ) THEN TOPDWN = .TRUE. ELSE TOPDWN = .FALSE. @@ -535,7 +552,7 @@ SUBROUTINE DLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, * Scale by DMAX * TEMP = ABS( D( 1 ) ) - DO 20 I = 2, MNMIN + DO 20 I = 2, MNMINNEW TEMP = MAX( TEMP, ABS( D( I ) ) ) 20 CONTINUE * @@ -546,9 +563,19 @@ SUBROUTINE DLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, RETURN END IF * - CALL DSCAL( MNMIN, ALPHA, D, 1 ) + CALL DSCAL( MNMINNEW, ALPHA, D, 1 ) * END IF +* + IF( ISYM.EQ.3 ) THEN + DO I = MNMIN, 2*MNMINNEW + 1, -1 + D(I) = ZERO + END DO + DO I = MNMINNEW, 1, -1 + D(2*I - 1) = D(I) + D(2*I) = ZERO + END DO + END IF * * 3) Generate Banded Matrix using Givens rotations. * Also the special case of UUB=LLB=0 @@ -1008,11 +1035,17 @@ SUBROUTINE DLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, * CALL DLAGGE( MR, NC, LLB, UUB, D, A, LDA, ISEED, WORK, $ IINFO ) - ELSE + ELSEIF( ISYM.EQ.2 ) THEN * * Symmetric -- A = U D U' * CALL DLAGSY( M, LLB, D, A, LDA, ISEED, WORK, IINFO ) +* + ELSE +* +* Skew-symmetric -- A = U D U' +* + CALL DLAGKY( M, LLB, D, A, LDA, ISEED, WORK, IINFO ) * END IF IF( IINFO.NE.0 ) THEN diff --git a/TESTING/MATGEN/slagky.f b/TESTING/MATGEN/slagky.f new file mode 100644 index 000000000..18b2e4f7e --- /dev/null +++ b/TESTING/MATGEN/slagky.f @@ -0,0 +1,261 @@ +*> \brief \b SLAGKY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SLAGKY( N, K, D, A, LDA, ISEED, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDA, N +* .. +* .. Array Arguments .. +* INTEGER ISEED( 4 ) +* REAL A( LDA, * ), D( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLAGKY generates a real skew-symmetric matrix A, by pre- and post- +*> multiplying a real diagonal matrix D with a random orthogonal matrix: +*> A = U*D*U'. The semi-bandwidth may then be reduced to k by additional +*> orthogonal transformations. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of nonzero subdiagonals within the band of A. +*> 0 <= K <= N-1. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is REAL array, dimension (N) +*> The diagonal elements of the diagonal matrix D. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> The generated n by n skew-symmetric matrix A (the full matrix is +*> stored). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= N. +*> \endverbatim +*> +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry, the seed of the random number generator; the array +*> elements must be between 0 and 4095, and ISEED(4) must be +*> odd. +*> On exit, the seed is updated. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup real_matgen +* +* ===================================================================== + SUBROUTINE SLAGKY( N, K, D, A, LDA, ISEED, WORK, INFO ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, N +* .. +* .. Array Arguments .. + INTEGER ISEED( 4 ) + REAL A( LDA, * ), D( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, HALF = 0.5E+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + REAL ALPHA, TAU, WA, WB, WN +* .. +* .. External Subroutines .. + EXTERNAL SAXPY, SGEMV, SGER, SLARNV, SSCAL, SKYMV, + $ SKYR2, XERBLA +* .. +* .. External Functions .. + REAL SDOT, SNRM2 + EXTERNAL SDOT, SNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SIGN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( K.LT.0 .OR. K.GT.N-1 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.LT.0 ) THEN + CALL XERBLA( 'SLAGKY', -INFO ) + RETURN + END IF +* +* initialize lower triangle of A to diagonal matrix +* + DO 20 J = 1, N + DO 10 I = J, N + A( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + DO 30 I = 1, N-1 + IF (MOD(I, 2).EQ.1) THEN + A( I+1, I ) = D(I) + END IF + 30 CONTINUE +* +* Generate lower triangle of skew-symmetric matrix +* + DO 40 I = N - 1, 1, -1 +* +* generate random reflection +* + CALL SLARNV( 3, ISEED, N-I+1, WORK ) + WN = SNRM2( N-I+1, WORK, 1 ) + WA = SIGN( WN, WORK( 1 ) ) + IF( WN.EQ.ZERO ) THEN + TAU = ZERO + ELSE + WB = WORK( 1 ) + WA + CALL SSCAL( N-I, ONE / WB, WORK( 2 ), 1 ) + WORK( 1 ) = ONE + TAU = WB / WA + END IF +* +* apply random reflection to A(i:n,i:n) from the left +* and the right +* +* compute y := tau * A * u +* + CALL SKYMV( 'Lower', N-I+1, TAU, A( I, I ), LDA, WORK, 1, ZERO, + $ WORK( N+1 ), 1 ) +* +* compute v := y - 1/2 * tau * ( y, u ) * u +* + ALPHA = -HALF*TAU*SDOT( N-I+1, WORK( N+1 ), 1, WORK, 1 ) + CALL SAXPY( N-I+1, ALPHA, WORK, 1, WORK( N+1 ), 1 ) +* +* apply the transformation as a rank-2 update to A(i:n,i:n) +* + CALL SKYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1, + $ A( I, I ), LDA ) + 40 CONTINUE +* +* Reduce number of subdiagonals to K +* + DO 60 I = 1, N - 1 - K +* +* generate reflection to annihilate A(k+i+1:n,i) +* + WN = SNRM2( N-K-I+1, A( K+I, I ), 1 ) + WA = SIGN( WN, A( K+I, I ) ) + IF( WN.EQ.ZERO ) THEN + TAU = ZERO + ELSE + WB = A( K+I, I ) + WA + CALL SSCAL( N-K-I, ONE / WB, A( K+I+1, I ), 1 ) + A( K+I, I ) = ONE + TAU = WB / WA + END IF +* +* apply reflection to A(k+i:n,i+1:k+i-1) from the left +* + CALL SGEMV( 'Transpose', N-K-I+1, K-1, ONE, A( K+I, I+1 ), LDA, + $ A( K+I, I ), 1, ZERO, WORK, 1 ) + CALL SGER( N-K-I+1, K-1, -TAU, A( K+I, I ), 1, WORK, 1, + $ A( K+I, I+1 ), LDA ) +* +* apply reflection to A(k+i:n,k+i:n) from the left and the right +* +* compute y := tau * A * u +* + CALL SKYMV( 'Lower', N-K-I+1, TAU, A( K+I, K+I ), LDA, + $ A( K+I, I ), 1, ZERO, WORK, 1 ) +* +* compute v := y - 1/2 * tau * ( y, u ) * u +* + ALPHA = -HALF*TAU*SDOT( N-K-I+1, WORK, 1, A( K+I, I ), 1 ) + CALL SAXPY( N-K-I+1, ALPHA, A( K+I, I ), 1, WORK, 1 ) +* +* apply skew-symmetric rank-2 update to A(k+i:n,k+i:n) +* + CALL SKYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1, + $ A( K+I, K+I ), LDA ) +* + A( K+I, I ) = -WA + DO 50 J = K + I + 1, N + A( J, I ) = ZERO + 50 CONTINUE + 60 CONTINUE +* +* Store full skew-symmetric matrix +* + DO 80 J = 1, N + DO 70 I = J + 1, N + A( J, I ) = -A( I, J ) + 70 CONTINUE + A( J, J ) = ZERO + 80 CONTINUE + RETURN +* +* End of SLAGKY +* + END diff --git a/TESTING/MATGEN/slatmr.f b/TESTING/MATGEN/slatmr.f index 0761fef0a..70b507578 100644 --- a/TESTING/MATGEN/slatmr.f +++ b/TESTING/MATGEN/slatmr.f @@ -36,8 +36,8 @@ *> operations: *> *> Generate a matrix A with random entries of distribution DIST -*> which is symmetric if SYM='S', and nonsymmetric -*> if SYM='N'. +*> which is symmetric if SYM='S', skew-symmetric if SYM='K', +*> and nonsymmetric if SYM='N'. *> *> Set the diagonal to D, where D may be input or *> computed according to MODE, COND, DMAX and RSIGN @@ -61,8 +61,8 @@ *> *> Pack the matrix if desired. Options specified by PACK are: *> no packing -*> zero out upper half (if symmetric) -*> zero out lower half (if symmetric) +*> zero out upper half (if symmetric/skew-symmetric) +*> zero out lower half (if symmetric/skew-symmetric) *> store the upper half columnwise (if symmetric or *> square upper triangular) *> store the lower half columnwise (if symmetric or @@ -104,7 +104,7 @@ *> On entry, DIST specifies the type of distribution to be used *> to generate a random matrix . *> 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) -*> 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) +*> 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric/skew-symmetric ) *> 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) *> Not modified. *> \endverbatim @@ -128,6 +128,7 @@ *> SYM is CHARACTER*1 *> If SYM='S' or 'H', generated matrix is symmetric. *> If SYM='N', generated matrix is nonsymmetric. +*> If SYM='K', generated matrix is skew-symmetric. *> Not modified. *> \endverbatim *> @@ -203,6 +204,9 @@ *> 'S' or 'H' => matrix premultiplied by diag( DL ) and *> postmultiplied by diag( DL ) *> ('S' for symmetric, or 'H' for Hermitian) +*> 'K' => matrix premultiplied by diag( DL ) and +*> postmultiplied by diag( DL ) +*> ('K' for skew-symmetric) *> 'E' => matrix premultiplied by diag( DL ) and *> postmultiplied by inv( diag( DL ) ) *> ( 'E' for eigenvalue invariance) @@ -309,7 +313,7 @@ *> On entry specifies the lower bandwidth of the matrix. For *> example, KL=0 implies upper triangular, KL=1 implies upper *> Hessenberg, and KL at least M-1 implies the matrix is not -*> banded. Must equal KU if matrix is symmetric. +*> banded. Must equal KU if matrix is symmetric/skew-symmetric. *> Not modified. *> \endverbatim *> @@ -319,7 +323,7 @@ *> On entry specifies the upper bandwidth of the matrix. For *> example, KU=0 implies lower triangular, KU=1 implies lower *> Hessenberg, and KU at least N-1 implies the matrix is not -*> banded. Must equal KL if matrix is symmetric. +*> banded. Must equal KL if matrix is symmetric/skew-symmetric. *> Not modified. *> \endverbatim *> @@ -352,8 +356,8 @@ *> PACK is CHARACTER*1 *> On entry specifies packing of matrix as follows: *> 'N' => no packing -*> 'U' => zero out all subdiagonal entries (if symmetric) -*> 'L' => zero out all superdiagonal entries (if symmetric) +*> 'U' => zero out all subdiagonal entries (if symmetric/skew-symmetric) +*> 'L' => zero out all superdiagonal entries (if symmetric/skew-symmetric) *> 'C' => store the upper triangle columnwise *> (only if matrix symmetric or square upper triangular) *> 'R' => store the lower triangle columnwise @@ -548,6 +552,8 @@ SUBROUTINE SLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, ISYM = 1 ELSE IF( LSAME( SYM, 'H' ) ) THEN ISYM = 0 + ELSE IF( LSAME( SYM, 'K' ) ) THEN + ISYM = 2 ELSE ISYM = -1 END IF @@ -654,7 +660,7 @@ SUBROUTINE SLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, * IF( M.LT.0 ) THEN INFO = -1 - ELSE IF( M.NE.N .AND. ISYM.EQ.0 ) THEN + ELSE IF( M.NE.N .AND. (ISYM.EQ.0 .OR. ISYM.EQ.2) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 @@ -671,8 +677,8 @@ SUBROUTINE SLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ IRSIGN.EQ.-1 ) THEN INFO = -10 ELSE IF( IGRADE.EQ.-1 .OR. ( IGRADE.EQ.4 .AND. M.NE.N ) .OR. - $ ( ( IGRADE.GE.1 .AND. IGRADE.LE.4 ) .AND. ISYM.EQ.0 ) ) - $ THEN + $ ( ( IGRADE.GE.1 .AND. IGRADE.LE.4 ) .AND. + $ ( ISYM.EQ.0 .OR. ISYM.EQ.2 ) ) ) THEN INFO = -11 ELSE IF( IGRADE.EQ.4 .AND. DZERO ) THEN INFO = -12 @@ -692,14 +698,15 @@ SUBROUTINE SLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ CONDR.LT.ONE ) THEN INFO = -17 ELSE IF( IPVTNG.EQ.-1 .OR. ( IPVTNG.EQ.3 .AND. M.NE.N ) .OR. - $ ( ( IPVTNG.EQ.1 .OR. IPVTNG.EQ.2 ) .AND. ISYM.EQ.0 ) ) - $ THEN + $ ( ( IPVTNG.EQ.1 .OR. IPVTNG.EQ.2 ) .AND. + $ ( ISYM.EQ.0 .OR. ISYM.EQ.2 ) ) ) THEN INFO = -18 ELSE IF( IPVTNG.NE.0 .AND. BADPVT ) THEN INFO = -19 ELSE IF( KL.LT.0 ) THEN INFO = -20 - ELSE IF( KU.LT.0 .OR. ( ISYM.EQ.0 .AND. KL.NE.KU ) ) THEN + ELSE IF( KU.LT.0 .OR. ( ( ISYM.EQ.0 .OR. ISYM.EQ.2 ) .AND. + $ KL.NE.KU ) ) THEN INFO = -21 ELSE IF( SPARSE.LT.ZERO .OR. SPARSE.GT.ONE ) THEN INFO = -22 @@ -813,8 +820,8 @@ SUBROUTINE SLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, END IF * * 4) Generate matrices for each kind of PACKing -* Always sweep matrix columnwise (if symmetric, upper -* half only) so that matrix generated does not depend +* Always sweep matrix columnwise (if symmetric/skew-symmetric, +* upper half only) so that matrix generated does not depend * on PACK * IF( FULBND ) THEN @@ -823,7 +830,7 @@ SUBROUTINE SLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, * differ only in the order of their rows and/or columns. * IF( IPACK.EQ.0 ) THEN - IF( ISYM.EQ.0 ) THEN + IF( ( ISYM.EQ.0 .OR. ISYM.EQ.2 ) ) THEN DO 100 J = 1, N DO 90 I = 1, J TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, @@ -996,7 +1003,7 @@ SUBROUTINE SLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, * Use SLATM2 * IF( IPACK.EQ.0 ) THEN - IF( ISYM.EQ.0 ) THEN + IF( (ISYM.EQ.0 .OR. ISYM.EQ.2 ) ) THEN DO 300 J = 1, N DO 290 I = 1, J A( I, J ) = SLATM2( M, N, I, J, KL, KU, IDIST, diff --git a/TESTING/MATGEN/slatms.f b/TESTING/MATGEN/slatms.f index aead76b5f..2e3c8bbc1 100644 --- a/TESTING/MATGEN/slatms.f +++ b/TESTING/MATGEN/slatms.f @@ -28,7 +28,7 @@ *> \verbatim *> *> SLATMS generates random matrices with specified singular values -*> (or symmetric/hermitian with specified eigenvalues) +*> (or symmetric/hermitian/skew-symmetric with specified eigenvalues) *> for testing LAPACK programs. *> *> SLATMS operates by applying the following sequence of @@ -67,8 +67,8 @@ *> *> Pack the matrix if desired. Options specified by PACK are: *> no packing -*> zero out upper half (if symmetric) -*> zero out lower half (if symmetric) +*> zero out upper half (if symmetric/skew-symmetric) +*> zero out lower half (if symmetric/skew-symmetric) *> store the upper half columnwise (if symmetric or upper *> triangular) *> store the lower half columnwise (if symmetric or lower @@ -104,7 +104,7 @@ *> On entry, DIST specifies the type of distribution to be used *> to generate the random eigen-/singular values. *> 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) -*> 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) +*> 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric/skew-symmetric ) *> 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) *> Not modified. *> \endverbatim @@ -129,6 +129,9 @@ *> If SYM='S' or 'H', the generated matrix is symmetric, with *> eigenvalues specified by D, COND, MODE, and DMAX; they *> may be positive, negative, or zero. +*> If SYM='K', the generated matrix is skew-symmetric, with +*> eigenvalues specified by D, COND, MODE, and DMAX; they +*> may be positive, negative, or zero. *> If SYM='P', the generated matrix is symmetric, with *> eigenvalues (= singular values) specified by D, COND, *> MODE, and DMAX; they will not be negative. @@ -200,7 +203,7 @@ *> example, KL=0 implies upper triangular, KL=1 implies upper *> Hessenberg, and KL being at least M-1 means that the matrix *> has full lower bandwidth. KL must equal KU if the matrix -*> is symmetric. +*> is symmetric/skew-symmetric. *> Not modified. *> \endverbatim *> @@ -211,7 +214,7 @@ *> example, KU=0 implies lower triangular, KU=1 implies lower *> Hessenberg, and KU being at least N-1 means that the matrix *> has full upper bandwidth. KL must equal KU if the matrix -*> is symmetric. +*> is symmetric/skew-symmetric. *> Not modified. *> \endverbatim *> @@ -220,8 +223,8 @@ *> PACK is CHARACTER*1 *> This specifies packing of matrix as follows: *> 'N' => no packing -*> 'U' => zero out all subdiagonal entries (if symmetric) -*> 'L' => zero out all superdiagonal entries (if symmetric) +*> 'U' => zero out all subdiagonal entries (if symmetric/skew-symmetric) +*> 'L' => zero out all superdiagonal entries (if symmetric/skew-symmetric) *> 'C' => store the upper triangle columnwise *> (only if the matrix is symmetric or upper triangular) *> 'R' => store the lower triangle columnwise @@ -285,7 +288,7 @@ *> Error code. On exit, INFO will be set to one of the *> following values: *> 0 => normal return -*> -1 => M negative or unequal to N and SYM='S', 'H', or 'P' +*> -1 => M negative or unequal to N and SYM='S', 'H', 'K', or 'P' *> -2 => N negative *> -3 => DIST illegal string *> -5 => SYM illegal string @@ -349,7 +352,7 @@ SUBROUTINE SLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ IOFFG, IOFFST, IPACK, IPACKG, IR, IR1, IR2, $ IROW, IRSIGN, ISKEW, ISYM, ISYMPK, J, JC, JCH, $ JKL, JKU, JR, K, LLB, MINLDA, MNMIN, MR, NC, - $ UUB + $ UUB, MNMINNEW REAL ALPHA, ANGLE, C, DUMMY, EXTRA, S, TEMP * .. * .. External Functions .. @@ -358,7 +361,7 @@ SUBROUTINE SLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, EXTERNAL LSAME, SLARND * .. * .. External Subroutines .. - EXTERNAL SCOPY, SLAGGE, SLAGSY, + EXTERNAL SCOPY, SLAGGE, SLAGSY, SLAGKY, $ SLAROT, SLARTG, SLATM1, $ SLASET, SSCAL, XERBLA * .. @@ -403,6 +406,9 @@ SUBROUTINE SLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, ELSE IF( LSAME( SYM, 'H' ) ) THEN ISYM = 2 IRSIGN = 1 + ELSE IF( LSAME( SYM, 'K' ) ) THEN + ISYM = 3 + IRSIGN = 1 ELSE ISYM = -1 END IF @@ -465,6 +471,9 @@ SUBROUTINE SLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, END IF IF( LDA.LT.M .AND. LDA.GE.MINLDA ) $ GIVENS = .TRUE. + IF( ISYM.EQ.3 ) THEN + GIVENS = .FALSE. + END IF * * Set INFO if an error * @@ -514,17 +523,25 @@ SUBROUTINE SLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, * * Compute D according to COND and MODE * - CALL SLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, MNMIN, - $ IINFO ) + IF( ISYM.EQ.3 ) THEN + MNMINNEW = MNMIN / 2 + ELSE + MNMINNEW = MNMIN + END IF + CALL SLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, + $ MNMINNEW, IINFO ) IF( IINFO.NE.0 ) THEN INFO = 1 RETURN END IF + IF( ISYM.EQ.3 .AND. MNMIN.EQ.1 ) THEN + D(1) = ONE + END IF * * Choose Top-Down if D is (apparently) increasing, * Bottom-Up if D is (apparently) decreasing. * - IF( ABS( D( 1 ) ).LE.ABS( D( MNMIN ) ) ) THEN + IF( ABS( D( 1 ) ).LE.ABS( D( MNMINNEW ) ) ) THEN TOPDWN = .TRUE. ELSE TOPDWN = .FALSE. @@ -535,7 +552,7 @@ SUBROUTINE SLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, * Scale by DMAX * TEMP = ABS( D( 1 ) ) - DO 20 I = 2, MNMIN + DO 20 I = 2, MNMINNEW TEMP = MAX( TEMP, ABS( D( I ) ) ) 20 CONTINUE * @@ -546,9 +563,19 @@ SUBROUTINE SLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, RETURN END IF * - CALL SSCAL( MNMIN, ALPHA, D, 1 ) + CALL SSCAL( MNMINNEW, ALPHA, D, 1 ) * END IF +* + IF( ISYM.EQ.3 ) THEN + DO I = MNMIN, 2*MNMINNEW + 1, -1 + D(I) = ZERO + END DO + DO I = MNMINNEW, 1, -1 + D(2*I - 1) = D(I) + D(2*I) = ZERO + END DO + END IF * * 3) Generate Banded Matrix using Givens rotations. * Also the special case of UUB=LLB=0 @@ -1008,11 +1035,17 @@ SUBROUTINE SLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, * CALL SLAGGE( MR, NC, LLB, UUB, D, A, LDA, ISEED, WORK, $ IINFO ) - ELSE + ELSEIF( ISYM.EQ.2 ) THEN * * Symmetric -- A = U D U' * CALL SLAGSY( M, LLB, D, A, LDA, ISEED, WORK, IINFO ) +* + ELSE +* +* Skew-symmetric -- A = U D U' +* + CALL SLAGKY( M, LLB, D, A, LDA, ISEED, WORK, IINFO ) * END IF IF( IINFO.NE.0 ) THEN diff --git a/TESTING/Makefile b/TESTING/Makefile index 3963260ac..24df868db 100644 --- a/TESTING/Makefile +++ b/TESTING/Makefile @@ -42,6 +42,7 @@ all: single complex double complex16 singleproto doubleproto complexproto comple SEIGTST= snep.out \ ssep.out \ + skep.out \ sse2.out \ ssvd.out \ sec.out \ @@ -50,6 +51,7 @@ SEIGTST= snep.out \ sgd.out \ ssb.out \ ssg.out \ + skg.out \ sbal.out \ sbak.out \ sgbal.out \ @@ -88,6 +90,7 @@ CDMDEIGTST= cdmd.out DEIGTST= dnep.out \ dsep.out \ + dkep.out \ dse2.out \ dsvd.out \ dec.out \ @@ -96,6 +99,7 @@ DEIGTST= dnep.out \ dgd.out \ dsb.out \ dsg.out \ + dkg.out \ dbal.out \ dbak.out \ dgbal.out \ @@ -233,6 +237,10 @@ ssep.out: sep.in EIG/xeigtsts @echo SEP: Testing Symmetric Eigenvalue Problem routines ./EIG/xeigtsts < sep.in > $@ 2>&1 +skep.out: kep.in EIG/xeigtsts + @echo KEP: Testing Skew-symmetric Eigenvalue Problem routines + ./EIG/xeigtsts < kep.in > $@ 2>&1 + sse2.out: se2.in EIG/xeigtsts @echo SEP: Testing Symmetric Eigenvalue Problem routines ./EIG/xeigtsts < se2.in > $@ 2>&1 @@ -265,6 +273,10 @@ ssg.out: ssg.in EIG/xeigtsts @echo SSG: Testing REAL Symmetric Generalized Eigenvalue Problem routines ./EIG/xeigtsts < ssg.in > $@ 2>&1 +skg.out: skg.in EIG/xeigtsts + @echo SKG: Testing REAL Skew-symmetric Generalized Eigenvalue Problem routines + ./EIG/xeigtsts < skg.in > $@ 2>&1 + sbal.out: sbal.in EIG/xeigtsts @echo SGEBAL: Testing the balancing of a REAL general matrix ./EIG/xeigtsts < sbal.in > $@ 2>&1 @@ -405,6 +417,10 @@ dsep.out: sep.in EIG/xeigtstd @echo SEP: Testing Symmetric Eigenvalue Problem routines ./EIG/xeigtstd < sep.in > $@ 2>&1 +dkep.out: kep.in EIG/xeigtstd + @echo KEP: Testing Skew-symmetric Eigenvalue Problem routines + ./EIG/xeigtstd < kep.in > $@ 2>&1 + dse2.out: se2.in EIG/xeigtstd @echo SEP: Testing Symmetric Eigenvalue Problem routines ./EIG/xeigtstd < se2.in > $@ 2>&1 @@ -437,6 +453,10 @@ dsg.out: dsg.in EIG/xeigtstd @echo DSG: Testing DOUBLE PRECISION Symmetric Generalized Eigenvalue Problem routines ./EIG/xeigtstd < dsg.in > $@ 2>&1 +dkg.out: dkg.in EIG/xeigtstd + @echo DKG: Testing DOUBLE PRECISION Skew-symmetric Generalized Eigenvalue Problem routines + ./EIG/xeigtstd < dkg.in > $@ 2>&1 + dbal.out: dbal.in EIG/xeigtstd @echo DGEBAL: Testing the balancing of a DOUBLE PRECISION general matrix ./EIG/xeigtstd < dbal.in > $@ 2>&1 diff --git a/TESTING/dkg.in b/TESTING/dkg.in new file mode 100644 index 000000000..0fcd3ccfe --- /dev/null +++ b/TESTING/dkg.in @@ -0,0 +1,13 @@ +DKG: Data file for testing Generalized Skew-symmetric Eigenvalue Problem routines +7 Number of values of N +0 1 2 3 5 10 16 Values of N (dimension) +3 Number of values of NB +1 3 20 Values of NB (blocksize) +2 2 2 Values of NBMIN (minimum blocksize) +1 1 1 Values of NX (crossover point) +20.0 Threshold value +T Put T to test the LAPACK routines +T Put T to test the driver routines +T Put T to test the error exits +1 Code to interpret the seed +DKG 21 diff --git a/TESTING/dlagky.f b/TESTING/dlagky.f new file mode 100644 index 000000000..4fafea6b5 --- /dev/null +++ b/TESTING/dlagky.f @@ -0,0 +1,261 @@ +*> \brief \b DLAGKY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DLAGKY( N, K, D, A, LDA, ISEED, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDA, N +* .. +* .. Array Arguments .. +* INTEGER ISEED( 4 ) +* DOUBLE PRECISION A( LDA, * ), D( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAGKY generates a real skew-symmetric matrix A, by pre- and post- +*> multiplying a real diagonal matrix D with a random orthogonal matrix: +*> A = U*D*U'. The semi-bandwidth may then be reduced to k by additional +*> orthogonal transformations. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of nonzero subdiagonals within the band of A. +*> 0 <= K <= N-1. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The diagonal elements of the diagonal matrix D. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The generated n by n skew-symmetric matrix A (the full matrix is +*> stored). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= N. +*> \endverbatim +*> +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry, the seed of the random number generator; the array +*> elements must be between 0 and 4095, and ISEED(4) must be +*> odd. +*> On exit, the seed is updated. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_matgen +* +* ===================================================================== + SUBROUTINE DLAGKY( N, K, D, A, LDA, ISEED, WORK, INFO ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, N +* .. +* .. Array Arguments .. + INTEGER ISEED( 4 ) + DOUBLE PRECISION A( LDA, * ), D( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION ALPHA, TAU, WA, WB, WN +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DGEMV, DGER, DLARNV, DSCAL, DKYMV, + $ DKYR2, XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DDOT, DNRM2 + EXTERNAL DDOT, DNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SIGN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( K.LT.0 .OR. K.GT.N-1 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.LT.0 ) THEN + CALL XERBLA( 'DLAGKY', -INFO ) + RETURN + END IF +* +* initialize lower triangle of A to diagonal matrix +* + DO 20 J = 1, N + DO 10 I = J, N + A( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + DO 30 I = 1, N-1 + IF (MOD(I, 2).EQ.1) THEN + A( I+1, I ) = D(I) + END IF + 30 CONTINUE +* +* Generate lower triangle of skew-symmetric matrix +* + DO 40 I = N - 1, 1, -1 +* +* generate random reflection +* + CALL DLARNV( 3, ISEED, N-I+1, WORK ) + WN = DNRM2( N-I+1, WORK, 1 ) + WA = SIGN( WN, WORK( 1 ) ) + IF( WN.EQ.ZERO ) THEN + TAU = ZERO + ELSE + WB = WORK( 1 ) + WA + CALL DSCAL( N-I, ONE / WB, WORK( 2 ), 1 ) + WORK( 1 ) = ONE + TAU = WB / WA + END IF +* +* apply random reflection to A(i:n,i:n) from the left +* and the right +* +* compute y := tau * A * u +* + CALL DKYMV( 'Lower', N-I+1, TAU, A( I, I ), LDA, WORK, 1, ZERO, + $ WORK( N+1 ), 1 ) +* +* compute v := y - 1/2 * tau * ( y, u ) * u +* + ALPHA = -HALF*TAU*DDOT( N-I+1, WORK( N+1 ), 1, WORK, 1 ) + CALL DAXPY( N-I+1, ALPHA, WORK, 1, WORK( N+1 ), 1 ) +* +* apply the transformation as a rank-2 update to A(i:n,i:n) +* + CALL DKYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1, + $ A( I, I ), LDA ) + 40 CONTINUE +* +* Reduce number of subdiagonals to K +* + DO 60 I = 1, N - 1 - K +* +* generate reflection to annihilate A(k+i+1:n,i) +* + WN = DNRM2( N-K-I+1, A( K+I, I ), 1 ) + WA = SIGN( WN, A( K+I, I ) ) + IF( WN.EQ.ZERO ) THEN + TAU = ZERO + ELSE + WB = A( K+I, I ) + WA + CALL DSCAL( N-K-I, ONE / WB, A( K+I+1, I ), 1 ) + A( K+I, I ) = ONE + TAU = WB / WA + END IF +* +* apply reflection to A(k+i:n,i+1:k+i-1) from the left +* + CALL DGEMV( 'Transpose', N-K-I+1, K-1, ONE, A( K+I, I+1 ), LDA, + $ A( K+I, I ), 1, ZERO, WORK, 1 ) + CALL DGER( N-K-I+1, K-1, -TAU, A( K+I, I ), 1, WORK, 1, + $ A( K+I, I+1 ), LDA ) +* +* apply reflection to A(k+i:n,k+i:n) from the left and the right +* +* compute y := tau * A * u +* + CALL DKYMV( 'Lower', N-K-I+1, TAU, A( K+I, K+I ), LDA, + $ A( K+I, I ), 1, ZERO, WORK, 1 ) +* +* compute v := y - 1/2 * tau * ( y, u ) * u +* + ALPHA = -HALF*TAU*DDOT( N-K-I+1, WORK, 1, A( K+I, I ), 1 ) + CALL DAXPY( N-K-I+1, ALPHA, A( K+I, I ), 1, WORK, 1 ) +* +* apply skew-symmetric rank-2 update to A(k+i:n,k+i:n) +* + CALL DKYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1, + $ A( K+I, K+I ), LDA ) +* + A( K+I, I ) = -WA + DO 50 J = K + I + 1, N + A( J, I ) = ZERO + 50 CONTINUE + 60 CONTINUE +* +* Store full skew-symmetric matrix +* + DO 80 J = 1, N + DO 70 I = J + 1, N + A( J, I ) = -A( I, J ) + 70 CONTINUE + A( J, J ) = ZERO + 80 CONTINUE + RETURN +* +* End of DLAGKY +* + END diff --git a/TESTING/dtest.in b/TESTING/dtest.in index 1b6c7bd4a..ce2fc9f8e 100644 --- a/TESTING/dtest.in +++ b/TESTING/dtest.in @@ -23,6 +23,7 @@ DPP 9 List types on next line if 0 < NTYPES < 9 DPB 8 List types on next line if 0 < NTYPES < 8 DPT 12 List types on next line if 0 < NTYPES < 12 DSY 10 List types on next line if 0 < NTYPES < 10 +DKY 10 List types on next line if 0 < NTYPES < 10 DSR 10 List types on next line if 0 < NTYPES < 10 DSK 10 List types on next line if 0 < NTYPES < 10 DSA 10 List types on next line if 0 < NTYPES < 10 diff --git a/TESTING/kep.in b/TESTING/kep.in new file mode 100644 index 000000000..91f806f00 --- /dev/null +++ b/TESTING/kep.in @@ -0,0 +1,15 @@ +KEP: Data file for testing Skew-symmetric Eigenvalue Problem routines +6 Number of values of N +0 1 2 3 5 20 Values of N (dimension) +5 Number of values of NB +1 3 3 3 10 Values of NB (blocksize) +2 2 2 2 2 Values of NBMIN (minimum blocksize) +1 0 5 9 1 Values of NX (crossover point) +50.0 Threshold value +T Put T to test the LAPACK routines +T Put T to test the driver routines +T Put T to test the error exits +1 Code to interpret the seed +KEP 20 +1 2 3 4 5 6 7 8 10 11 12 13 14 15 16 17 18 19 20 21 + diff --git a/TESTING/skg.in b/TESTING/skg.in new file mode 100644 index 000000000..8b72a0bd4 --- /dev/null +++ b/TESTING/skg.in @@ -0,0 +1,13 @@ +SKG: Data file for testing Generalized Skew-symmetric Eigenvalue Problem routines +7 Number of values of N +0 1 2 3 5 10 16 Values of N (dimension) +3 Number of values of NB +1 3 20 Values of NB (blocksize) +2 2 2 Values of NBMIN (minimum blocksize) +1 1 1 Values of NX (crossover point) +20.0 Threshold value +T Put T to test the LAPACK routines +T Put T to test the driver routines +T Put T to test the error exits +1 Code to interpret the seed +SKG 21 diff --git a/TESTING/slagky.f b/TESTING/slagky.f new file mode 100644 index 000000000..18b2e4f7e --- /dev/null +++ b/TESTING/slagky.f @@ -0,0 +1,261 @@ +*> \brief \b SLAGKY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SLAGKY( N, K, D, A, LDA, ISEED, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDA, N +* .. +* .. Array Arguments .. +* INTEGER ISEED( 4 ) +* REAL A( LDA, * ), D( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLAGKY generates a real skew-symmetric matrix A, by pre- and post- +*> multiplying a real diagonal matrix D with a random orthogonal matrix: +*> A = U*D*U'. The semi-bandwidth may then be reduced to k by additional +*> orthogonal transformations. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of nonzero subdiagonals within the band of A. +*> 0 <= K <= N-1. +*> \endverbatim +*> +*> \param[in] D +*> \verbatim +*> D is REAL array, dimension (N) +*> The diagonal elements of the diagonal matrix D. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> The generated n by n skew-symmetric matrix A (the full matrix is +*> stored). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= N. +*> \endverbatim +*> +*> \param[in,out] ISEED +*> \verbatim +*> ISEED is INTEGER array, dimension (4) +*> On entry, the seed of the random number generator; the array +*> elements must be between 0 and 4095, and ISEED(4) must be +*> odd. +*> On exit, the seed is updated. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup real_matgen +* +* ===================================================================== + SUBROUTINE SLAGKY( N, K, D, A, LDA, ISEED, WORK, INFO ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, N +* .. +* .. Array Arguments .. + INTEGER ISEED( 4 ) + REAL A( LDA, * ), D( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, HALF = 0.5E+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + REAL ALPHA, TAU, WA, WB, WN +* .. +* .. External Subroutines .. + EXTERNAL SAXPY, SGEMV, SGER, SLARNV, SSCAL, SKYMV, + $ SKYR2, XERBLA +* .. +* .. External Functions .. + REAL SDOT, SNRM2 + EXTERNAL SDOT, SNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SIGN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( K.LT.0 .OR. K.GT.N-1 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.LT.0 ) THEN + CALL XERBLA( 'SLAGKY', -INFO ) + RETURN + END IF +* +* initialize lower triangle of A to diagonal matrix +* + DO 20 J = 1, N + DO 10 I = J, N + A( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + DO 30 I = 1, N-1 + IF (MOD(I, 2).EQ.1) THEN + A( I+1, I ) = D(I) + END IF + 30 CONTINUE +* +* Generate lower triangle of skew-symmetric matrix +* + DO 40 I = N - 1, 1, -1 +* +* generate random reflection +* + CALL SLARNV( 3, ISEED, N-I+1, WORK ) + WN = SNRM2( N-I+1, WORK, 1 ) + WA = SIGN( WN, WORK( 1 ) ) + IF( WN.EQ.ZERO ) THEN + TAU = ZERO + ELSE + WB = WORK( 1 ) + WA + CALL SSCAL( N-I, ONE / WB, WORK( 2 ), 1 ) + WORK( 1 ) = ONE + TAU = WB / WA + END IF +* +* apply random reflection to A(i:n,i:n) from the left +* and the right +* +* compute y := tau * A * u +* + CALL SKYMV( 'Lower', N-I+1, TAU, A( I, I ), LDA, WORK, 1, ZERO, + $ WORK( N+1 ), 1 ) +* +* compute v := y - 1/2 * tau * ( y, u ) * u +* + ALPHA = -HALF*TAU*SDOT( N-I+1, WORK( N+1 ), 1, WORK, 1 ) + CALL SAXPY( N-I+1, ALPHA, WORK, 1, WORK( N+1 ), 1 ) +* +* apply the transformation as a rank-2 update to A(i:n,i:n) +* + CALL SKYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1, + $ A( I, I ), LDA ) + 40 CONTINUE +* +* Reduce number of subdiagonals to K +* + DO 60 I = 1, N - 1 - K +* +* generate reflection to annihilate A(k+i+1:n,i) +* + WN = SNRM2( N-K-I+1, A( K+I, I ), 1 ) + WA = SIGN( WN, A( K+I, I ) ) + IF( WN.EQ.ZERO ) THEN + TAU = ZERO + ELSE + WB = A( K+I, I ) + WA + CALL SSCAL( N-K-I, ONE / WB, A( K+I+1, I ), 1 ) + A( K+I, I ) = ONE + TAU = WB / WA + END IF +* +* apply reflection to A(k+i:n,i+1:k+i-1) from the left +* + CALL SGEMV( 'Transpose', N-K-I+1, K-1, ONE, A( K+I, I+1 ), LDA, + $ A( K+I, I ), 1, ZERO, WORK, 1 ) + CALL SGER( N-K-I+1, K-1, -TAU, A( K+I, I ), 1, WORK, 1, + $ A( K+I, I+1 ), LDA ) +* +* apply reflection to A(k+i:n,k+i:n) from the left and the right +* +* compute y := tau * A * u +* + CALL SKYMV( 'Lower', N-K-I+1, TAU, A( K+I, K+I ), LDA, + $ A( K+I, I ), 1, ZERO, WORK, 1 ) +* +* compute v := y - 1/2 * tau * ( y, u ) * u +* + ALPHA = -HALF*TAU*SDOT( N-K-I+1, WORK, 1, A( K+I, I ), 1 ) + CALL SAXPY( N-K-I+1, ALPHA, A( K+I, I ), 1, WORK, 1 ) +* +* apply skew-symmetric rank-2 update to A(k+i:n,k+i:n) +* + CALL SKYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1, + $ A( K+I, K+I ), LDA ) +* + A( K+I, I ) = -WA + DO 50 J = K + I + 1, N + A( J, I ) = ZERO + 50 CONTINUE + 60 CONTINUE +* +* Store full skew-symmetric matrix +* + DO 80 J = 1, N + DO 70 I = J + 1, N + A( J, I ) = -A( I, J ) + 70 CONTINUE + A( J, J ) = ZERO + 80 CONTINUE + RETURN +* +* End of SLAGKY +* + END diff --git a/TESTING/stest.in b/TESTING/stest.in index 7faa8b7a1..4e4579837 100644 --- a/TESTING/stest.in +++ b/TESTING/stest.in @@ -23,6 +23,7 @@ SPP 9 List types on next line if 0 < NTYPES < 9 SPB 8 List types on next line if 0 < NTYPES < 8 SPT 12 List types on next line if 0 < NTYPES < 12 SSY 10 List types on next line if 0 < NTYPES < 10 +SKY 10 List types on next line if 0 < NTYPES < 10 SSR 10 List types on next line if 0 < NTYPES < 10 SSK 10 List types on next line if 0 < NTYPES < 10 SSA 10 List types on next line if 0 < NTYPES < 10 diff --git a/lapack_testing.py b/lapack_testing.py index dc3c471b5..6a35cdceb 100755 --- a/lapack_testing.py +++ b/lapack_testing.py @@ -224,21 +224,21 @@ def run_summary_test( f, cmdline, short_summary): sys.stdout.flush() dtests = ( - ("nep", "sep", "se2", "svd", + ("nep", "sep", "kep", "se2", "svd", letter+"ec",letter+"ed",letter+"gg", - letter+"gd",letter+"sb",letter+"sg", + letter+"gd",letter+"sb",letter+"sg",letter+"kg", letter+"bb","glm","gqr", "gsv","csd","lse", letter+"test", letter+dtypes[0][dtype-1]+"test",letter+"test_rfp",letter+"dmd"), - ("Nonsymmetric-Eigenvalue-Problem", "Symmetric-Eigenvalue-Problem", "Symmetric-Eigenvalue-Problem-2-stage", "Singular-Value-Decomposition", + ("Nonsymmetric-Eigenvalue-Problem", "Symmetric-Eigenvalue-Problem", "Skew-symmetric-Eigenvalue-Problem", "Symmetric-Eigenvalue-Problem-2-stage", "Singular-Value-Decomposition", "Eigen-Condition","Nonsymmetric-Eigenvalue","Nonsymmetric-Generalized-Eigenvalue-Problem", - "Nonsymmetric-Generalized-Eigenvalue-Problem-driver", "Symmetric-Eigenvalue-Problem", "Symmetric-Eigenvalue-Generalized-Problem", + "Nonsymmetric-Generalized-Eigenvalue-Problem-driver", "Symmetric-Eigenvalue-Problem", "Symmetric-Eigenvalue-Generalized-Problem", "Skew-symmetric-Eigenvalue-Generalized-Problem", "Banded-Singular-Value-Decomposition-routines", "Generalized-Linear-Regression-Model-routines", "Generalized-QR-and-RQ-factorization-routines", "Generalized-Singular-Value-Decomposition-routines", "CS-Decomposition-routines", "Constrained-Linear-Least-Squares-routines", "Linear-Equation-routines", "Mixed-Precision-linear-equation-routines","RFP-linear-equation-routines","Dynamic-Mode-Decomposition"), - (letter+"nep", letter+"sep", letter+"se2", letter+"svd", + (letter+"nep", letter+"sep", letter+"kep", letter+"se2", letter+"svd", letter+"ec",letter+"ed",letter+"gg", - letter+"gd",letter+"sb",letter+"sg", + letter+"gd",letter+"sb",letter+"sg",letter+"kg", letter+"bb",letter+"glm",letter+"gqr", letter+"gsv",letter+"csd",letter+"lse", letter+"test", letter+dtypes[0][dtype-1]+"test",letter+"test_rfp",letter+"dmd"), @@ -248,21 +248,24 @@ def run_summary_test( f, cmdline, short_summary): for dtest in range_test: nb_of_test=0 # NEED TO SKIP SOME PRECISION (namely s and c) FOR PROTO MIXED PRECISION TESTING - if dtest==17 and (letter=="s" or letter=="c"): + if dtest==19 and (letter=="s" or letter=="c"): + continue + # NEED TO SKIP COMPLEX SUBROUTINE (namely c and z) FOR SKEW-SYMMETRIC TESTING + if (dtest==2 or dtest==11) and (letter=="c" or letter=="z"): continue if with_file: cmdbase=dtests[2][dtest]+".out" else: - if dtest==16: + if dtest==18: # LIN TESTS cmdbase="xlintst"+letter+" < "+dtests[0][dtest]+".in > "+dtests[2][dtest]+".out" - elif dtest==17: + elif dtest==19: # PROTO LIN TESTS cmdbase="xlintst"+letter+dtypes[0][dtype-1]+" < "+dtests[0][dtest]+".in > "+dtests[2][dtest]+".out" - elif dtest==18: + elif dtest==20: # PROTO LIN TESTS cmdbase="xlintstrf"+letter+" < "+dtests[0][dtest]+".in > "+dtests[2][dtest]+".out" - elif dtest==20: + elif dtest==21: # DMD EIG TESTS cmdbase="xdmdeigtst"+letter+" < "+dtests[0][dtest]+".in > "+dtests[2][dtest]+".out" else: