From a50de3c8cc87505adbfdb759def537a44da129a3 Mon Sep 17 00:00:00 2001 From: Julie Date: Sun, 9 Oct 2016 10:07:56 -0700 Subject: [PATCH] Adding Assen for SV, TRF, SV from @iyamazak@icl.utk.edu Contribution by Ichitaro Yamazaki, University of Tennessee Note: need to add corresponding LAPACKE routines --- SRC/CMakeLists.txt | 12 +- SRC/Makefile | 4 + SRC/chesv_aasen.f | 251 ++++++++++++++++++++ SRC/chetrf_aasen.f | 485 +++++++++++++++++++++++++++++++++++++ SRC/chetrs_aasen.f | 292 +++++++++++++++++++++++ SRC/clahef_aasen.f | 515 ++++++++++++++++++++++++++++++++++++++++ SRC/dlasyf_aasen.f | 508 +++++++++++++++++++++++++++++++++++++++ SRC/dsysv_aasen.f | 249 +++++++++++++++++++ SRC/dsytrf_aasen.f | 482 +++++++++++++++++++++++++++++++++++++ SRC/dsytrs_aasen.f | 282 ++++++++++++++++++++++ SRC/slasyf_aasen.f | 508 +++++++++++++++++++++++++++++++++++++++ SRC/ssysv_aasen.f | 249 +++++++++++++++++++ SRC/ssytrf_aasen.f | 482 +++++++++++++++++++++++++++++++++++++ SRC/ssytrs_aasen.f | 291 +++++++++++++++++++++++ SRC/zhesv_aasen.f | 251 ++++++++++++++++++++ SRC/zhetrf_aasen.f | 485 +++++++++++++++++++++++++++++++++++++ SRC/zhetrs_aasen.f | 284 ++++++++++++++++++++++ SRC/zlahef_aasen.f | 515 ++++++++++++++++++++++++++++++++++++++++ TESTING/LIN/CMakeLists.txt | 24 +- TESTING/LIN/Makefile | 24 +- TESTING/LIN/aladhd.f | 26 +- TESTING/LIN/alaerh.f | 3 + TESTING/LIN/alahd.f | 24 ++ TESTING/LIN/cchkaa.f | 36 ++- TESTING/LIN/cchkhe_aasen.f | 578 ++++++++++++++++++++++++++++++++++++++++++++ TESTING/LIN/cdrvhe_aasen.f | 529 +++++++++++++++++++++++++++++++++++++++++ TESTING/LIN/cerrvx.f | 21 +- TESTING/LIN/chet01_aasen.f | 267 +++++++++++++++++++++ TESTING/LIN/dchkaa.f | 29 +++ TESTING/LIN/dchksy_aasen.f | 577 ++++++++++++++++++++++++++++++++++++++++++++ TESTING/LIN/ddrvsy_aasen.f | 517 ++++++++++++++++++++++++++++++++++++++++ TESTING/LIN/derrvx.f | 21 +- TESTING/LIN/dsyt01_aasen.f | 263 ++++++++++++++++++++ TESTING/LIN/schkaa.f | 27 +++ TESTING/LIN/schksy_aasen.f | 578 ++++++++++++++++++++++++++++++++++++++++++++ TESTING/LIN/sdrvsy_aasen.f | 517 ++++++++++++++++++++++++++++++++++++++++ TESTING/LIN/serrvx.f | 20 +- TESTING/LIN/ssyt01_aasen.f | 262 ++++++++++++++++++++ TESTING/LIN/zchkaa.f | 34 ++- TESTING/LIN/zchkhe_aasen.f | 579 +++++++++++++++++++++++++++++++++++++++++++++ TESTING/LIN/zdrvhe_aasen.f | 525 ++++++++++++++++++++++++++++++++++++++++ TESTING/LIN/zerrvx.f | 21 +- TESTING/LIN/zhet01_aasen.f | 267 +++++++++++++++++++++ TESTING/ctest.in | 1 + TESTING/dtest.in | 1 + TESTING/stest.in | 1 + TESTING/ztest.in | 1 + 47 files changed, 11877 insertions(+), 41 deletions(-) create mode 100644 SRC/chesv_aasen.f create mode 100644 SRC/chetrf_aasen.f create mode 100644 SRC/chetrs_aasen.f create mode 100644 SRC/clahef_aasen.f create mode 100644 SRC/dlasyf_aasen.f create mode 100644 SRC/dsysv_aasen.f create mode 100644 SRC/dsytrf_aasen.f create mode 100644 SRC/dsytrs_aasen.f create mode 100644 SRC/slasyf_aasen.f create mode 100644 SRC/ssysv_aasen.f create mode 100644 SRC/ssytrf_aasen.f create mode 100644 SRC/ssytrs_aasen.f create mode 100644 SRC/zhesv_aasen.f create mode 100644 SRC/zhetrf_aasen.f create mode 100644 SRC/zhetrs_aasen.f create mode 100644 SRC/zlahef_aasen.f create mode 100644 TESTING/LIN/cchkhe_aasen.f create mode 100644 TESTING/LIN/cdrvhe_aasen.f create mode 100644 TESTING/LIN/chet01_aasen.f create mode 100644 TESTING/LIN/dchksy_aasen.f create mode 100644 TESTING/LIN/ddrvsy_aasen.f create mode 100644 TESTING/LIN/dsyt01_aasen.f create mode 100644 TESTING/LIN/schksy_aasen.f create mode 100644 TESTING/LIN/sdrvsy_aasen.f create mode 100644 TESTING/LIN/ssyt01_aasen.f create mode 100644 TESTING/LIN/zchkhe_aasen.f create mode 100644 TESTING/LIN/zdrvhe_aasen.f create mode 100644 TESTING/LIN/zhet01_aasen.f diff --git a/SRC/CMakeLists.txt b/SRC/CMakeLists.txt index b80deab..4459a6f 100644 --- a/SRC/CMakeLists.txt +++ b/SRC/CMakeLists.txt @@ -114,7 +114,7 @@ set(SLASRC slaqtr.f slar1v.f slar2v.f ilaslr.f ilaslc.f slarf.f slarfb.f slarfg.f slarfgp.f slarft.f slarfx.f slargv.f slarrv.f slartv.f - slarz.f slarzb.f slarzt.f slaswp.f slasy2.f slasyf.f slasyf_rook.f + slarz.f slarzb.f slarzt.f slaswp.f slasy2.f slasyf.f slasyf_rook.f slasyf_aasen.f slatbs.f slatdf.f slatps.f slatrd.f slatrs.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 @@ -135,6 +135,7 @@ set(SLASRC ssygst.f ssygv.f ssygvd.f ssygvx.f ssyrfs.f ssysv.f ssysvx.f ssytd2.f ssytf2.f ssytrd.f ssytrf.f ssytri.f ssytri2.f ssytri2x.f ssyswapr.f ssytrs.f ssytrs2.f ssyconv.f + ssysv_aasen.f ssytrf_aasen.f ssytrs_aasen.f ssytf2_rook.f ssytrf_rook.f ssytrs_rook.f ssytri_rook.f ssycon_rook.f ssysv_rook.f stbcon.f @@ -185,6 +186,7 @@ set(CLASRC chetf2.f chetrd.f chetrf.f chetri.f chetri2.f chetri2x.f cheswapr.f chetrs.f chetrs2.f + chesv_aasen.f chetrf_aasen.f chetrs_aasen.f chetf2_rook.f chetrf_rook.f chetri_rook.f chetrs_rook.f checon_rook.f chesv_rook.f chgeqz.f chpcon.f chpev.f chpevd.f chpevx.f chpgst.f chpgv.f chpgvd.f chpgvx.f chprfs.f chpsv.f @@ -193,7 +195,7 @@ set(CLASRC clacgv.f clacon.f clacn2.f clacp2.f clacpy.f clacrm.f clacrt.f cladiv.f claed0.f claed7.f claed8.f claein.f claesy.f claev2.f clags2.f clagtm.f - clahef.f clahef_rook.f clahqr.f + clahef.f clahef_rook.f clahef_aasen.f clahqr.f clahr2.f claic1.f clals0.f clalsa.f clalsd.f clangb.f clange.f clangt.f clanhb.f clanhe.f clanhp.f clanhs.f clanht.f clansb.f clansp.f clansy.f clantb.f @@ -274,7 +276,7 @@ set(DLASRC dlaqtr.f dlar1v.f dlar2v.f iladlr.f iladlc.f dlarf.f dlarfb.f dlarfg.f dlarfgp.f dlarft.f dlarfx.f dlargv.f dlarrv.f dlartv.f - dlarz.f dlarzb.f dlarzt.f dlaswp.f dlasy2.f dlasyf.f dlasyf_rook.f + dlarz.f dlarzb.f dlarzt.f dlaswp.f dlasy2.f dlasyf.f dlasyf_rook.f dlasyf_aasen.f dlatbs.f dlatdf.f dlatps.f dlatrd.f dlatrs.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 @@ -296,6 +298,7 @@ set(DLASRC dsysv.f dsysvx.f dsytd2.f dsytf2.f dsytrd.f dsytrf.f dsytri.f dsytrs.f dsytrs2.f dsytri2.f dsytri2x.f dsyswapr.f dsyconv.f + dsysv_aasen.f dsytrf_aasen.f dsytrs_aasen.f dsytf2_rook.f dsytrf_rook.f dsytrs_rook.f dsytri_rook.f dsycon_rook.f dsysv_rook.f dtbcon.f @@ -344,6 +347,7 @@ set(ZLASRC zhetf2.f zhetrd.f zhetrf.f zhetri.f zhetri2.f zhetri2x.f zheswapr.f zhetrs.f zhetrs2.f + zhesv_aasen.f zhetrf_aasen.f zhetrs_aasen.f zhetf2_rook.f zhetrf_rook.f zhetri_rook.f zhetrs_rook.f zhecon_rook.f zhesv_rook.f zhgeqz.f zhpcon.f zhpev.f zhpevd.f zhpevx.f zhpgst.f zhpgv.f zhpgvd.f zhpgvx.f zhprfs.f zhpsv.f @@ -352,7 +356,7 @@ set(ZLASRC zlacgv.f zlacon.f zlacn2.f zlacp2.f zlacpy.f zlacrm.f zlacrt.f zladiv.f zlaed0.f zlaed7.f zlaed8.f zlaein.f zlaesy.f zlaev2.f zlags2.f zlagtm.f - zlahef.f zlahef_rook.f zlahqr.f + zlahef.f zlahef_rook.f zlahef_aasen.f zlahqr.f zlahr2.f zlaic1.f zlals0.f zlalsa.f zlalsd.f zlangb.f zlange.f zlangt.f zlanhb.f zlanhe.f diff --git a/SRC/Makefile b/SRC/Makefile index a30da01..b8d4323 100644 --- a/SRC/Makefile +++ b/SRC/Makefile @@ -145,6 +145,7 @@ SLASRC = \ ssytd2.o ssytf2.o ssytrd.o ssytrf.o ssytri.o ssytri2.o ssytri2x.o \ ssyswapr.o ssytrs.o ssytrs2.o ssyconv.o \ ssytf2_rook.o ssytrf_rook.o ssytrs_rook.o \ + slasyf_aasen.o ssysv_aasen.o ssytrf_aasen.o ssytrs_aasen.o \ ssytri_rook.o ssycon_rook.o ssysv_rook.o \ stbcon.o \ stbrfs.o stbtrs.o stgevc.o stgex2.o stgexc.o stgsen.o \ @@ -196,6 +197,7 @@ CLASRC = \ chetrf.o chetri.o chetri2.o chetri2x.o cheswapr.o \ chetrs.o chetrs2.o \ chetf2_rook.o chetrf_rook.o chetri_rook.o chetrs_rook.o checon_rook.o chesv_rook.o \ + chesv_aasen.o chetrf_aasen.o chetrs_aasen.o clahef_aasen.o\ chgeqz.o chpcon.o chpev.o chpevd.o \ chpevx.o chpgst.o chpgv.o chpgvd.o chpgvx.o chprfs.o chpsv.o \ chpsvx.o \ @@ -312,6 +314,7 @@ DLASRC = \ dsytd2.o dsytf2.o dsytrd.o dsytrf.o dsytri.o dsytri2.o dsytri2x.o \ dsyswapr.o dsytrs.o dsytrs2.o dsyconv.o \ dsytf2_rook.o dsytrf_rook.o dsytrs_rook.o \ + dlasyf_aasen.o dsysv_aasen.o dsytrf_aasen.o dsytrs_aasen.o \ dsytri_rook.o dsycon_rook.o dsysv_rook.o \ dtbcon.o dtbrfs.o dtbtrs.o dtgevc.o dtgex2.o dtgexc.o dtgsen.o \ dtgsja.o dtgsna.o dtgsy2.o dtgsyl.o dtpcon.o dtprfs.o dtptri.o \ @@ -362,6 +365,7 @@ ZLASRC = \ zhetrf.o zhetri.o zhetri2.o zhetri2x.o zheswapr.o \ zhetrs.o zhetrs2.o \ zhetf2_rook.o zhetrf_rook.o zhetri_rook.o zhetrs_rook.o zhecon_rook.o zhesv_rook.o \ + zhesv_aasen.o zhetrf_aasen.o zhetrs_aasen.o zlahef_aasen.o \ zhgeqz.o zhpcon.o zhpev.o zhpevd.o \ zhpevx.o zhpgst.o zhpgv.o zhpgvd.o zhpgvx.o zhprfs.o zhpsv.o \ zhpsvx.o \ diff --git a/SRC/chesv_aasen.f b/SRC/chesv_aasen.f new file mode 100644 index 0000000..e5d1cb6 --- /dev/null +++ b/SRC/chesv_aasen.f @@ -0,0 +1,251 @@ +*> \brief CHESV_AASEN computes the solution to system of linear equations A * X = B for HE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHESV_AASEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHESV_AASEN( 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( * ) +* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHESV_AASEN computes the solution to a complex system of linear equations +*> A * X = B, +*> where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS +*> matrices. +*> +*> Aasen's algorithm is used to factor A as +*> A = U * T * U**H, if UPLO = 'U', or +*> A = L * T * L**H, if UPLO = 'L', +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and T is Hermitian and tridiagonal. 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 COMPLEX array, dimension (LDA,N) +*> On entry, the Hermitian 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. +*> +*> On exit, if INFO = 0, the tridiagonal matrix T and the +*> multipliers used to obtain the factor U or L from the +*> factorization A = U*T*U**H or A = L*T*L**H as computed by +*> CHETRF_AASEN. +*> \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) +*> On exit, it contains the details of the interchanges, i.e., +*> the row and column k of A were interchanged with the +*> row and column IPIV(k). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX 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 COMPLEX 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 +*> CHETRF. +*> 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,i) 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. +* +*> \date November 2016 +* +*> \ingroup complexHEsolve +* +* @generated from zhesv_aasen.f, fortran z -> c, Mon Oct 3 01:48:05 2016 +* +* ===================================================================== + SUBROUTINE CHESV_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CHETRF, CHETRS, CHETRS2 +* .. +* .. 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.MAX(2*N, 3*N-2) .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF +* + IF( INFO.EQ.0 ) THEN + NB = ILAENV( 1, 'CHETRF_AASEN', UPLO, N, -1, -1, -1 ) + LWKOPT = MAX( 3*N-2, (1+NB)*N ) + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHESV_AASEN ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = U*T*U**H or A = L*T*L**H. +* + CALL CHETRF_AASEN( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* + CALL CHETRS_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of CHESV_AASEN +* + END diff --git a/SRC/chetrf_aasen.f b/SRC/chetrf_aasen.f new file mode 100644 index 0000000..deb0b64 --- /dev/null +++ b/SRC/chetrf_aasen.f @@ -0,0 +1,485 @@ +*> \brief \b CHETRF_AASEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHETRF_AASEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHETRF_AASEN( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, LDA, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), WORK( * ) +* .. +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHETRF_AASEN computes the factorization of a real hermitian matrix A +*> using the Aasen's algorithm. The form of the factorization is +*> +*> A = U*T*U**T or A = L*T*L**T +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and T is a hermitian tridiagonal matrix. +*> +*> 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 COMPLEX array, dimension (LDA,N) +*> On entry, the hermitian 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. +*> +*> On exit, the tridiagonal matrix is stored in the diagonals +*> and the subdiagonals of A just below (or above) the diagonals, +*> and L is stored below (or above) the subdiaonals, when UPLO +*> is 'L' (or 'U'). +*> \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) +*> On exit, it contains the details of the interchanges, i.e., +*> the row and column k of A were interchanged with the +*> row and column IPIV(k). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX 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 >= 2*N. For optimum performance +*> LWORK >= N*(1+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 +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2016 +* +*> \ingroup complexSYcomputational +* +* @generated from zhetrf_aasen.f, fortran z -> c, Sun Oct 2 22:29:10 2016 +* +* ===================================================================== + SUBROUTINE CHETRF_AASEN( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, LDA, LWORK, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* .. Parameters .. + COMPLEX ZERO, ONE + PARAMETER ( ZERO = (0.0E+0, 0.0E+0), ONE = (1.0E+0, 0.0E+0) ) +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER J, LWKOPT, IINFO + INTEGER NB, MJ, NJ, K1, K2, J1, J2, J3, JB + COMPLEX ALPHA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, CONJG, MAX +* .. +* .. Executable Statements .. +* +* Determine the block size +* + NB = ILAENV( 1, 'CHETRF', UPLO, N, -1, -1, -1 ) +* +* 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.( 2*N ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN + LWKOPT = (NB+1)*N + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHETRF_AASEN', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return +* + IF ( N.EQ.0 ) THEN + RETURN + ENDIF + IPIV( 1 ) = 1 + IF ( N.EQ.1 ) THEN + A( 1, 1 ) = REAL( A( 1, 1 ) ) + IF ( A( 1, 1 ).EQ.ZERO ) THEN + INFO = 1 + END IF + RETURN + END IF +* +* Adjubst block size based on the workspace size +* + IF( LWORK.LT.((1+NB)*N) ) THEN + NB = ( LWORK-N ) / N + END IF +* + IF( UPPER ) THEN +* +* ..................................................... +* Factorize A as L*D*L**T using the upper triangle of A +* ..................................................... +* +* copy first row A(1, 1:N) into H(1:n) (stored in WORK(1:N)) +* + CALL CCOPY( N, A( 1, 1 ), LDA, WORK( 1 ), 1 ) +* +* J is the main loop index, increasing from 1 to N in steps of +* JB, where JB is the number of columns factorized by CLAHEF; +* JB is either NB, or N-J+1 for the last block +* + J = 0 + 10 CONTINUE + IF( J.GE.N ) + $ GO TO 20 +* +* each step of the main loop +* J is the last column of the previous panel +* J1 is the first column of the current panel +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 for the first panel, and +* K1=0 for the rest +* + J1 = J + 1 + JB = MIN( N-J1+1, NB ) + K1 = MAX(1, J)-J +* +* Panel factorization +* + CALL CLAHEF_AASEN( UPLO, 2-K1, N-J, JB, + $ A( MAX(1, J), J+1 ), LDA, + $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), + $ IINFO ) + IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN + INFO = IINFO+J + ENDIF +* +* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot) +* + DO J2 = J+2, MIN(N, J+JB+1) + IPIV( J2 ) = IPIV( J2 ) + J + IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN + CALL CSWAP( J1-K1-2, A( 1, J2 ), 1, + $ A( 1, IPIV(J2) ), 1 ) + END IF + END DO + J = J + JB +* +* Trailing submatrix update, where +* the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and +* WORK stores the current block of the auxiriarly matrix H +* + IF( J.LT.N ) THEN +* +* if the first panel and JB=1 (NB=1), then nothing to do +* + IF( J1.GT.1 .OR. JB.GT.1 ) THEN +* +* Merge rank-1 update with BLAS-3 update +* + ALPHA = CONJG( A( J, J+1 ) ) + A( J, J+1 ) = ONE + CALL CCOPY( N-J, A( J-1, J+1 ), LDA, + $ WORK( (J+1-J1+1)+JB*N ), 1 ) + CALL CSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 ) +* +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=0 and K2=1 for the first panel, +* and K1=1 and K2=0 for the rest +* + IF( J1.GT.1 ) THEN +* +* Not first panel +* + K2 = 1 + ELSE +* +* First panel +* + K2 = 0 +* +* First update skips the first column +* + JB = JB - 1 + END IF +* + DO J2 = J+1, N, NB + NJ = MIN( NB, N-J2+1 ) +* +* Update (J2, J2) diagonal block with CGEMV +* + J3 = J2 + DO MJ = NJ-1, 1, -1 + CALL CGEMM( 'Conjugate transpose', 'Transpose', + $ 1, MJ, JB+1, + $ -ONE, A( J1-K2, J3 ), LDA, + $ WORK( (J3-J1+1)+K1*N ), N, + $ ONE, A( J3, J3 ), LDA ) + J3 = J3 + 1 + END DO +* +* Update off-diagonal block of J2-th block row with CGEMM +* + CALL CGEMM( 'Conjugate transpose', 'Transpose', + $ NJ, N-J3+1, JB+1, + $ -ONE, A( J1-K2, J2 ), LDA, + $ WORK( (J3-J1+1)+K1*N ), N, + $ ONE, A( J2, J3 ), LDA ) + END DO +* +* Recover T( J, J+1 ) +* + A( J, J+1 ) = CONJG( ALPHA ) + END IF +* +* WORK(J+1, 1) stores H(J+1, 1) +* + CALL CCOPY( N-J, A( J+1, J+1 ), LDA, WORK( 1 ), 1 ) + END IF + GO TO 10 + ELSE +* +* ..................................................... +* Factorize A as L*D*L**T using the lower triangle of A +* ..................................................... +* +* copy first column A(1:N, 1) into H(1:N, 1) +* (stored in WORK(1:N)) +* + CALL CCOPY( N, A( 1, 1 ), 1, WORK( 1 ), 1 ) +* +* J is the main loop index, increasing from 1 to N in steps of +* JB, where JB is the number of columns factorized by CLAHEF; +* JB is either NB, or N-J+1 for the last block +* + J = 0 + 11 CONTINUE + IF( J.GE.N ) + $ GO TO 20 +* +* each step of the main loop +* J is the last column of the previous panel +* J1 is the first column of the current panel +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 for the first panel, and +* K1=0 for the rest +* + J1 = J+1 + JB = MIN( N-J1+1, NB ) + K1 = MAX(1, J)-J +* +* Panel factorization +* + CALL CLAHEF_AASEN( UPLO, 2-K1, N-J, JB, + $ A( J+1, MAX(1, J) ), LDA, + $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), IINFO) + IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN + INFO = IINFO+J + ENDIF +* +* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot) +* + DO J2 = J+2, MIN(N, J+JB+1) + IPIV( J2 ) = IPIV( J2 ) + J + IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN + CALL CSWAP( J1-K1-2, A( J2, 1 ), LDA, + $ A( IPIV(J2), 1 ), LDA ) + END IF + END DO + J = J + JB +* +* Trailing submatrix update, where +* A(J2+1, J1-1) stores L(J2+1, J1) and +* WORK(J2+1, 1) stores H(J2+1, 1) +* + IF( J.LT.N ) THEN +* +* if the first panel and JB=1 (NB=1), then nothing to do +* + IF( J1.GT.1 .OR. JB.GT.1 ) THEN +* +* Merge rank-1 update with BLAS-3 update +* + ALPHA = CONJG( A( J+1, J ) ) + A( J+1, J ) = ONE + CALL CCOPY( N-J, A( J+1, J-1 ), 1, + $ WORK( (J+1-J1+1)+JB*N ), 1 ) + CALL CSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 ) +* +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=0 and K2=1 for the first panel, +* and K1=1 and K2=0 for the rest +* + IF( J1.GT.1 ) THEN +* +* Not first panel +* + K2 = 1 + ELSE +* +* First panel +* + K2 = 0 +* +* First update skips the first column +* + JB = JB - 1 + END IF +* + DO J2 = J+1, N, NB + NJ = MIN( NB, N-J2+1 ) +* +* Update (J2, J2) diagonal block with CGEMV +* + J3 = J2 + DO MJ = NJ-1, 1, -1 + CALL CGEMM( 'No transpose', 'Conjugate transpose', + $ MJ, 1, JB+1, + $ -ONE, WORK( (J3-J1+1)+K1*N ), N, + $ A( J3, J1-K2 ), LDA, + $ ONE, A( J3, J3 ), LDA ) + J3 = J3 + 1 + END DO +* +* Update off-diagonal block of J2-th block column with CGEMM +* + CALL CGEMM( 'No transpose', 'Conjugate transpose', + $ N-J3+1, NJ, JB+1, + $ -ONE, WORK( (J3-J1+1)+K1*N ), N, + $ A( J2, J1-K2 ), LDA, + $ ONE, A( J3, J2 ), LDA ) + END DO +* +* Recover T( J+1, J ) +* + A( J+1, J ) = CONJG( ALPHA ) + END IF +* +* WORK(J+1, 1) stores H(J+1, 1) +* + CALL CCOPY( N-J, A( J+1, J+1 ), 1, WORK( 1 ), 1 ) + END IF + GO TO 11 + END IF +* + 20 CONTINUE + RETURN +* +* End of CHETRF_AASEN +* + END diff --git a/SRC/chetrs_aasen.f b/SRC/chetrs_aasen.f new file mode 100644 index 0000000..629084e --- /dev/null +++ b/SRC/chetrs_aasen.f @@ -0,0 +1,292 @@ +*> \brief \b CHETRS_AASEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CHETRS_AASEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CHETRS_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHETRS_AASEN solves a system of linear equations A*X = B with a real +*> hermitian matrix A using the factorization A = U*T*U**T or +*> A = L*T*L**T computed by CHETRF_AASEN. +*> \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*T*U**T; +*> = 'L': Lower triangular, form is A = L*T*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 COMPLEX array, dimension (LDA,N) +*> Details of factors computed by CHETRF_AASEN. +*> \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 as computed by CHETRF_AASEN. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX 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[in] WORK +*> \verbatim +*> WORK is DOUBLE array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER, LWORK >= 3*N-2. +*> +*> \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. +* +*> \date November 2016 +* +*> \ingroup complexSYcomputational +* +* @generated from zhetrs_aasen.f, fortran z -> c, Fri Sep 23 00:09:52 2016 +* +* ===================================================================== + SUBROUTINE CHETRS_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* + COMPLEX ONE + PARAMETER ( ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER K, KP +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CGTSV, CSWAP, CTRSM, 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 + ELSE IF( LWORK.LT.(3*N-2) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHETRS_AASEN', -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*T*U**T. +* +* P**T * B +* + K = 1 + DO WHILE ( K.LE.N ) + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K + 1 + END DO +* +* Compute (U \P**T * B) -> B [ (U \P**T * B) ] +* + CALL CTRSM('L', 'U', 'C', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA, + $ B( 2, 1 ), LDB) +* +* Compute T \ B -> B [ T \ (U \P**T * B) ] +* + CALL CLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1) + IF( N.GT.1 ) THEN + CALL CLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 2*N ), 1) + CALL CLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 1 ), 1) + CALL CLACGV( N-1, WORK( 1 ), 1 ) + END IF + CALL CGTSV(N, NRHS, WORK(1), WORK(N), WORK(2*N), B, LDB, + $ INFO) +* +* Compute (U**T \ B) -> B [ U**T \ (T \ (U \P**T * B) ) ] +* + CALL CTRSM( 'L', 'U', 'N', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA, + $ B(2, 1), LDB) +* +* Pivot, P * B [ P * (U**T \ (T \ (U \P**T * B) )) ] +* + K = N + DO WHILE ( K.GE.1 ) + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K - 1 + END DO +* + ELSE +* +* Solve A*X = B, where A = L*T*L**T. +* +* Pivot, P**T * B +* + K = 1 + DO WHILE ( K.LE.N ) + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K + 1 + END DO +* +* Compute (L \P**T * B) -> B [ (L \P**T * B) ] +* + CALL CTRSM( 'L', 'L', 'N', 'U', N-1, NRHS, ONE, A( 2, 1), LDA, + $ B(2, 1), LDB) +* +* Compute T \ B -> B [ T \ (L \P**T * B) ] +* + CALL CLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1) + IF( N.GT.1 ) THEN + CALL CLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 1 ), 1) + CALL CLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 2*N ), 1) + CALL CLACGV( N-1, WORK( 2*N ), 1 ) + END IF + CALL CGTSV(N, NRHS, WORK(1), WORK(N), WORK(2*N), B, LDB, + $ INFO) +* +* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ] +* + CALL CTRSM( 'L', 'L', 'C', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA, + $ B( 2, 1 ), LDB) +* +* Pivot, P * B [ P * (L**T \ (T \ (L \P**T * B) )) ] +* + K = N + DO WHILE ( K.GE.1 ) + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K - 1 + END DO +* + END IF +* + RETURN +* +* End of CHETRS_AASEN +* + END diff --git a/SRC/clahef_aasen.f b/SRC/clahef_aasen.f new file mode 100644 index 0000000..f79c8b7 --- /dev/null +++ b/SRC/clahef_aasen.f @@ -0,0 +1,515 @@ +*> \brief \b CLAHEF_AASEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CLAHEF_AASEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CLAHEF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV, +* H, LDH, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER J1, M, NB, LDA, LDH, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), H( LDH, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLATRF_AASEN factorizes a panel of a real hermitian matrix A using +*> the Aasen's algorithm. The panel consists of a set of NB rows of A +*> when UPLO is U, or a set of NB columns when UPLO is L. +*> +*> In order to factorize the panel, the Aasen's algorithm requires the +*> last row, or column, of the previous panel. The first row, or column, +*> of A is set to be the first row, or column, of an identity matrix, +*> which is used to factorize the first panel. +*> +*> The resulting J-th row of U, or J-th column of L, is stored in the +*> (J-1)-th row, or column, of A (without the unit diatonals), while +*> the diagonal and subdiagonal of A are overwritten by those of 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] J1 +*> \verbatim +*> J1 is INTEGER +*> The location of the first row, or column, of the panel +*> within the submatrix of A, passed to this routine, e.g., +*> when called by CHETRF_AASEN, for the first panel, J1 is 1, +*> while for the remaining panels, J1 is 2. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The dimension of the submatrix. M >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The dimension of the panel to be facotorized. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,M) for +*> the first panel, while dimension (LDA,M+1) for the +*> remaining panels. +*> +*> On entry, A contains the last row, or column, of +*> the previous panel, and the trailing submatrix of A +*> to be factorized, except for the first panel, only +*> the panel is passed. +*> +*> On exit, the leading panel is factorized. +*> \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 row and column interchanges, +*> the row and column k were interchanged with the row and +*> column IPIV(k). +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is COMPLEX workspace, dimension (LDH,NB). +*> +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the workspace H. LDH >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX workspace, dimension (M). +*> \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) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2016 +* +*> \ingroup complexSYcomputational +* +* @generated from zlahef_aasen.f, fortran z -> c, Sun Oct 2 22:41:33 2016 +* +* ===================================================================== + SUBROUTINE CLAHEF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV, + $ H, LDH, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER M, NB, J1, LDA, LDH, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), H( LDH, * ), WORK( * ) +* .. +* +* ===================================================================== +* .. Parameters .. + COMPLEX ZERO, ONE + PARAMETER ( ZERO = (0.0E+0, 0.0E+0), ONE = (1.0E+0, 0.0E+0) ) +* +* .. Local Scalars .. + INTEGER J, K, K1, I1, I2 + COMPLEX PIV, ALPHA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ICAMAX, ILAENV + EXTERNAL LSAME, ILAENV, ICAMAX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, CONJG, MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + J = 1 +* +* K1 is the first column of the panel to be factorized +* i.e., K1 is 2 for the first block column, and 1 for the rest of the blocks +* + K1 = (2-J1)+1 +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* ..................................................... +* Factorize A as U**T*D*U using the upper triangle of A +* ..................................................... +* + 10 CONTINUE + IF ( J.GT.MIN(M, NB) ) + $ GO TO 20 +* +* K is the column to be factorized +* when being called from CHETRF_AASEN, +* > for the first block column, J1 is 1, hence J1+J-1 is J, +* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, +* + K = J1+J-1 +* +* H(J:N, J) := A(J, J:N) - H(J:N, 1:(J-1)) * L(J1:(J-1), J), +* where H(J:N, J) has been initialized to be A(J, J:N) +* + IF( K.GT.2 ) THEN +* +* K is the column to be factorized +* > for the first block column, K is J, skipping the first two +* columns +* > for the rest of the columns, K is J+1, skipping only the +* first column +* + CALL CLACGV( J-K1, A( 1, J ), 1 ) + CALL CGEMV( 'No transpose', M-J+1, J-K1, + $ -ONE, H( J, K1 ), LDH, + $ A( 1, J ), 1, + $ ONE, H( J, J ), 1 ) + CALL CLACGV( J-K1, A( 1, J ), 1 ) + END IF +* +* Copy H(i:n, i) into WORK +* + CALL CCOPY( M-J+1, H( J, J ), 1, WORK( 1 ), 1 ) +* + IF( J.GT.K1 ) THEN +* +* Compute WORK := WORK - L(J-1, J:N) * T(J-1,J), +* where A(J-1, J) stores T(J-1, J) and A(J-2, J:N) stores U(J-1, J:N) +* + ALPHA = -CONJG( A( K-1, J ) ) + CALL CAXPY( M-J+1, ALPHA, A( K-2, J ), LDA, WORK( 1 ), 1 ) + END IF +* +* Set A(J, J) = T(J, J) +* + A( K, J ) = REAL( WORK( 1 ) ) +* + IF( J.LT.M ) THEN +* +* Compute WORK(2:N) = T(J, J) L(J, (J+1):N) +* where A(J, J) stores T(J, J) and A(J-1, (J+1):N) stores U(J, (J+1):N) +* + IF( (J1+J-1).GT.1 ) THEN + ALPHA = -A( K, J ) + CALL CAXPY( M-J, ALPHA, A( K-1, J+1 ), LDA, + $ WORK( 2 ), 1 ) + ENDIF +* +* Find max(|WORK(2:n)|) +* + I2 = ICAMAX( M-J, WORK( 2 ), 1 ) + 1 + PIV = WORK( I2 ) +* +* Apply hermitian pivot +* + IF( (I2.NE.2) .AND. (PIV.NE.0) ) THEN +* +* Swap WORK(I1) and WORK(I2) +* + I1 = 2 + WORK( I2 ) = WORK( I1 ) + WORK( I1 ) = PIV +* +* Swap A(I1, I1+1:N) with A(I1+1:N, I2) +* + I1 = I1+J-1 + I2 = I2+J-1 + CALL CSWAP( I2-I1-1, A( J1+I1-1, I1+1 ), LDA, + $ A( J1+I1, I2 ), 1 ) + CALL CLACGV( I2-I1, A( J1+I1-1, I1+1 ), LDA ) + CALL CLACGV( I2-I1-1, A( J1+I1, I2 ), 1 ) +* +* Swap A(I1, I2+1:N) with A(I2, I2+1:N) +* + CALL CSWAP( M-I2, A( J1+I1-1, I2+1 ), LDA, + $ A( J1+I2-1, I2+1 ), LDA ) +* +* Swap A(I1, I1) with A(I2,I2) +* + PIV = A( I1+J1-1, I1 ) + A( J1+I1-1, I1 ) = A( J1+I2-1, I2 ) + A( J1+I2-1, I2 ) = PIV +* +* Swap H(I1, 1:J1) with H(I2, 1:J1) +* + CALL CSWAP( I1-1, H( I1, 1 ), LDH, H( I2, 1 ), LDH ) + IPIV( I1 ) = I2 +* + IF( I1.GT.(K1-1) ) THEN +* +* Swap L(1:I1-1, I1) with L(1:I1-1, I2), +* skipping the first column +* + CALL CSWAP( I1-K1+1, A( 1, I1 ), 1, + $ A( 1, I2 ), 1 ) + END IF + ELSE + IPIV( J+1 ) = J+1 + ENDIF +* +* Set A(J, J+1) = T(J, J+1) +* + A( K, J+1 ) = WORK( 2 ) + IF( (A( K, J ).EQ.ZERO ) .AND. + $ ( (J.EQ.M) .OR. (A( K, J+1 ).EQ.ZERO))) THEN + IF(INFO .EQ. 0) THEN + INFO = J + END IF + END IF +* + IF( J.LT.NB ) THEN +* +* Copy A(J+1:N, J+1) into H(J:N, J), +* + CALL CCOPY( M-J, A( K+1, J+1 ), LDA, + $ H( J+1, J+1 ), 1 ) + END IF +* +* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), +* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) +* + IF( A( K, J+1 ).NE.ZERO ) THEN + ALPHA = ONE / A( K, J+1 ) + CALL CCOPY( M-J-1, WORK( 3 ), 1, A( K, J+2 ), LDA ) + CALL CSCAL( M-J-1, ALPHA, A( K, J+2 ), LDA ) + ELSE + CALL CLASET( 'Full', 1, M-J-1, ZERO, ZERO, + $ A( K, J+2 ), LDA) + END IF + ELSE + IF( (A( K, J ).EQ.ZERO) .AND. (INFO.EQ.0) ) THEN + INFO = J + END IF + END IF + J = J + 1 + GO TO 10 + 20 CONTINUE +* + ELSE +* +* ..................................................... +* Factorize A as L*D*L**T using the lower triangle of A +* ..................................................... +* + 30 CONTINUE + IF( J.GT.MIN( M, NB ) ) + $ GO TO 40 +* +* K is the column to be factorized +* when being called from CHETRF_AASEN, +* > for the first block column, J1 is 1, hence J1+J-1 is J, +* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, +* + K = J1+J-1 +* +* H(J:N, J) := A(J:N, J) - H(J:N, 1:(J-1)) * L(J, J1:(J-1))^T, +* where H(J:N, J) has been initialized to be A(J:N, J) +* + IF( K.GT.2 ) THEN +* +* K is the column to be factorized +* > for the first block column, K is J, skipping the first two +* columns +* > for the rest of the columns, K is J+1, skipping only the +* first column +* + CALL CLACGV( J-K1, A( J, 1 ), LDA ) + CALL CGEMV( 'No transpose', M-J+1, J-K1, + $ -ONE, H( J, K1 ), LDH, + $ A( J, 1 ), LDA, + $ ONE, H( J, J ), 1 ) + CALL CLACGV( J-K1, A( J, 1 ), LDA ) + END IF +* +* Copy H(J:N, J) into WORK +* + CALL CCOPY( M-J+1, H( J, J ), 1, WORK( 1 ), 1 ) +* + IF( J.GT.K1 ) THEN +* +* Compute WORK := WORK - L(J:N, J-1) * T(J-1,J), +* where A(J-1, J) = T(J-1, J) and A(J, J-2) = L(J, J-1) +* + ALPHA = -CONJG( A( J, K-1 ) ) + CALL CAXPY( M-J+1, ALPHA, A( J, K-2 ), 1, WORK( 1 ), 1 ) + END IF +* +* Set A(J, J) = T(J, J) +* + A( J, K ) = REAL( WORK( 1 ) ) +* + IF( J.LT.M ) THEN +* +* Compute WORK(2:N) = T(J, J) L((J+1):N, J) +* where A(J, J) = T(J, J) and A((J+1):N, J-1) = L((J+1):N, J) +* + IF( (J1+J-1).GT.1 ) THEN + ALPHA = -A( J, K ) + CALL CAXPY( M-J, ALPHA, A( J+1, K-1 ), 1, + $ WORK( 2 ), 1 ) + ENDIF +* +* Find max(|WORK(2:n)|) +* + I2 = ICAMAX( M-J, WORK( 2 ), 1 ) + 1 + PIV = WORK( I2 ) +* +* Apply hermitian pivot +* + IF( (I2.NE.2) .AND. (PIV.NE.0) ) THEN +* +* Swap WORK(I1) and WORK(I2) +* + I1 = 2 + WORK( I2 ) = WORK( I1 ) + WORK( I1 ) = PIV +* +* Swap A(I1+1:N, I1) with A(I2, I1+1:N) +* + I1 = I1+J-1 + I2 = I2+J-1 + CALL CSWAP( I2-I1-1, A( I1+1, J1+I1-1 ), 1, + $ A( I2, J1+I1 ), LDA ) + CALL CLACGV( I2-I1, A( I1+1, J1+I1-1 ), 1 ) + CALL CLACGV( I2-I1-1, A( I2, J1+I1 ), LDA ) +* +* Swap A(I2+1:N, I1) with A(I2+1:N, I2) +* + CALL CSWAP( M-I2, A( I2+1, J1+I1-1 ), 1, + $ A( I2+1, J1+I2-1 ), 1 ) +* +* Swap A(I1, I1) with A(I2, I2) +* + PIV = A( I1, J1+I1-1 ) + A( I1, J1+I1-1 ) = A( I2, J1+I2-1 ) + A( I2, J1+I2-1 ) = PIV +* +* Swap H(I1, I1:J1) with H(I2, I2:J1) +* + CALL CSWAP( I1-1, H( I1, 1 ), LDH, H( I2, 1 ), LDH ) + IPIV( I1 ) = I2 +* + IF( I1.GT.(K1-1) ) THEN +* +* Swap L(1:I1-1, I1) with L(1:I1-1, I2), +* skipping the first column +* + CALL CSWAP( I1-K1+1, A( I1, 1 ), LDA, + $ A( I2, 1 ), LDA ) + END IF + ELSE + IPIV( J+1 ) = J+1 + ENDIF +* +* Set A(J+1, J) = T(J+1, J) +* + A( J+1, K ) = WORK( 2 ) + IF( (A( J, K ).EQ.ZERO) .AND. + $ ( (J.EQ.M) .OR. (A( J+1, K ).EQ.ZERO)) ) THEN + IF (INFO .EQ. 0) + $ INFO = J + END IF +* + IF( J.LT.NB ) THEN +* +* Copy A(J+1:N, J+1) into H(J+1:N, J), +* + CALL CCOPY( M-J, A( J+1, K+1 ), 1, + $ H( J+1, J+1 ), 1 ) + END IF +* +* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), +* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) +* + IF( A( J+1, K ).NE.ZERO ) THEN + ALPHA = ONE / A( J+1, K ) + CALL CCOPY( M-J-1, WORK( 3 ), 1, A( J+2, K ), 1 ) + CALL CSCAL( M-J-1, ALPHA, A( J+2, K ), 1 ) + ELSE + CALL CLASET( 'Full', M-J-1, 1, ZERO, ZERO, + $ A( J+2, K ), LDA ) + END IF + ELSE + IF( (A( J, K ).EQ.ZERO) .AND. (J.EQ.M) + $ .AND. (INFO.EQ.0) ) INFO = J + END IF + J = J + 1 + GO TO 30 + 40 CONTINUE + END IF + RETURN +* +* End of CLAHEF_AASEN +* + END diff --git a/SRC/dlasyf_aasen.f b/SRC/dlasyf_aasen.f new file mode 100644 index 0000000..6a28751 --- /dev/null +++ b/SRC/dlasyf_aasen.f @@ -0,0 +1,508 @@ +*> \brief \b DLASYF_AASEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLASYF_AASEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLASYF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV, +* H, LDH, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER J1, M, NB, LDA, LDH, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), H( LDH, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLATRF_AASEN factorizes a panel of a real symmetric matrix A using +*> the Aasen's algorithm. The panel consists of a set of NB rows of A +*> when UPLO is U, or a set of NB columns when UPLO is L. +*> +*> In order to factorize the panel, the Aasen's algorithm requires the +*> last row, or column, of the previous panel. The first row, or column, +*> of A is set to be the first row, or column, of an identity matrix, +*> which is used to factorize the first panel. +*> +*> The resulting J-th row of U, or J-th column of L, is stored in the +*> (J-1)-th row, or column, of A (without the unit diatonals), while +*> the diagonal and subdiagonal of A are overwritten by those of 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] J1 +*> \verbatim +*> J1 is INTEGER +*> The location of the first row, or column, of the panel +*> within the submatrix of A, passed to this routine, e.g., +*> when called by DSYTRF_AASEN, for the first panel, J1 is 1, +*> while for the remaining panels, J1 is 2. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The dimension of the submatrix. M >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The dimension of the panel to be facotorized. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,M) for +*> the first panel, while dimension (LDA,M+1) for the +*> remaining panels. +*> +*> On entry, A contains the last row, or column, of +*> the previous panel, and the trailing submatrix of A +*> to be factorized, except for the first panel, only +*> the panel is passed. +*> +*> On exit, the leading panel is factorized. +*> \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 row and column interchanges, +*> the row and column k were interchanged with the row and +*> column IPIV(k). +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is DOUBLE PRECISION workspace, dimension (LDH,NB). +*> +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the workspace H. LDH >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION workspace, dimension (M). +*> \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) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2016 +* +*> \ingroup doubleSYcomputational +* +* @precisions fortran d -> s +* +* ===================================================================== + SUBROUTINE DLASYF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV, + $ H, LDH, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER M, NB, J1, LDA, LDH, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), H( LDH, * ), WORK( * ) +* .. +* +* ===================================================================== +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* +* .. Local Scalars .. + INTEGER J, K, K1, I1, I2 + DOUBLE PRECISION PIV, ALPHA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX, ILAENV + EXTERNAL LSAME, ILAENV, IDAMAX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + J = 1 +* +* K1 is the first column of the panel to be factorized +* i.e., K1 is 2 for the first block column, and 1 for the rest of the blocks +* + K1 = (2-J1)+1 +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* ..................................................... +* Factorize A as U**T*D*U using the upper triangle of A +* ..................................................... +* + 10 CONTINUE + IF ( J.GT.MIN(M, NB) ) + $ GO TO 20 +* +* K is the column to be factorized +* when being called from DSYTRF_AASEN, +* > for the first block column, J1 is 1, hence J1+J-1 is J, +* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, +* + K = J1+J-1 +* +* H(J:N, J) := A(J, J:N) - H(J:N, 1:(J-1)) * L(J1:(J-1), J), +* where H(J:N, J) has been initialized to be A(J, J:N) +* + IF( K.GT.2 ) THEN +* +* K is the column to be factorized +* > for the first block column, K is J, skipping the first two +* columns +* > for the rest of the columns, K is J+1, skipping only the +* first column +* + CALL DGEMV( 'No transpose', M-J+1, J-K1, + $ -ONE, H( J, K1 ), LDH, + $ A( 1, J ), 1, + $ ONE, H( J, J ), 1 ) + END IF +* +* Copy H(i:n, i) into WORK +* + CALL DCOPY( M-J+1, H( J, J ), 1, WORK( 1 ), 1 ) +* + IF( J.GT.K1 ) THEN +* +* Compute WORK := WORK - L(J-1, J:N) * T(J-1,J), +* where A(J-1, J) stores T(J-1, J) and A(J-2, J:N) stores U(J-1, J:N) +* + ALPHA = -A( K-1, J ) + CALL DAXPY( M-J+1, ALPHA, A( K-2, J ), LDA, WORK( 1 ), 1 ) + END IF +* +* Set A(J, J) = T(J, J) +* + A( K, J ) = WORK( 1 ) +* + IF( J.LT.M ) THEN +* +* Compute WORK(2:N) = T(J, J) L(J, (J+1):N) +* where A(J, J) stores T(J, J) and A(J-1, (J+1):N) stores U(J, (J+1):N) +* + IF( (J1+J-1).GT.1 ) THEN + ALPHA = -A( K, J ) + CALL DAXPY( M-J, ALPHA, A( K-1, J+1 ), LDA, + $ WORK( 2 ), 1 ) + ENDIF +* +* Find max(|WORK(2:n)|) +* + I2 = IDAMAX( M-J, WORK( 2 ), 1 ) + 1 + PIV = WORK( I2 ) +* +* Apply symmetric pivot +* + IF( (I2.NE.2) .AND. (PIV.NE.0) ) THEN +* +* Swap WORK(I1) and WORK(I2) +* + I1 = 2 + WORK( I2 ) = WORK( I1 ) + WORK( I1 ) = PIV +* +* Swap A(I1, I1+1:N) with A(I1+1:N, I2) +* + I1 = I1+J-1 + I2 = I2+J-1 + CALL DSWAP( I2-I1-1, A( J1+I1-1, I1+1 ), LDA, + $ A( J1+I1, I2 ), 1 ) +* +* Swap A(I1, I2+1:N) with A(I2, I2+1:N) +* + CALL DSWAP( M-I2, A( J1+I1-1, I2+1 ), LDA, + $ A( J1+I2-1, I2+1 ), LDA ) +* +* Swap A(I1, I1) with A(I2,I2) +* + PIV = A( I1+J1-1, I1 ) + A( J1+I1-1, I1 ) = A( J1+I2-1, I2 ) + A( J1+I2-1, I2 ) = PIV +* +* Swap H(I1, 1:J1) with H(I2, 1:J1) +* + CALL DSWAP( I1-1, H( I1, 1 ), LDH, H( I2, 1 ), LDH ) + IPIV( I1 ) = I2 +* + IF( I1.GT.(K1-1) ) THEN +* +* Swap L(1:I1-1, I1) with L(1:I1-1, I2), +* skipping the first column +* + CALL DSWAP( I1-K1+1, A( 1, I1 ), 1, + $ A( 1, I2 ), 1 ) + END IF + ELSE + IPIV( J+1 ) = J+1 + ENDIF +* +* Set A(J, J+1) = T(J, J+1) +* + A( K, J+1 ) = WORK( 2 ) + IF( (A( K, J ).EQ.ZERO ) .AND. + $ ( (J.EQ.M) .OR. (A( K, J+1 ).EQ.ZERO))) THEN + IF(INFO .EQ. 0) THEN + INFO = J + ENDIF + END IF +* + IF( J.LT.NB ) THEN +* +* Copy A(J+1:N, J+1) into H(J:N, J), +* + CALL DCOPY( M-J, A( K+1, J+1 ), LDA, + $ H( J+1, J+1 ), 1 ) + END IF +* +* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), +* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) +* + IF( A( K, J+1 ).NE.ZERO ) THEN + ALPHA = ONE / A( K, J+1 ) + CALL DCOPY( M-J-1, WORK( 3 ), 1, A( K, J+2 ), LDA ) + CALL DSCAL( M-J-1, ALPHA, A( K, J+2 ), LDA ) + ELSE + CALL DLASET( 'Full', 1, M-J-1, ZERO, ZERO, + $ A( K, J+2 ), LDA) + END IF + ELSE + IF( (A( K, J ).EQ.ZERO) .AND. (INFO.EQ.0) ) THEN + INFO = J + END IF + END IF + J = J + 1 + GO TO 10 + 20 CONTINUE +* + ELSE +* +* ..................................................... +* Factorize A as L*D*L**T using the lower triangle of A +* ..................................................... +* + 30 CONTINUE + IF( J.GT.MIN( M, NB ) ) + $ GO TO 40 +* +* K is the column to be factorized +* when being called from DSYTRF_AASEN, +* > for the first block column, J1 is 1, hence J1+J-1 is J, +* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, +* + K = J1+J-1 +* +* H(J:N, J) := A(J:N, J) - H(J:N, 1:(J-1)) * L(J, J1:(J-1))^T, +* where H(J:N, J) has been initialized to be A(J:N, J) +* + IF( K.GT.2 ) THEN +* +* K is the column to be factorized +* > for the first block column, K is J, skipping the first two +* columns +* > for the rest of the columns, K is J+1, skipping only the +* first column +* + CALL DGEMV( 'No transpose', M-J+1, J-K1, + $ -ONE, H( J, K1 ), LDH, + $ A( J, 1 ), LDA, + $ ONE, H( J, J ), 1 ) + END IF +* +* Copy H(J:N, J) into WORK +* + CALL DCOPY( M-J+1, H( J, J ), 1, WORK( 1 ), 1 ) +* + IF( J.GT.K1 ) THEN +* +* Compute WORK := WORK - L(J:N, J-1) * T(J-1,J), +* where A(J-1, J) = T(J-1, J) and A(J, J-2) = L(J, J-1) +* + ALPHA = -A( J, K-1 ) + CALL DAXPY( M-J+1, ALPHA, A( J, K-2 ), 1, WORK( 1 ), 1 ) + END IF +* +* Set A(J, J) = T(J, J) +* + A( J, K ) = WORK( 1 ) +* + IF( J.LT.M ) THEN +* +* Compute WORK(2:N) = T(J, J) L((J+1):N, J) +* where A(J, J) = T(J, J) and A((J+1):N, J-1) = L((J+1):N, J) +* + IF( (J1+J-1).GT.1 ) THEN + ALPHA = -A( J, K ) + CALL DAXPY( M-J, ALPHA, A( J+1, K-1 ), 1, + $ WORK( 2 ), 1 ) + ENDIF +* +* Find max(|WORK(2:n)|) +* + I2 = IDAMAX( M-J, WORK( 2 ), 1 ) + 1 + PIV = WORK( I2 ) +* +* Apply symmetric pivot +* + IF( (I2.NE.2) .AND. (PIV.NE.0) ) THEN +* +* Swap WORK(I1) and WORK(I2) +* + I1 = 2 + WORK( I2 ) = WORK( I1 ) + WORK( I1 ) = PIV +* +* Swap A(I1+1:N, I1) with A(I2, I1+1:N) +* + I1 = I1+J-1 + I2 = I2+J-1 + CALL DSWAP( I2-I1-1, A( I1+1, J1+I1-1 ), 1, + $ A( I2, J1+I1 ), LDA ) +* +* Swap A(I2+1:N, I1) with A(I2+1:N, I2) +* + CALL DSWAP( M-I2, A( I2+1, J1+I1-1 ), 1, + $ A( I2+1, J1+I2-1 ), 1 ) +* +* Swap A(I1, I1) with A(I2, I2) +* + PIV = A( I1, J1+I1-1 ) + A( I1, J1+I1-1 ) = A( I2, J1+I2-1 ) + A( I2, J1+I2-1 ) = PIV +* +* Swap H(I1, I1:J1) with H(I2, I2:J1) +* + CALL DSWAP( I1-1, H( I1, 1 ), LDH, H( I2, 1 ), LDH ) + IPIV( I1 ) = I2 +* + IF( I1.GT.(K1-1) ) THEN +* +* Swap L(1:I1-1, I1) with L(1:I1-1, I2), +* skipping the first column +* + CALL DSWAP( I1-K1+1, A( I1, 1 ), LDA, + $ A( I2, 1 ), LDA ) + END IF + ELSE + IPIV( J+1 ) = J+1 + ENDIF +* +* Set A(J+1, J) = T(J+1, J) +* + A( J+1, K ) = WORK( 2 ) + IF( (A( J, K ).EQ.ZERO) .AND. + $ ( (J.EQ.M) .OR. (A( J+1, K ).EQ.ZERO)) ) THEN + IF (INFO .EQ. 0) + $ INFO = J + END IF +* + IF( J.LT.NB ) THEN +* +* Copy A(J+1:N, J+1) into H(J+1:N, J), +* + CALL DCOPY( M-J, A( J+1, K+1 ), 1, + $ H( J+1, J+1 ), 1 ) + END IF +* +* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), +* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) +* + IF( A( J+1, K ).NE.ZERO ) THEN + ALPHA = ONE / A( J+1, K ) + CALL DCOPY( M-J-1, WORK( 3 ), 1, A( J+2, K ), 1 ) + CALL DSCAL( M-J-1, ALPHA, A( J+2, K ), 1 ) + ELSE + CALL DLASET( 'Full', M-J-1, 1, ZERO, ZERO, + $ A( J+2, K ), LDA ) + END IF + ELSE + IF( (A( J, K ).EQ.ZERO) .AND. (INFO.EQ.0) ) THEN + INFO = J + END IF + END IF + J = J + 1 + GO TO 30 + 40 CONTINUE + END IF + RETURN +* +* End of DLASYF_AASEN +* + END diff --git a/SRC/dsysv_aasen.f b/SRC/dsysv_aasen.f new file mode 100644 index 0000000..63cb8a5 --- /dev/null +++ b/SRC/dsysv_aasen.f @@ -0,0 +1,249 @@ +*> \brief DSYSV_AASEN computes the solution to system of linear equations A * X = B for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYSV_AASEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYSV_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYSV computes the solution to a real system of linear equations +*> A * X = B, +*> where A is an N-by-N symmetric matrix and X and B are N-by-NRHS +*> matrices. +*> +*> Aasen's algorithm is used to factor A as +*> A = U * T * U**T, if UPLO = 'U', or +*> A = L * T * L**T, if UPLO = 'L', +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and T is symmetric tridiagonal. 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 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. +*> +*> On exit, if INFO = 0, the tridiagonal matrix T and the +*> multipliers used to obtain the factor U or L from the +*> factorization A = U*T*U**T or A = L*T*L**T as computed by +*> DSYTRF. +*> \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) +*> On exit, it contains the details of the interchanges, i.e., +*> the row and column k of A were interchanged with the +*> row and column IPIV(k). +*> \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 >= MAX(2*N, 3*N-2), and for +*> the best performance, LWORK >= max(1,N*NB), where NB is +*> the optimal blocksize for DSYTRF_AASEN. +*> +*> 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,i) 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. +* +*> \date November 2016 +* +*> \ingroup doubleSYsolve +* +* @precisions fortran d -> s +* +* ===================================================================== + SUBROUTINE DSYSV_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* +* .. 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, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DSYTRF, DSYTRS, DSYTRS2 +* .. +* .. 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.MAX(2*N, 3*N-2) .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF +* + IF( INFO.EQ.0 ) THEN + NB = ILAENV( 1, 'DSYTRF_AASEN', UPLO, N, -1, -1, -1 ) + LWKOPT = MAX( 3*N-2, (1+NB)*N ) + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYSV_AASEN ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = U*T*U**T or A = L*T*L**T. +* + CALL DSYTRF_AASEN( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* + CALL DSYTRS_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DSYSV_AASEN +* + END diff --git a/SRC/dsytrf_aasen.f b/SRC/dsytrf_aasen.f new file mode 100644 index 0000000..f484c6b --- /dev/null +++ b/SRC/dsytrf_aasen.f @@ -0,0 +1,482 @@ +*> \brief \b DSYTRF_AASEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRF_AASEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRF_AASEN( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, LDA, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTRF_AASEN computes the factorization of a real symmetric matrix A +*> using the Aasen's algorithm. The form of the factorization is +*> +*> A = U*T*U**T or A = L*T*L**T +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and T is a symmetric tridiagonal matrix. +*> +*> 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 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. +*> +*> On exit, the tridiagonal matrix is stored in the diagonals +*> and the subdiagonals of A just below (or above) the diagonals, +*> and L is stored below (or above) the subdiaonals, when UPLO +*> is 'L' (or 'U'). +*> \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) +*> On exit, it contains the details of the interchanges, i.e., +*> the row and column k of A were interchanged with the +*> row and column IPIV(k). +*> \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 >=2*N. For optimum performance +*> LWORK >= N*(1+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 +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2016 +* +*> \ingroup doubleSYcomputational +* +* @precisions fortran d -> s +* +* ===================================================================== + SUBROUTINE DSYTRF_AASEN( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, LDA, LWORK, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER J, LWKOPT, IINFO + INTEGER NB, MJ, NJ, K1, K2, J1, J2, J3, JB + DOUBLE PRECISION ALPHA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Determine the block size +* + NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 ) +* +* 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.( 2*N ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN + LWKOPT = (NB+1)*N + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRF_AASEN', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return +* + IF ( N.EQ.0 ) THEN + RETURN + ENDIF + IPIV( 1 ) = 1 + IF ( N.EQ.1 ) THEN + IF ( A( 1, 1 ).EQ.ZERO ) THEN + INFO = 1 + END IF + RETURN + END IF +* +* Adjubst block size based on the workspace size +* + IF( LWORK.LT.((1+NB)*N) ) THEN + NB = ( LWORK-N ) / N + END IF +* + IF( UPPER ) THEN +* +* ..................................................... +* Factorize A as L*D*L**T using the upper triangle of A +* ..................................................... +* +* Copy first row A(1, 1:N) into H(1:n) (stored in WORK(1:N)) +* + CALL DCOPY( N, A( 1, 1 ), LDA, WORK( 1 ), 1 ) +* +* J is the main loop index, increasing from 1 to N in steps of +* JB, where JB is the number of columns factorized by DLASYF; +* JB is either NB, or N-J+1 for the last block +* + J = 0 + 10 CONTINUE + IF( J.GE.N ) + $ GO TO 20 +* +* each step of the main loop +* J is the last column of the previous panel +* J1 is the first column of the current panel +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 for the first panel, and +* K1=0 for the rest +* + J1 = J + 1 + JB = MIN( N-J1+1, NB ) + K1 = MAX(1, J)-J +* +* Panel factorization +* + CALL DLASYF_AASEN( UPLO, 2-K1, N-J, JB, + $ A( MAX(1, J), J+1 ), LDA, + $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), + $ IINFO ) + IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN + INFO = IINFO+J + ENDIF +* +* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot) +* + DO J2 = J+2, MIN(N, J+JB+1) + IPIV( J2 ) = IPIV( J2 ) + J + IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN + CALL DSWAP( J1-K1-2, A( 1, J2 ), 1, + $ A( 1, IPIV(J2) ), 1 ) + END IF + END DO + J = J + JB +* +* Trailing submatrix update, where +* the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and +* WORK stores the current block of the auxiriarly matrix H +* + IF( J.LT.N ) THEN +* +* If first panel and JB=1 (NB=1), then nothing to do +* + IF( J1.GT.1 .OR. JB.GT.1 ) THEN +* +* Merge rank-1 update with BLAS-3 update +* + ALPHA = A( J, J+1 ) + A( J, J+1 ) = ONE + CALL DCOPY( N-J, A( J-1, J+1 ), LDA, + $ WORK( (J+1-J1+1)+JB*N ), 1 ) + CALL DSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 ) +* +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 and K2= 0 for the first panel, +* while K1=0 and K2=1 for the rest +* + IF( J1.GT.1 ) THEN +* +* Not first panel +* + K2 = 1 + ELSE +* +* First panel +* + K2 = 0 +* +* First update skips the first column +* + JB = JB - 1 + END IF +* + DO J2 = J+1, N, NB + NJ = MIN( NB, N-J2+1 ) +* +* Update (J2, J2) diagonal block with DGEMV +* + J3 = J2 + DO MJ = NJ-1, 1, -1 + CALL DGEMV( 'No transpose', MJ, JB+1, + $ -ONE, WORK( J3-J1+1+K1*N ), N, + $ A( J1-K2, J3 ), 1, + $ ONE, A( J3, J3 ), LDA ) + J3 = J3 + 1 + END DO +* +* Update off-diagonal block of J2-th block row with DGEMM +* + CALL DGEMM( 'Transpose', 'Transpose', + $ NJ, N-J3+1, JB+1, + $ -ONE, A( J1-K2, J2 ), LDA, + $ WORK( J3-J1+1+K1*N ), N, + $ ONE, A( J2, J3 ), LDA ) + END DO +* +* Recover T( J, J+1 ) +* + A( J, J+1 ) = ALPHA + END IF +* +* WORK(J+1, 1) stores H(J+1, 1) +* + CALL DCOPY( N-J, A( J+1, J+1 ), LDA, WORK( 1 ), 1 ) + END IF + GO TO 10 + ELSE +* +* ..................................................... +* Factorize A as L*D*L**T using the lower triangle of A +* ..................................................... +* +* copy first column A(1:N, 1) into H(1:N, 1) +* (stored in WORK(1:N)) +* + CALL DCOPY( N, A( 1, 1 ), 1, WORK( 1 ), 1 ) +* +* J is the main loop index, increasing from 1 to N in steps of +* JB, where JB is the number of columns factorized by DLASYF; +* JB is either NB, or N-J+1 for the last block +* + J = 0 + 11 CONTINUE + IF( J.GE.N ) + $ GO TO 20 +* +* each step of the main loop +* J is the last column of the previous panel +* J1 is the first column of the current panel +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 for the first panel, and +* K1=0 for the rest +* + J1 = J+1 + JB = MIN( N-J1+1, NB ) + K1 = MAX(1, J)-J +* +* Panel factorization +* + CALL DLASYF_AASEN( UPLO, 2-K1, N-J, JB, + $ A( J+1, MAX(1, J) ), LDA, + $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), IINFO) + IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN + INFO = IINFO+J + ENDIF +* +* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot) +* + DO J2 = J+2, MIN(N, J+JB+1) + IPIV( J2 ) = IPIV( J2 ) + J + IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN + CALL DSWAP( J1-K1-2, A( J2, 1 ), LDA, + $ A( IPIV(J2), 1 ), LDA ) + END IF + END DO + J = J + JB +* +* Trailing submatrix update, where +* A(J2+1, J1-1) stores L(J2+1, J1) and +* WORK(J2+1, 1) stores H(J2+1, 1) +* + IF( J.LT.N ) THEN +* +* if first panel and JB=1 (NB=1), then nothing to do +* + IF( J1.GT.1 .OR. JB.GT.1 ) THEN +* +* Merge rank-1 update with BLAS-3 update +* + ALPHA = A( J+1, J ) + A( J+1, J ) = ONE + CALL DCOPY( N-J, A( J+1, J-1 ), 1, + $ WORK( (J+1-J1+1)+JB*N ), 1 ) + CALL DSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 ) +* +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 and K2= 0 for the first panel, +* while K1=0 and K2=1 for the rest +* + IF( J1.GT.1 ) THEN +* +* Not first panel +* + K2 = 1 + ELSE +* +* First panel +* + K2 = 0 +* +* First update skips the first column +* + JB = JB - 1 + END IF +* + DO J2 = J+1, N, NB + NJ = MIN( NB, N-J2+1 ) +* +* Update (J2, J2) diagonal block with DGEMV +* + J3 = J2 + DO MJ = NJ-1, 1, -1 + CALL DGEMV( 'No transpose', MJ, JB+1, + $ -ONE, WORK( J3-J1+1+K1*N ), N, + $ A( J3, J1-K2 ), LDA, + $ ONE, A( J3, J3 ), 1 ) + J3 = J3 + 1 + END DO +* +* Update off-diagonal block in J2-th block column with DGEMM +* + CALL DGEMM( 'No transpose', 'Transpose', + $ N-J3+1, NJ, JB+1, + $ -ONE, WORK( J3-J1+1+K1*N ), N, + $ A( J2, J1-K2 ), LDA, + $ ONE, A( J3, J2 ), LDA ) + END DO +* +* Recover T( J+1, J ) +* + A( J+1, J ) = ALPHA + END IF +* +* WORK(J+1, 1) stores H(J+1, 1) +* + CALL DCOPY( N-J, A( J+1, J+1 ), 1, WORK( 1 ), 1 ) + END IF + GO TO 11 + END IF +* + 20 CONTINUE + RETURN +* +* End of DSYTRF_AASEN +* + END diff --git a/SRC/dsytrs_aasen.f b/SRC/dsytrs_aasen.f new file mode 100644 index 0000000..05bcda3 --- /dev/null +++ b/SRC/dsytrs_aasen.f @@ -0,0 +1,282 @@ +*> \brief \b DSYTRS_AASEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DSYTRS_AASEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DSYTRS_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYTRS_AASEN solves a system of linear equations A*X = B with a real +*> symmetric matrix A using the factorization A = U*T*U**T or +*> A = L*T*L**T computed by DSYTRF_AASEN. +*> \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*T*U**T; +*> = 'L': Lower triangular, form is A = L*T*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) +*> Details of factors computed by DSYTRF_AASEN. +*> \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 as computed by DSYTRF_AASEN. +*> \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[in] WORK +*> \verbatim +*> WORK is DOUBLE array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER, LWORK >= 3*N-2. +*> +*> \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. +* +*> \date November 2016 +* +*> \ingroup doubleSYcomputational +* +* @precisions fortran d -> s +* +* ===================================================================== + SUBROUTINE DSYTRS_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER K, KP +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGTSV, 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 + ELSE IF( LWORK.LT.(3*N-2) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRS_AASEN', -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*T*U**T. +* +* Pivot, P**T * B +* + DO K = 1, N + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* +* Compute (U \P**T * B) -> B [ (U \P**T * B) ] +* + CALL DTRSM('L', 'U', 'T', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA, + $ B( 2, 1 ), LDB) +* +* Compute T \ B -> B [ T \ (U \P**T * B) ] +* + CALL DLACPY( 'F', 1, N, A( 1, 1 ), LDA+1, WORK( N ), 1) + IF( N.GT.1 ) THEN + CALL DLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 1 ), 1 ) + CALL DLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 2*N ), 1 ) + END IF + CALL DGTSV( N, NRHS, WORK( 1 ), WORK( N ), WORK( 2*N ), B, LDB, + $ INFO ) +* +* Compute (U**T \ B) -> B [ U**T \ (T \ (U \P**T * B) ) ] +* + CALL DTRSM( 'L', 'U', 'N', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA, + $ B( 2, 1 ), LDB) +* +* Pivot, P * B [ P * (U**T \ (T \ (U \P**T * B) )) ] +* + DO K = N, 1, -1 + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* + ELSE +* +* Solve A*X = B, where A = L*T*L**T. +* +* Pivot, P**T * B +* + DO K = 1, N + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* +* Compute (L \P**T * B) -> B [ (L \P**T * B) ] +* + CALL DTRSM( 'L', 'L', 'N', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA, + $ B( 2, 1 ), LDB) +* +* Compute T \ B -> B [ T \ (L \P**T * B) ] +* + CALL DLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1) + IF( N.GT.1 ) THEN + CALL DLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 1 ), 1 ) + CALL DLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 2*N ), 1 ) + END IF + CALL DGTSV( N, NRHS, WORK( 1 ), WORK(N), WORK( 2*N ), B, LDB, + $ INFO) +* +* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ] +* + CALL DTRSM( 'L', 'L', 'T', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA, + $ B( 2, 1 ), LDB) +* +* Pivot, P * B [ P * (L**T \ (T \ (L \P**T * B) )) ] +* + DO K = N, 1, -1 + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* + END IF +* + RETURN +* +* End of DSYTRS_AASEN +* + END diff --git a/SRC/slasyf_aasen.f b/SRC/slasyf_aasen.f new file mode 100644 index 0000000..2c8f4e0 --- /dev/null +++ b/SRC/slasyf_aasen.f @@ -0,0 +1,508 @@ +*> \brief \b SLASYF_AASEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SLASYF_AASEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SLASYF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV, +* H, LDH, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER J1, M, NB, LDA, LDH, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), H( LDH, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLATRF_AASEN factorizes a panel of a real symmetric matrix A using +*> the Aasen's algorithm. The panel consists of a set of NB rows of A +*> when UPLO is U, or a set of NB columns when UPLO is L. +*> +*> In order to factorize the panel, the Aasen's algorithm requires the +*> last row, or column, of the previous panel. The first row, or column, +*> of A is set to be the first row, or column, of an identity matrix, +*> which is used to factorize the first panel. +*> +*> The resulting J-th row of U, or J-th column of L, is stored in the +*> (J-1)-th row, or column, of A (without the unit diatonals), while +*> the diagonal and subdiagonal of A are overwritten by those of 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] J1 +*> \verbatim +*> J1 is INTEGER +*> The location of the first row, or column, of the panel +*> within the submatrix of A, passed to this routine, e.g., +*> when called by SSYTRF_AASEN, for the first panel, J1 is 1, +*> while for the remaining panels, J1 is 2. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The dimension of the submatrix. M >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The dimension of the panel to be facotorized. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,M) for +*> the first panel, while dimension (LDA,M+1) for the +*> remaining panels. +*> +*> On entry, A contains the last row, or column, of +*> the previous panel, and the trailing submatrix of A +*> to be factorized, except for the first panel, only +*> the panel is passed. +*> +*> On exit, the leading panel is factorized. +*> \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 row and column interchanges, +*> the row and column k were interchanged with the row and +*> column IPIV(k). +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is REAL workspace, dimension (LDH,NB). +*> +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the workspace H. LDH >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL workspace, dimension (M). +*> \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) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2016 +* +*> \ingroup realSYcomputational +* +* @generated from dlasyf_aasen.f, fortran d -> s, Sun Oct 2 22:57:56 2016 +* +* ===================================================================== + SUBROUTINE SLASYF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV, + $ H, LDH, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER M, NB, J1, LDA, LDH, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), H( LDH, * ), WORK( * ) +* .. +* +* ===================================================================== +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* +* .. Local Scalars .. + INTEGER J, K, K1, I1, I2 + REAL PIV, ALPHA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ISAMAX, ILAENV + EXTERNAL LSAME, ILAENV, ISAMAX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + J = 1 +* +* K1 is the first column of the panel to be factorized +* i.e., K1 is 2 for the first block column, and 1 for the rest of the blocks +* + K1 = (2-J1)+1 +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* ..................................................... +* Factorize A as U**T*D*U using the upper triangle of A +* ..................................................... +* + 10 CONTINUE + IF ( J.GT.MIN(M, NB) ) + $ GO TO 20 +* +* K is the column to be factorized +* when being called from SSYTRF_AASEN, +* > for the first block column, J1 is 1, hence J1+J-1 is J, +* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, +* + K = J1+J-1 +* +* H(J:N, J) := A(J, J:N) - H(J:N, 1:(J-1)) * L(J1:(J-1), J), +* where H(J:N, J) has been initialized to be A(J, J:N) +* + IF( K.GT.2 ) THEN +* +* K is the column to be factorized +* > for the first block column, K is J, skipping the first two +* columns +* > for the rest of the columns, K is J+1, skipping only the +* first column +* + CALL SGEMV( 'No transpose', M-J+1, J-K1, + $ -ONE, H( J, K1 ), LDH, + $ A( 1, J ), 1, + $ ONE, H( J, J ), 1 ) + END IF +* +* Copy H(i:n, i) into WORK +* + CALL SCOPY( M-J+1, H( J, J ), 1, WORK( 1 ), 1 ) +* + IF( J.GT.K1 ) THEN +* +* Compute WORK := WORK - L(J-1, J:N) * T(J-1,J), +* where A(J-1, J) stores T(J-1, J) and A(J-2, J:N) stores U(J-1, J:N) +* + ALPHA = -A( K-1, J ) + CALL SAXPY( M-J+1, ALPHA, A( K-2, J ), LDA, WORK( 1 ), 1 ) + END IF +* +* Set A(J, J) = T(J, J) +* + A( K, J ) = WORK( 1 ) +* + IF( J.LT.M ) THEN +* +* Compute WORK(2:N) = T(J, J) L(J, (J+1):N) +* where A(J, J) stores T(J, J) and A(J-1, (J+1):N) stores U(J, (J+1):N) +* + IF( (J1+J-1).GT.1 ) THEN + ALPHA = -A( K, J ) + CALL SAXPY( M-J, ALPHA, A( K-1, J+1 ), LDA, + $ WORK( 2 ), 1 ) + ENDIF +* +* Find max(|WORK(2:n)|) +* + I2 = ISAMAX( M-J, WORK( 2 ), 1 ) + 1 + PIV = WORK( I2 ) +* +* Apply symmetric pivot +* + IF( (I2.NE.2) .AND. (PIV.NE.0) ) THEN +* +* Swap WORK(I1) and WORK(I2) +* + I1 = 2 + WORK( I2 ) = WORK( I1 ) + WORK( I1 ) = PIV +* +* Swap A(I1, I1+1:N) with A(I1+1:N, I2) +* + I1 = I1+J-1 + I2 = I2+J-1 + CALL SSWAP( I2-I1-1, A( J1+I1-1, I1+1 ), LDA, + $ A( J1+I1, I2 ), 1 ) +* +* Swap A(I1, I2+1:N) with A(I2, I2+1:N) +* + CALL SSWAP( M-I2, A( J1+I1-1, I2+1 ), LDA, + $ A( J1+I2-1, I2+1 ), LDA ) +* +* Swap A(I1, I1) with A(I2,I2) +* + PIV = A( I1+J1-1, I1 ) + A( J1+I1-1, I1 ) = A( J1+I2-1, I2 ) + A( J1+I2-1, I2 ) = PIV +* +* Swap H(I1, 1:J1) with H(I2, 1:J1) +* + CALL SSWAP( I1-1, H( I1, 1 ), LDH, H( I2, 1 ), LDH ) + IPIV( I1 ) = I2 +* + IF( I1.GT.(K1-1) ) THEN +* +* Swap L(1:I1-1, I1) with L(1:I1-1, I2), +* skipping the first column +* + CALL SSWAP( I1-K1+1, A( 1, I1 ), 1, + $ A( 1, I2 ), 1 ) + END IF + ELSE + IPIV( J+1 ) = J+1 + ENDIF +* +* Set A(J, J+1) = T(J, J+1) +* + A( K, J+1 ) = WORK( 2 ) + IF( (A( K, J ).EQ.ZERO ) .AND. + $ ( (J.EQ.M) .OR. (A( K, J+1 ).EQ.ZERO))) THEN + IF(INFO .EQ. 0) THEN + INFO = J + ENDIF + END IF +* + IF( J.LT.NB ) THEN +* +* Copy A(J+1:N, J+1) into H(J:N, J), +* + CALL SCOPY( M-J, A( K+1, J+1 ), LDA, + $ H( J+1, J+1 ), 1 ) + END IF +* +* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), +* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) +* + IF( A( K, J+1 ).NE.ZERO ) THEN + ALPHA = ONE / A( K, J+1 ) + CALL SCOPY( M-J-1, WORK( 3 ), 1, A( K, J+2 ), LDA ) + CALL SSCAL( M-J-1, ALPHA, A( K, J+2 ), LDA ) + ELSE + CALL SLASET( 'Full', 1, M-J-1, ZERO, ZERO, + $ A( K, J+2 ), LDA) + END IF + ELSE + IF( (A( K, J ).EQ.ZERO) .AND. (INFO.EQ.0) ) THEN + INFO = J + END IF + END IF + J = J + 1 + GO TO 10 + 20 CONTINUE +* + ELSE +* +* ..................................................... +* Factorize A as L*D*L**T using the lower triangle of A +* ..................................................... +* + 30 CONTINUE + IF( J.GT.MIN( M, NB ) ) + $ GO TO 40 +* +* K is the column to be factorized +* when being called from SSYTRF_AASEN, +* > for the first block column, J1 is 1, hence J1+J-1 is J, +* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, +* + K = J1+J-1 +* +* H(J:N, J) := A(J:N, J) - H(J:N, 1:(J-1)) * L(J, J1:(J-1))^T, +* where H(J:N, J) has been initialized to be A(J:N, J) +* + IF( K.GT.2 ) THEN +* +* K is the column to be factorized +* > for the first block column, K is J, skipping the first two +* columns +* > for the rest of the columns, K is J+1, skipping only the +* first column +* + CALL SGEMV( 'No transpose', M-J+1, J-K1, + $ -ONE, H( J, K1 ), LDH, + $ A( J, 1 ), LDA, + $ ONE, H( J, J ), 1 ) + END IF +* +* Copy H(J:N, J) into WORK +* + CALL SCOPY( M-J+1, H( J, J ), 1, WORK( 1 ), 1 ) +* + IF( J.GT.K1 ) THEN +* +* Compute WORK := WORK - L(J:N, J-1) * T(J-1,J), +* where A(J-1, J) = T(J-1, J) and A(J, J-2) = L(J, J-1) +* + ALPHA = -A( J, K-1 ) + CALL SAXPY( M-J+1, ALPHA, A( J, K-2 ), 1, WORK( 1 ), 1 ) + END IF +* +* Set A(J, J) = T(J, J) +* + A( J, K ) = WORK( 1 ) +* + IF( J.LT.M ) THEN +* +* Compute WORK(2:N) = T(J, J) L((J+1):N, J) +* where A(J, J) = T(J, J) and A((J+1):N, J-1) = L((J+1):N, J) +* + IF( (J1+J-1).GT.1 ) THEN + ALPHA = -A( J, K ) + CALL SAXPY( M-J, ALPHA, A( J+1, K-1 ), 1, + $ WORK( 2 ), 1 ) + ENDIF +* +* Find max(|WORK(2:n)|) +* + I2 = ISAMAX( M-J, WORK( 2 ), 1 ) + 1 + PIV = WORK( I2 ) +* +* Apply symmetric pivot +* + IF( (I2.NE.2) .AND. (PIV.NE.0) ) THEN +* +* Swap WORK(I1) and WORK(I2) +* + I1 = 2 + WORK( I2 ) = WORK( I1 ) + WORK( I1 ) = PIV +* +* Swap A(I1+1:N, I1) with A(I2, I1+1:N) +* + I1 = I1+J-1 + I2 = I2+J-1 + CALL SSWAP( I2-I1-1, A( I1+1, J1+I1-1 ), 1, + $ A( I2, J1+I1 ), LDA ) +* +* Swap A(I2+1:N, I1) with A(I2+1:N, I2) +* + CALL SSWAP( M-I2, A( I2+1, J1+I1-1 ), 1, + $ A( I2+1, J1+I2-1 ), 1 ) +* +* Swap A(I1, I1) with A(I2, I2) +* + PIV = A( I1, J1+I1-1 ) + A( I1, J1+I1-1 ) = A( I2, J1+I2-1 ) + A( I2, J1+I2-1 ) = PIV +* +* Swap H(I1, I1:J1) with H(I2, I2:J1) +* + CALL SSWAP( I1-1, H( I1, 1 ), LDH, H( I2, 1 ), LDH ) + IPIV( I1 ) = I2 +* + IF( I1.GT.(K1-1) ) THEN +* +* Swap L(1:I1-1, I1) with L(1:I1-1, I2), +* skipping the first column +* + CALL SSWAP( I1-K1+1, A( I1, 1 ), LDA, + $ A( I2, 1 ), LDA ) + END IF + ELSE + IPIV( J+1 ) = J+1 + ENDIF +* +* Set A(J+1, J) = T(J+1, J) +* + A( J+1, K ) = WORK( 2 ) + IF( (A( J, K ).EQ.ZERO) .AND. + $ ( (J.EQ.M) .OR. (A( J+1, K ).EQ.ZERO)) ) THEN + IF (INFO .EQ. 0) + $ INFO = J + END IF +* + IF( J.LT.NB ) THEN +* +* Copy A(J+1:N, J+1) into H(J+1:N, J), +* + CALL SCOPY( M-J, A( J+1, K+1 ), 1, + $ H( J+1, J+1 ), 1 ) + END IF +* +* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), +* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) +* + IF( A( J+1, K ).NE.ZERO ) THEN + ALPHA = ONE / A( J+1, K ) + CALL SCOPY( M-J-1, WORK( 3 ), 1, A( J+2, K ), 1 ) + CALL SSCAL( M-J-1, ALPHA, A( J+2, K ), 1 ) + ELSE + CALL SLASET( 'Full', M-J-1, 1, ZERO, ZERO, + $ A( J+2, K ), LDA ) + END IF + ELSE + IF( (A( J, K ).EQ.ZERO) .AND. (INFO.EQ.0) ) THEN + INFO = J + END IF + END IF + J = J + 1 + GO TO 30 + 40 CONTINUE + END IF + RETURN +* +* End of SLASYF_AASEN +* + END diff --git a/SRC/ssysv_aasen.f b/SRC/ssysv_aasen.f new file mode 100644 index 0000000..52f507e --- /dev/null +++ b/SRC/ssysv_aasen.f @@ -0,0 +1,249 @@ +*> \brief SSYSV_AASEN computes the solution to system of linear equations A * X = B for SY matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYSV_AASEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYSV_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, +* LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYSV computes the solution to a real system of linear equations +*> A * X = B, +*> where A is an N-by-N symmetric matrix and X and B are N-by-NRHS +*> matrices. +*> +*> Aasen's algorithm is used to factor A as +*> A = U * T * U**T, if UPLO = 'U', or +*> A = L * T * L**T, if UPLO = 'L', +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and T is symmetric tridiagonal. 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 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. +*> +*> On exit, if INFO = 0, the tridiagonal matrix T and the +*> multipliers used to obtain the factor U or L from the +*> factorization A = U*T*U**T or A = L*T*L**T as computed by +*> SSYTRF. +*> \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) +*> On exit, it contains the details of the interchanges, i.e., +*> the row and column k of A were interchanged with the +*> row and column IPIV(k). +*> \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 >= MAX(2*N, 3*N-2), and for +*> the best performance, LWORK >= max(1,N*NB), where NB is +*> the optimal blocksize for SSYTRF_AASEN. +*> +*> 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,i) 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. +* +*> \date November 2016 +* +*> \ingroup realSYsolve +* +* @generated from dsysv_aasen.f, fortran d -> s, Mon Oct 3 01:04:05 2016 +* +* ===================================================================== + SUBROUTINE SSYSV_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* +* .. 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 + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SSYTRF, SSYTRS, SSYTRS2 +* .. +* .. 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.MAX(2*N, 3*N-2) .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF +* + IF( INFO.EQ.0 ) THEN + CALL SSYTRF( UPLO, N, A, LDA, IPIV, WORK, -1, INFO ) + LWKOPT = WORK(1) + LWKOPT = MAX( 3*N-2, LWKOPT ) + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYSV_AASEN', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = U*T*U**T or A = L*T*L**T. +* + CALL SSYTRF_AASEN( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* + CALL SSYTRS_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of SSYSV_AASEN +* + END diff --git a/SRC/ssytrf_aasen.f b/SRC/ssytrf_aasen.f new file mode 100644 index 0000000..ba39518 --- /dev/null +++ b/SRC/ssytrf_aasen.f @@ -0,0 +1,482 @@ +*> \brief \b SSYTRF_AASEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYTRF_AASEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYTRF_AASEN( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, LDA, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), WORK( * ) +* .. +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYTRF_AASEN computes the factorization of a real symmetric matrix A +*> using the Aasen's algorithm. The form of the factorization is +*> +*> A = U*T*U**T or A = L*T*L**T +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and T is a symmetric tridiagonal matrix. +*> +*> 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 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. +*> +*> On exit, the tridiagonal matrix is stored in the diagonals +*> and the subdiagonals of A just below (or above) the diagonals, +*> and L is stored below (or above) the subdiaonals, when UPLO +*> is 'L' (or 'U'). +*> \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) +*> On exit, it contains the details of the interchanges, i.e., +*> the row and column k of A were interchanged with the +*> row and column IPIV(k). +*> \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 >=2*N. For optimum performance +*> LWORK >= N*(1+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 +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2016 +* +*> \ingroup realSYcomputational +* +* @generated from dsytrf_aasen.f, fortran d -> s, Sun Oct 2 22:27:17 2016 +* +* ===================================================================== + SUBROUTINE SSYTRF_AASEN( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, LDA, LWORK, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER J, LWKOPT, IINFO + INTEGER NB, MJ, NJ, K1, K2, J1, J2, J3, JB + REAL ALPHA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Determine the block size +* + NB = ILAENV( 1, 'SSYTRF', UPLO, N, -1, -1, -1 ) +* +* 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.( 2*N ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN + LWKOPT = (NB+1)*N + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYTRF_AASEN', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return +* + IF ( N.EQ.0 ) THEN + RETURN + ENDIF + IPIV( 1 ) = 1 + IF ( N.EQ.1 ) THEN + IF ( A( 1, 1 ).EQ.ZERO ) THEN + INFO = 1 + END IF + RETURN + END IF +* +* Adjubst block size based on the workspace size +* + IF( LWORK.LT.((1+NB)*N) ) THEN + NB = ( LWORK-N ) / N + END IF +* + IF( UPPER ) THEN +* +* ..................................................... +* Factorize A as L*D*L**T using the upper triangle of A +* ..................................................... +* +* Copy first row A(1, 1:N) into H(1:n) (stored in WORK(1:N)) +* + CALL SCOPY( N, A( 1, 1 ), LDA, WORK( 1 ), 1 ) +* +* J is the main loop index, increasing from 1 to N in steps of +* JB, where JB is the number of columns factorized by SLASYF; +* JB is either NB, or N-J+1 for the last block +* + J = 0 + 10 CONTINUE + IF( J.GE.N ) + $ GO TO 20 +* +* each step of the main loop +* J is the last column of the previous panel +* J1 is the first column of the current panel +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 for the first panel, and +* K1=0 for the rest +* + J1 = J + 1 + JB = MIN( N-J1+1, NB ) + K1 = MAX(1, J)-J +* +* Panel factorization +* + CALL SLASYF_AASEN( UPLO, 2-K1, N-J, JB, + $ A( MAX(1, J), J+1 ), LDA, + $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), + $ IINFO ) + IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN + INFO = IINFO+J + ENDIF +* +* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot) +* + DO J2 = J+2, MIN(N, J+JB+1) + IPIV( J2 ) = IPIV( J2 ) + J + IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN + CALL SSWAP( J1-K1-2, A( 1, J2 ), 1, + $ A( 1, IPIV(J2) ), 1 ) + END IF + END DO + J = J + JB +* +* Trailing submatrix update, where +* the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and +* WORK stores the current block of the auxiriarly matrix H +* + IF( J.LT.N ) THEN +* +* If first panel and JB=1 (NB=1), then nothing to do +* + IF( J1.GT.1 .OR. JB.GT.1 ) THEN +* +* Merge rank-1 update with BLAS-3 update +* + ALPHA = A( J, J+1 ) + A( J, J+1 ) = ONE + CALL SCOPY( N-J, A( J-1, J+1 ), LDA, + $ WORK( (J+1-J1+1)+JB*N ), 1 ) + CALL SSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 ) +* +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 and K2= 0 for the first panel, +* while K1=0 and K2=1 for the rest +* + IF( J1.GT.1 ) THEN +* +* Not first panel +* + K2 = 1 + ELSE +* +* First panel +* + K2 = 0 +* +* First update skips the first column +* + JB = JB - 1 + END IF +* + DO J2 = J+1, N, NB + NJ = MIN( NB, N-J2+1 ) +* +* Update (J2, J2) diagonal block with SGEMV +* + J3 = J2 + DO MJ = NJ-1, 1, -1 + CALL SGEMV( 'No transpose', MJ, JB+1, + $ -ONE, WORK( J3-J1+1+K1*N ), N, + $ A( J1-K2, J3 ), 1, + $ ONE, A( J3, J3 ), LDA ) + J3 = J3 + 1 + END DO +* +* Update off-diagonal block of J2-th block row with SGEMM +* + CALL SGEMM( 'Transpose', 'Transpose', + $ NJ, N-J3+1, JB+1, + $ -ONE, A( J1-K2, J2 ), LDA, + $ WORK( J3-J1+1+K1*N ), N, + $ ONE, A( J2, J3 ), LDA ) + END DO +* +* Recover T( J, J+1 ) +* + A( J, J+1 ) = ALPHA + END IF +* +* WORK(J+1, 1) stores H(J+1, 1) +* + CALL SCOPY( N-J, A( J+1, J+1 ), LDA, WORK( 1 ), 1 ) + END IF + GO TO 10 + ELSE +* +* ..................................................... +* Factorize A as L*D*L**T using the lower triangle of A +* ..................................................... +* +* copy first column A(1:N, 1) into H(1:N, 1) +* (stored in WORK(1:N)) +* + CALL SCOPY( N, A( 1, 1 ), 1, WORK( 1 ), 1 ) +* +* J is the main loop index, increasing from 1 to N in steps of +* JB, where JB is the number of columns factorized by SLASYF; +* JB is either NB, or N-J+1 for the last block +* + J = 0 + 11 CONTINUE + IF( J.GE.N ) + $ GO TO 20 +* +* each step of the main loop +* J is the last column of the previous panel +* J1 is the first column of the current panel +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 for the first panel, and +* K1=0 for the rest +* + J1 = J+1 + JB = MIN( N-J1+1, NB ) + K1 = MAX(1, J)-J +* +* Panel factorization +* + CALL SLASYF_AASEN( UPLO, 2-K1, N-J, JB, + $ A( J+1, MAX(1, J) ), LDA, + $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), IINFO) + IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN + INFO = IINFO+J + ENDIF +* +* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot) +* + DO J2 = J+2, MIN(N, J+JB+1) + IPIV( J2 ) = IPIV( J2 ) + J + IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN + CALL SSWAP( J1-K1-2, A( J2, 1 ), LDA, + $ A( IPIV(J2), 1 ), LDA ) + END IF + END DO + J = J + JB +* +* Trailing submatrix update, where +* A(J2+1, J1-1) stores L(J2+1, J1) and +* WORK(J2+1, 1) stores H(J2+1, 1) +* + IF( J.LT.N ) THEN +* +* if first panel and JB=1 (NB=1), then nothing to do +* + IF( J1.GT.1 .OR. JB.GT.1 ) THEN +* +* Merge rank-1 update with BLAS-3 update +* + ALPHA = A( J+1, J ) + A( J+1, J ) = ONE + CALL SCOPY( N-J, A( J+1, J-1 ), 1, + $ WORK( (J+1-J1+1)+JB*N ), 1 ) + CALL SSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 ) +* +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 and K2= 0 for the first panel, +* while K1=0 and K2=1 for the rest +* + IF( J1.GT.1 ) THEN +* +* Not first panel +* + K2 = 1 + ELSE +* +* First panel +* + K2 = 0 +* +* First update skips the first column +* + JB = JB - 1 + END IF +* + DO J2 = J+1, N, NB + NJ = MIN( NB, N-J2+1 ) +* +* Update (J2, J2) diagonal block with SGEMV +* + J3 = J2 + DO MJ = NJ-1, 1, -1 + CALL SGEMV( 'No transpose', MJ, JB+1, + $ -ONE, WORK( J3-J1+1+K1*N ), N, + $ A( J3, J1-K2 ), LDA, + $ ONE, A( J3, J3 ), 1 ) + J3 = J3 + 1 + END DO +* +* Update off-diagonal block in J2-th block column with SGEMM +* + CALL SGEMM( 'No transpose', 'Transpose', + $ N-J3+1, NJ, JB+1, + $ -ONE, WORK( J3-J1+1+K1*N ), N, + $ A( J2, J1-K2 ), LDA, + $ ONE, A( J3, J2 ), LDA ) + END DO +* +* Recover T( J+1, J ) +* + A( J+1, J ) = ALPHA + END IF +* +* WORK(J+1, 1) stores H(J+1, 1) +* + CALL SCOPY( N-J, A( J+1, J+1 ), 1, WORK( 1 ), 1 ) + END IF + GO TO 11 + END IF +* + 20 CONTINUE + RETURN +* +* End of SSYTRF_AASEN +* + END diff --git a/SRC/ssytrs_aasen.f b/SRC/ssytrs_aasen.f new file mode 100644 index 0000000..05d7923 --- /dev/null +++ b/SRC/ssytrs_aasen.f @@ -0,0 +1,291 @@ +*> \brief \b SSYTRS_AASEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SSYTRS_AASEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SSYTRS_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYTRS_AASEN solves a system of linear equations A*X = B with a real +*> symmetric matrix A using the factorization A = U*T*U**T or +*> A = L*T*L**T computed by SSYTRF_AASEN. +*> \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*T*U**T; +*> = 'L': Lower triangular, form is A = L*T*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) +*> Details of factors computed by SSYTRF_AASEN. +*> \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 as computed by SSYTRF_AASEN. +*> \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[in] WORK +*> \verbatim +*> WORK is DOUBLE array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER, LWORK >= 3*N-2. +*> +*> \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. +* +*> \date November 2016 +* +*> \ingroup realSYcomputational +* +* @generated from dsytrs_aasen.f, fortran d -> s, Wed Sep 21 16:39:24 2016 +* +* ===================================================================== + SUBROUTINE SSYTRS_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER K, KP +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SGTSV, 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 + ELSE IF( LWORK.LT.(3*N-2) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYTRS_AASEN', -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*T*U**T. +* +* Pivot, P**T * B +* + K = 1 + DO WHILE ( K.LE.N ) + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K + 1 + END DO +* +* Compute (U \P**T * B) -> B [ (U \P**T * B) ] +* + CALL STRSM('L', 'U', 'T', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA, + $ B( 2, 1 ), LDB) +* +* Compute T \ B -> B [ T \ (U \P**T * B) ] +* + CALL SLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1) + IF( N.GT.1 ) THEN + CALL SLACPY( 'F', 1, N-1, A(1, 2), LDA+1, WORK(1), 1) + CALL SLACPY( 'F', 1, N-1, A(1, 2), LDA+1, WORK(2*N), 1) + END IF + CALL SGTSV(N, NRHS, WORK(1), WORK(N), WORK(2*N), B, LDB, + $ INFO) +* +* +* Compute (U**T \ B) -> B [ U**T \ (T \ (U \P**T * B) ) ] +* + CALL STRSM( 'L', 'U', 'N', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA, + $ B(2, 1), LDB) +* +* Pivot, P * B [ P * (U**T \ (T \ (U \P**T * B) )) ] +* + K = N + DO WHILE ( K.GE.1 ) + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K - 1 + END DO +* + ELSE +* +* Solve A*X = B, where A = L*T*L**T. +* +* Pivot, P**T * B +* + K = 1 + DO WHILE ( K.LE.N ) + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K + 1 + END DO +* +* Compute (L \P**T * B) -> B [ (L \P**T * B) ] +* + CALL STRSM( 'L', 'L', 'N', 'U', N-1, NRHS, ONE, A( 2, 1), LDA, + $ B(2, 1), LDB) +* +* Compute T \ B -> B [ T \ (L \P**T * B) ] +* + CALL SLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1) + IF( N.GT.1 ) THEN + CALL SLACPY( 'F', 1, N-1, A(2, 1), LDA+1, WORK(1), 1) + CALL SLACPY( 'F', 1, N-1, A(2, 1), LDA+1, WORK(2*N), 1) + END IF + CALL SGTSV(N, NRHS, WORK(1), WORK(N), WORK(2*N), B, LDB, + $ INFO) +* +* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ] +* + CALL STRSM( 'L', 'L', 'T', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA, + $ B( 2, 1 ), LDB) +* +* Pivot, P * B [ P * (L**T \ (T \ (L \P**T * B) )) ] +* + K = N + DO WHILE ( K.GE.1 ) + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + K = K - 1 + END DO +* + END IF +* + RETURN +* +* End of SSYTRS_AASEN +* + END diff --git a/SRC/zhesv_aasen.f b/SRC/zhesv_aasen.f new file mode 100644 index 0000000..2db9699 --- /dev/null +++ b/SRC/zhesv_aasen.f @@ -0,0 +1,251 @@ +*> \brief ZHESV_AASEN computes the solution to system of linear equations A * X = B for HE matrices +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHESV_AASEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHESV_AASEN( 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( * ) +* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHESV_AASEN computes the solution to a complex system of linear equations +*> A * X = B, +*> where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS +*> matrices. +*> +*> Aasen's algorithm is used to factor A as +*> A = U * T * U**H, if UPLO = 'U', or +*> A = L * T * L**H, if UPLO = 'L', +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and T is Hermitian and tridiagonal. 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 COMPLEX*16 array, dimension (LDA,N) +*> On entry, the Hermitian 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. +*> +*> On exit, if INFO = 0, the tridiagonal matrix T and the +*> multipliers used to obtain the factor U or L from the +*> factorization A = U*T*U**H or A = L*T*L**H as computed by +*> ZHETRF_AASEN. +*> \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) +*> On exit, it contains the details of the interchanges, i.e., +*> the row and column k of A were interchanged with the +*> row and column IPIV(k). +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 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 COMPLEX*16 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 +*> ZHETRF. +*> 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,i) 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. +* +*> \date November 2016 +* +*> \ingroup complex16HEsolve +* +* @precisions fortran z -> c +* +* ===================================================================== + SUBROUTINE ZHESV_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LWORK, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER LWKOPT, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZHETRF, ZHETRS, ZHETRS2 +* .. +* .. 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.MAX(2*N, 3*N-2) .AND. .NOT.LQUERY ) THEN + INFO = -10 + END IF +* + IF( INFO.EQ.0 ) THEN + NB = ILAENV( 1, 'ZHETRF_AASEN', UPLO, N, -1, -1, -1 ) + LWKOPT = MAX( 3*N-2, (1+NB)*N ) + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHESV_AASEN ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Compute the factorization A = U*T*U**H or A = L*T*L**H. +* + CALL ZHETRF_AASEN( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* + CALL ZHETRS_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, + $ LWORK, INFO ) +* + END IF +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of ZHESV_AASEN +* + END diff --git a/SRC/zhetrf_aasen.f b/SRC/zhetrf_aasen.f new file mode 100644 index 0000000..75d6951 --- /dev/null +++ b/SRC/zhetrf_aasen.f @@ -0,0 +1,485 @@ +*> \brief \b ZHETRF_AASEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHETRF_AASEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHETRF_AASEN( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, LDA, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHETRF_AASEN computes the factorization of a real hermitian matrix A +*> using the Aasen's algorithm. The form of the factorization is +*> +*> A = U*T*U**T or A = L*T*L**T +*> +*> where U (or L) is a product of permutation and unit upper (lower) +*> triangular matrices, and T is a hermitian tridiagonal matrix. +*> +*> 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 COMPLEX*16 array, dimension (LDA,N) +*> On entry, the hermitian 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. +*> +*> On exit, the tridiagonal matrix is stored in the diagonals +*> and the subdiagonals of A just below (or above) the diagonals, +*> and L is stored below (or above) the subdiaonals, when UPLO +*> is 'L' (or 'U'). +*> \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) +*> On exit, it contains the details of the interchanges, i.e., +*> the row and column k of A were interchanged with the +*> row and column IPIV(k). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 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 >= 2*N. For optimum performance +*> LWORK >= N*(1+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 +*> > 0: if INFO = i, D(i,i) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2016 +* +*> \ingroup complex16SYcomputational +* +* @precisions fortran z -> c +* +* ===================================================================== + SUBROUTINE ZHETRF_AASEN( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, LDA, LWORK, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), WORK( * ) +* .. +* +* ===================================================================== +* .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = (0.0D+0, 0.0D+0), ONE = (1.0D+0, 0.0D+0) ) +* +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER J, LWKOPT, IINFO + INTEGER NB, MJ, NJ, K1, K2, J1, J2, J3, JB + COMPLEX*16 ALPHA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCONJG, MAX +* .. +* .. Executable Statements .. +* +* Determine the block size +* + NB = ILAENV( 1, 'ZHETRF', UPLO, N, -1, -1, -1 ) +* +* 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.( 2*N ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN + LWKOPT = (NB+1)*N + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHETRF_AASEN', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return +* + IF ( N.EQ.0 ) THEN + RETURN + ENDIF + IPIV( 1 ) = 1 + IF ( N.EQ.1 ) THEN + A( 1, 1 ) = DBLE( A( 1, 1 ) ) + IF ( A( 1, 1 ).EQ.ZERO ) THEN + INFO = 1 + END IF + RETURN + END IF +* +* Adjubst block size based on the workspace size +* + IF( LWORK.LT.((1+NB)*N) ) THEN + NB = ( LWORK-N ) / N + END IF +* + IF( UPPER ) THEN +* +* ..................................................... +* Factorize A as L*D*L**T using the upper triangle of A +* ..................................................... +* +* copy first row A(1, 1:N) into H(1:n) (stored in WORK(1:N)) +* + CALL ZCOPY( N, A( 1, 1 ), LDA, WORK( 1 ), 1 ) +* +* J is the main loop index, increasing from 1 to N in steps of +* JB, where JB is the number of columns factorized by ZLAHEF; +* JB is either NB, or N-J+1 for the last block +* + J = 0 + 10 CONTINUE + IF( J.GE.N ) + $ GO TO 20 +* +* each step of the main loop +* J is the last column of the previous panel +* J1 is the first column of the current panel +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 for the first panel, and +* K1=0 for the rest +* + J1 = J + 1 + JB = MIN( N-J1+1, NB ) + K1 = MAX(1, J)-J +* +* Panel factorization +* + CALL ZLAHEF_AASEN( UPLO, 2-K1, N-J, JB, + $ A( MAX(1, J), J+1 ), LDA, + $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), + $ IINFO ) + IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN + INFO = IINFO+J + ENDIF +* +* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot) +* + DO J2 = J+2, MIN(N, J+JB+1) + IPIV( J2 ) = IPIV( J2 ) + J + IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN + CALL ZSWAP( J1-K1-2, A( 1, J2 ), 1, + $ A( 1, IPIV(J2) ), 1 ) + END IF + END DO + J = J + JB +* +* Trailing submatrix update, where +* the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and +* WORK stores the current block of the auxiriarly matrix H +* + IF( J.LT.N ) THEN +* +* if the first panel and JB=1 (NB=1), then nothing to do +* + IF( J1.GT.1 .OR. JB.GT.1 ) THEN +* +* Merge rank-1 update with BLAS-3 update +* + ALPHA = DCONJG( A( J, J+1 ) ) + A( J, J+1 ) = ONE + CALL ZCOPY( N-J, A( J-1, J+1 ), LDA, + $ WORK( (J+1-J1+1)+JB*N ), 1 ) + CALL ZSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 ) +* +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=0 and K2=1 for the first panel, +* and K1=1 and K2=0 for the rest +* + IF( J1.GT.1 ) THEN +* +* Not first panel +* + K2 = 1 + ELSE +* +* First panel +* + K2 = 0 +* +* First update skips the first column +* + JB = JB - 1 + END IF +* + DO J2 = J+1, N, NB + NJ = MIN( NB, N-J2+1 ) +* +* Update (J2, J2) diagonal block with ZGEMV +* + J3 = J2 + DO MJ = NJ-1, 1, -1 + CALL ZGEMM( 'Conjugate transpose', 'Transpose', + $ 1, MJ, JB+1, + $ -ONE, A( J1-K2, J3 ), LDA, + $ WORK( (J3-J1+1)+K1*N ), N, + $ ONE, A( J3, J3 ), LDA ) + J3 = J3 + 1 + END DO +* +* Update off-diagonal block of J2-th block row with ZGEMM +* + CALL ZGEMM( 'Conjugate transpose', 'Transpose', + $ NJ, N-J3+1, JB+1, + $ -ONE, A( J1-K2, J2 ), LDA, + $ WORK( (J3-J1+1)+K1*N ), N, + $ ONE, A( J2, J3 ), LDA ) + END DO +* +* Recover T( J, J+1 ) +* + A( J, J+1 ) = DCONJG( ALPHA ) + END IF +* +* WORK(J+1, 1) stores H(J+1, 1) +* + CALL ZCOPY( N-J, A( J+1, J+1 ), LDA, WORK( 1 ), 1 ) + END IF + GO TO 10 + ELSE +* +* ..................................................... +* Factorize A as L*D*L**T using the lower triangle of A +* ..................................................... +* +* copy first column A(1:N, 1) into H(1:N, 1) +* (stored in WORK(1:N)) +* + CALL ZCOPY( N, A( 1, 1 ), 1, WORK( 1 ), 1 ) +* +* J is the main loop index, increasing from 1 to N in steps of +* JB, where JB is the number of columns factorized by ZLAHEF; +* JB is either NB, or N-J+1 for the last block +* + J = 0 + 11 CONTINUE + IF( J.GE.N ) + $ GO TO 20 +* +* each step of the main loop +* J is the last column of the previous panel +* J1 is the first column of the current panel +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=1 for the first panel, and +* K1=0 for the rest +* + J1 = J+1 + JB = MIN( N-J1+1, NB ) + K1 = MAX(1, J)-J +* +* Panel factorization +* + CALL ZLAHEF_AASEN( UPLO, 2-K1, N-J, JB, + $ A( J+1, MAX(1, J) ), LDA, + $ IPIV( J+1 ), WORK, N, WORK( N*NB+1 ), IINFO) + IF( (IINFO.GT.0) .AND. (INFO.EQ.0) ) THEN + INFO = IINFO+J + ENDIF +* +* Ajust IPIV and apply it back (J-th step picks (J+1)-th pivot) +* + DO J2 = J+2, MIN(N, J+JB+1) + IPIV( J2 ) = IPIV( J2 ) + J + IF( (J2.NE.IPIV(J2)) .AND. ((J1-K1).GT.2) ) THEN + CALL ZSWAP( J1-K1-2, A( J2, 1 ), LDA, + $ A( IPIV(J2), 1 ), LDA ) + END IF + END DO + J = J + JB +* +* Trailing submatrix update, where +* A(J2+1, J1-1) stores L(J2+1, J1) and +* WORK(J2+1, 1) stores H(J2+1, 1) +* + IF( J.LT.N ) THEN +* +* if the first panel and JB=1 (NB=1), then nothing to do +* + IF( J1.GT.1 .OR. JB.GT.1 ) THEN +* +* Merge rank-1 update with BLAS-3 update +* + ALPHA = DCONJG( A( J+1, J ) ) + A( J+1, J ) = ONE + CALL ZCOPY( N-J, A( J+1, J-1 ), 1, + $ WORK( (J+1-J1+1)+JB*N ), 1 ) + CALL ZSCAL( N-J, ALPHA, WORK( (J+1-J1+1)+JB*N ), 1 ) +* +* K1 identifies if the previous column of the panel has been +* explicitly stored, e.g., K1=0 and K2=1 for the first panel, +* and K1=1 and K2=0 for the rest +* + IF( J1.GT.1 ) THEN +* +* Not first panel +* + K2 = 1 + ELSE +* +* First panel +* + K2 = 0 +* +* First update skips the first column +* + JB = JB - 1 + END IF +* + DO J2 = J+1, N, NB + NJ = MIN( NB, N-J2+1 ) +* +* Update (J2, J2) diagonal block with ZGEMV +* + J3 = J2 + DO MJ = NJ-1, 1, -1 + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ MJ, 1, JB+1, + $ -ONE, WORK( (J3-J1+1)+K1*N ), N, + $ A( J3, J1-K2 ), LDA, + $ ONE, A( J3, J3 ), LDA ) + J3 = J3 + 1 + END DO +* +* Update off-diagonal block of J2-th block column with ZGEMM +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ N-J3+1, NJ, JB+1, + $ -ONE, WORK( (J3-J1+1)+K1*N ), N, + $ A( J2, J1-K2 ), LDA, + $ ONE, A( J3, J2 ), LDA ) + END DO +* +* Recover T( J+1, J ) +* + A( J+1, J ) = DCONJG( ALPHA ) + END IF +* +* WORK(J+1, 1) stores H(J+1, 1) +* + CALL ZCOPY( N-J, A( J+1, J+1 ), 1, WORK( 1 ), 1 ) + END IF + GO TO 11 + END IF +* + 20 CONTINUE + RETURN +* +* End of ZHETRF_AASEN +* + END diff --git a/SRC/zhetrs_aasen.f b/SRC/zhetrs_aasen.f new file mode 100644 index 0000000..309f1e7 --- /dev/null +++ b/SRC/zhetrs_aasen.f @@ -0,0 +1,284 @@ +*> \brief \b ZHETRS_AASEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZHETRS_AASEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZHETRS_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, +* WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHETRS_AASEN solves a system of linear equations A*X = B with a real +*> hermitian matrix A using the factorization A = U*T*U**T or +*> A = L*T*L**T computed by ZHETRF_AASEN. +*> \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*T*U**T; +*> = 'L': Lower triangular, form is A = L*T*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 COMPLEX*16 array, dimension (LDA,N) +*> Details of factors computed by ZHETRF_AASEN. +*> \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 as computed by ZHETRF_AASEN. +*> \endverbatim +*> +*> \param[in,out] B +*> \verbatim +*> B is COMPLEX*16 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[in] WORK +*> \verbatim +*> WORK is DOUBLE array, dimension (MAX(1,LWORK)) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER, LWORK >= 3*N-2. +*> +*> \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. +* +*> \date November 2016 +* +*> \ingroup complex16SYcomputational +* +* @precisions fortran z -> c +* +* ===================================================================== + SUBROUTINE ZHETRS_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, NRHS, LDA, LDB, LWORK, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) +* .. +* +* ===================================================================== +* + COMPLEX*16 ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER K, KP +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZGTSV, ZSWAP, ZTRSM, 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 + ELSE IF( LWORK.LT.(3*N-2) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHETRS_AASEN', -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*T*U**T. +* +* Pivot, P**T * B +* + DO K = 1, N + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* +* Compute (U \P**T * B) -> B [ (U \P**T * B) ] +* + CALL ZTRSM('L', 'U', 'C', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA, + $ B( 2, 1 ), LDB) +* +* Compute T \ B -> B [ T \ (U \P**T * B) ] +* + CALL ZLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1) + IF( N.GT.1 ) THEN + CALL ZLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 2*N ), 1) + CALL ZLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 1 ), 1) + CALL ZLACGV( N-1, WORK( 1 ), 1 ) + END IF + CALL ZGTSV(N, NRHS, WORK(1), WORK(N), WORK(2*N), B, LDB, + $ INFO) +* +* Compute (U**T \ B) -> B [ U**T \ (T \ (U \P**T * B) ) ] +* + CALL ZTRSM( 'L', 'U', 'N', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA, + $ B(2, 1), LDB) +* +* Pivot, P * B [ P * (U**T \ (T \ (U \P**T * B) )) ] +* + DO K = N, 1, -1 + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* + ELSE +* +* Solve A*X = B, where A = L*T*L**T. +* +* Pivot, P**T * B +* + DO K = 1, N + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* +* Compute (L \P**T * B) -> B [ (L \P**T * B) ] +* + CALL ZTRSM( 'L', 'L', 'N', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA, + $ B(2, 1), LDB) +* +* Compute T \ B -> B [ T \ (L \P**T * B) ] +* + CALL ZLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1) + IF( N.GT.1 ) THEN + CALL ZLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 1 ), 1) + CALL ZLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 2*N ), 1) + CALL ZLACGV( N-1, WORK( 2*N ), 1 ) + END IF + CALL ZGTSV(N, NRHS, WORK(1), WORK(N), WORK(2*N), B, LDB, + $ INFO) +* +* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ] +* + CALL ZTRSM( 'L', 'L', 'C', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA, + $ B( 2, 1 ), LDB) +* +* Pivot, P * B [ P * (L**T \ (T \ (L \P**T * B) )) ] +* + DO K = N, 1, -1 + KP = IPIV( K ) + IF( KP.NE.K ) + $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) + END DO +* + END IF +* + RETURN +* +* End of ZHETRS_AASEN +* + END diff --git a/SRC/zlahef_aasen.f b/SRC/zlahef_aasen.f new file mode 100644 index 0000000..d85669e --- /dev/null +++ b/SRC/zlahef_aasen.f @@ -0,0 +1,515 @@ +*> \brief \b ZLAHEF_AASEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLAHEF_AASEN + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLAHEF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV, +* H, LDH, WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER J1, M, NB, LDA, LDH, INFO +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), H( LDH, * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLATRF_AASEN factorizes a panel of a real hermitian matrix A using +*> the Aasen's algorithm. The panel consists of a set of NB rows of A +*> when UPLO is U, or a set of NB columns when UPLO is L. +*> +*> In order to factorize the panel, the Aasen's algorithm requires the +*> last row, or column, of the previous panel. The first row, or column, +*> of A is set to be the first row, or column, of an identity matrix, +*> which is used to factorize the first panel. +*> +*> The resulting J-th row of U, or J-th column of L, is stored in the +*> (J-1)-th row, or column, of A (without the unit diatonals), while +*> the diagonal and subdiagonal of A are overwritten by those of 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] J1 +*> \verbatim +*> J1 is INTEGER +*> The location of the first row, or column, of the panel +*> within the submatrix of A, passed to this routine, e.g., +*> when called by ZHETRF_AASEN, for the first panel, J1 is 1, +*> while for the remaining panels, J1 is 2. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The dimension of the submatrix. M >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The dimension of the panel to be facotorized. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,M) for +*> the first panel, while dimension (LDA,M+1) for the +*> remaining panels. +*> +*> On entry, A contains the last row, or column, of +*> the previous panel, and the trailing submatrix of A +*> to be factorized, except for the first panel, only +*> the panel is passed. +*> +*> On exit, the leading panel is factorized. +*> \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 row and column interchanges, +*> the row and column k were interchanged with the row and +*> column IPIV(k). +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is COMPLEX*16 workspace, dimension (LDH,NB). +*> +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> The leading dimension of the workspace H. LDH >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 workspace, dimension (M). +*> \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) is exactly zero. The factorization +*> has been completed, but the block diagonal matrix D is +*> exactly singular, and division by zero will occur if it +*> is used to solve a system of equations. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2016 +* +*> \ingroup complex16SYcomputational +* +* @precisions fortran z -> c +* +* ===================================================================== + SUBROUTINE ZLAHEF_AASEN( UPLO, J1, M, NB, A, LDA, IPIV, + $ H, LDH, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER M, NB, J1, LDA, LDH, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), H( LDH, * ), WORK( * ) +* .. +* +* ===================================================================== +* .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = (0.0D+0, 0.0D+0), ONE = (1.0D+0, 0.0D+0) ) +* +* .. Local Scalars .. + INTEGER J, K, K1, I1, I2 + COMPLEX*16 PIV, ALPHA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IZAMAX, ILAENV + EXTERNAL LSAME, ILAENV, IZAMAX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCONJG, MAX +* .. +* .. Executable Statements .. +* + INFO = 0 + J = 1 +* +* K1 is the first column of the panel to be factorized +* i.e., K1 is 2 for the first block column, and 1 for the rest of the blocks +* + K1 = (2-J1)+1 +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* ..................................................... +* Factorize A as U**T*D*U using the upper triangle of A +* ..................................................... +* + 10 CONTINUE + IF ( J.GT.MIN(M, NB) ) + $ GO TO 20 +* +* K is the column to be factorized +* when being called from ZHETRF_AASEN, +* > for the first block column, J1 is 1, hence J1+J-1 is J, +* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, +* + K = J1+J-1 +* +* H(J:N, J) := A(J, J:N) - H(J:N, 1:(J-1)) * L(J1:(J-1), J), +* where H(J:N, J) has been initialized to be A(J, J:N) +* + IF( K.GT.2 ) THEN +* +* K is the column to be factorized +* > for the first block column, K is J, skipping the first two +* columns +* > for the rest of the columns, K is J+1, skipping only the +* first column +* + CALL ZLACGV( J-K1, A( 1, J ), 1 ) + CALL ZGEMV( 'No transpose', M-J+1, J-K1, + $ -ONE, H( J, K1 ), LDH, + $ A( 1, J ), 1, + $ ONE, H( J, J ), 1 ) + CALL ZLACGV( J-K1, A( 1, J ), 1 ) + END IF +* +* Copy H(i:n, i) into WORK +* + CALL ZCOPY( M-J+1, H( J, J ), 1, WORK( 1 ), 1 ) +* + IF( J.GT.K1 ) THEN +* +* Compute WORK := WORK - L(J-1, J:N) * T(J-1,J), +* where A(J-1, J) stores T(J-1, J) and A(J-2, J:N) stores U(J-1, J:N) +* + ALPHA = -DCONJG( A( K-1, J ) ) + CALL ZAXPY( M-J+1, ALPHA, A( K-2, J ), LDA, WORK( 1 ), 1 ) + END IF +* +* Set A(J, J) = T(J, J) +* + A( K, J ) = DBLE( WORK( 1 ) ) +* + IF( J.LT.M ) THEN +* +* Compute WORK(2:N) = T(J, J) L(J, (J+1):N) +* where A(J, J) stores T(J, J) and A(J-1, (J+1):N) stores U(J, (J+1):N) +* + IF( (J1+J-1).GT.1 ) THEN + ALPHA = -A( K, J ) + CALL ZAXPY( M-J, ALPHA, A( K-1, J+1 ), LDA, + $ WORK( 2 ), 1 ) + ENDIF +* +* Find max(|WORK(2:n)|) +* + I2 = IZAMAX( M-J, WORK( 2 ), 1 ) + 1 + PIV = WORK( I2 ) +* +* Apply hermitian pivot +* + IF( (I2.NE.2) .AND. (PIV.NE.0) ) THEN +* +* Swap WORK(I1) and WORK(I2) +* + I1 = 2 + WORK( I2 ) = WORK( I1 ) + WORK( I1 ) = PIV +* +* Swap A(I1, I1+1:N) with A(I1+1:N, I2) +* + I1 = I1+J-1 + I2 = I2+J-1 + CALL ZSWAP( I2-I1-1, A( J1+I1-1, I1+1 ), LDA, + $ A( J1+I1, I2 ), 1 ) + CALL ZLACGV( I2-I1, A( J1+I1-1, I1+1 ), LDA ) + CALL ZLACGV( I2-I1-1, A( J1+I1, I2 ), 1 ) +* +* Swap A(I1, I2+1:N) with A(I2, I2+1:N) +* + CALL ZSWAP( M-I2, A( J1+I1-1, I2+1 ), LDA, + $ A( J1+I2-1, I2+1 ), LDA ) +* +* Swap A(I1, I1) with A(I2,I2) +* + PIV = A( I1+J1-1, I1 ) + A( J1+I1-1, I1 ) = A( J1+I2-1, I2 ) + A( J1+I2-1, I2 ) = PIV +* +* Swap H(I1, 1:J1) with H(I2, 1:J1) +* + CALL ZSWAP( I1-1, H( I1, 1 ), LDH, H( I2, 1 ), LDH ) + IPIV( I1 ) = I2 +* + IF( I1.GT.(K1-1) ) THEN +* +* Swap L(1:I1-1, I1) with L(1:I1-1, I2), +* skipping the first column +* + CALL ZSWAP( I1-K1+1, A( 1, I1 ), 1, + $ A( 1, I2 ), 1 ) + END IF + ELSE + IPIV( J+1 ) = J+1 + ENDIF +* +* Set A(J, J+1) = T(J, J+1) +* + A( K, J+1 ) = WORK( 2 ) + IF( (A( K, J ).EQ.ZERO ) .AND. + $ ( (J.EQ.M) .OR. (A( K, J+1 ).EQ.ZERO))) THEN + IF(INFO .EQ. 0) THEN + INFO = J + END IF + END IF +* + IF( J.LT.NB ) THEN +* +* Copy A(J+1:N, J+1) into H(J:N, J), +* + CALL ZCOPY( M-J, A( K+1, J+1 ), LDA, + $ H( J+1, J+1 ), 1 ) + END IF +* +* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), +* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) +* + IF( A( K, J+1 ).NE.ZERO ) THEN + ALPHA = ONE / A( K, J+1 ) + CALL ZCOPY( M-J-1, WORK( 3 ), 1, A( K, J+2 ), LDA ) + CALL ZSCAL( M-J-1, ALPHA, A( K, J+2 ), LDA ) + ELSE + CALL ZLASET( 'Full', 1, M-J-1, ZERO, ZERO, + $ A( K, J+2 ), LDA) + END IF + ELSE + IF( (A( K, J ).EQ.ZERO) .AND. (INFO.EQ.0) ) THEN + INFO = J + END IF + END IF + J = J + 1 + GO TO 10 + 20 CONTINUE +* + ELSE +* +* ..................................................... +* Factorize A as L*D*L**T using the lower triangle of A +* ..................................................... +* + 30 CONTINUE + IF( J.GT.MIN( M, NB ) ) + $ GO TO 40 +* +* K is the column to be factorized +* when being called from ZHETRF_AASEN, +* > for the first block column, J1 is 1, hence J1+J-1 is J, +* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, +* + K = J1+J-1 +* +* H(J:N, J) := A(J:N, J) - H(J:N, 1:(J-1)) * L(J, J1:(J-1))^T, +* where H(J:N, J) has been initialized to be A(J:N, J) +* + IF( K.GT.2 ) THEN +* +* K is the column to be factorized +* > for the first block column, K is J, skipping the first two +* columns +* > for the rest of the columns, K is J+1, skipping only the +* first column +* + CALL ZLACGV( J-K1, A( J, 1 ), LDA ) + CALL ZGEMV( 'No transpose', M-J+1, J-K1, + $ -ONE, H( J, K1 ), LDH, + $ A( J, 1 ), LDA, + $ ONE, H( J, J ), 1 ) + CALL ZLACGV( J-K1, A( J, 1 ), LDA ) + END IF +* +* Copy H(J:N, J) into WORK +* + CALL ZCOPY( M-J+1, H( J, J ), 1, WORK( 1 ), 1 ) +* + IF( J.GT.K1 ) THEN +* +* Compute WORK := WORK - L(J:N, J-1) * T(J-1,J), +* where A(J-1, J) = T(J-1, J) and A(J, J-2) = L(J, J-1) +* + ALPHA = -DCONJG( A( J, K-1 ) ) + CALL ZAXPY( M-J+1, ALPHA, A( J, K-2 ), 1, WORK( 1 ), 1 ) + END IF +* +* Set A(J, J) = T(J, J) +* + A( J, K ) = DBLE( WORK( 1 ) ) +* + IF( J.LT.M ) THEN +* +* Compute WORK(2:N) = T(J, J) L((J+1):N, J) +* where A(J, J) = T(J, J) and A((J+1):N, J-1) = L((J+1):N, J) +* + IF( (J1+J-1).GT.1 ) THEN + ALPHA = -A( J, K ) + CALL ZAXPY( M-J, ALPHA, A( J+1, K-1 ), 1, + $ WORK( 2 ), 1 ) + ENDIF +* +* Find max(|WORK(2:n)|) +* + I2 = IZAMAX( M-J, WORK( 2 ), 1 ) + 1 + PIV = WORK( I2 ) +* +* Apply hermitian pivot +* + IF( (I2.NE.2) .AND. (PIV.NE.0) ) THEN +* +* Swap WORK(I1) and WORK(I2) +* + I1 = 2 + WORK( I2 ) = WORK( I1 ) + WORK( I1 ) = PIV +* +* Swap A(I1+1:N, I1) with A(I2, I1+1:N) +* + I1 = I1+J-1 + I2 = I2+J-1 + CALL ZSWAP( I2-I1-1, A( I1+1, J1+I1-1 ), 1, + $ A( I2, J1+I1 ), LDA ) + CALL ZLACGV( I2-I1, A( I1+1, J1+I1-1 ), 1 ) + CALL ZLACGV( I2-I1-1, A( I2, J1+I1 ), LDA ) +* +* Swap A(I2+1:N, I1) with A(I2+1:N, I2) +* + CALL ZSWAP( M-I2, A( I2+1, J1+I1-1 ), 1, + $ A( I2+1, J1+I2-1 ), 1 ) +* +* Swap A(I1, I1) with A(I2, I2) +* + PIV = A( I1, J1+I1-1 ) + A( I1, J1+I1-1 ) = A( I2, J1+I2-1 ) + A( I2, J1+I2-1 ) = PIV +* +* Swap H(I1, I1:J1) with H(I2, I2:J1) +* + CALL ZSWAP( I1-1, H( I1, 1 ), LDH, H( I2, 1 ), LDH ) + IPIV( I1 ) = I2 +* + IF( I1.GT.(K1-1) ) THEN +* +* Swap L(1:I1-1, I1) with L(1:I1-1, I2), +* skipping the first column +* + CALL ZSWAP( I1-K1+1, A( I1, 1 ), LDA, + $ A( I2, 1 ), LDA ) + END IF + ELSE + IPIV( J+1 ) = J+1 + ENDIF +* +* Set A(J+1, J) = T(J+1, J) +* + A( J+1, K ) = WORK( 2 ) + IF( (A( J, K ).EQ.ZERO) .AND. + $ ( (J.EQ.M) .OR. (A( J+1, K ).EQ.ZERO)) ) THEN + IF (INFO .EQ. 0) + $ INFO = J + END IF +* + IF( J.LT.NB ) THEN +* +* Copy A(J+1:N, J+1) into H(J+1:N, J), +* + CALL ZCOPY( M-J, A( J+1, K+1 ), 1, + $ H( J+1, J+1 ), 1 ) + END IF +* +* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), +* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) +* + IF( A( J+1, K ).NE.ZERO ) THEN + ALPHA = ONE / A( J+1, K ) + CALL ZCOPY( M-J-1, WORK( 3 ), 1, A( J+2, K ), 1 ) + CALL ZSCAL( M-J-1, ALPHA, A( J+2, K ), 1 ) + ELSE + CALL ZLASET( 'Full', M-J-1, 1, ZERO, ZERO, + $ A( J+2, K ), LDA ) + END IF + ELSE + IF( (A( J, K ).EQ.ZERO) .AND. (J.EQ.M) + $ .AND. (INFO.EQ.0) ) INFO = J + END IF + J = J + 1 + GO TO 30 + 40 CONTINUE + END IF + RETURN +* +* End of ZLAHEF_AASEN +* + END diff --git a/TESTING/LIN/CMakeLists.txt b/TESTING/LIN/CMakeLists.txt index a924b12..b832097 100644 --- a/TESTING/LIN/CMakeLists.txt +++ b/TESTING/LIN/CMakeLists.txt @@ -10,10 +10,10 @@ 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 schkql.f schkqr.f schkrq.f - schksp.f schksy.f schksy_rook.f schktb.f schktp.f schktr.f + schksp.f schksy.f schksy_rook.f schksy_aasen.f schktb.f schktp.f schktr.f schktz.f sdrvgt.f sdrvls.f sdrvpb.f - sdrvpp.f sdrvpt.f sdrvsp.f sdrvsy.f sdrvsy_rook.f + sdrvpp.f sdrvpt.f sdrvsp.f sdrvsy.f sdrvsy_rook.f sdrvsy_aasen.f serrgt.f serrlq.f serrls.f serrpo.f serrps.f serrql.f serrqp.f serrqr.f serrrq.f serrsy.f serrtr.f serrtz.f serrvx.f @@ -29,7 +29,7 @@ set(SLINTST schkaa.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 + sspt01.f ssyt01.f ssyt01_rook.f ssyt01_aasen.f stbt02.f stbt03.f stbt05.f stbt06.f stpt01.f stpt02.f stpt03.f stpt05.f stpt06.f strt01.f strt02.f strt03.f strt05.f strt06.f @@ -44,11 +44,11 @@ endif() set(CLINTST cchkaa.f cchkeq.f cchkgb.f cchkge.f cchkgt.f - cchkhe.f cchkhe_rook.f cchkhp.f cchklq.f cchkpb.f + cchkhe.f cchkhe_rook.f cchkhe_aasen.f cchkhp.f cchklq.f cchkpb.f cchkpo.f cchkps.f cchkpp.f cchkpt.f cchkq3.f cchkql.f cchkqr.f cchkrq.f cchksp.f cchksy.f cchksy_rook.f cchktb.f cchktp.f cchktr.f cchktz.f - cdrvgt.f cdrvhe.f cdrvhe_rook.f cdrvhp.f + cdrvgt.f cdrvhe.f cdrvhe_rook.f cdrvhe_aasen.f cdrvhp.f cdrvls.f cdrvpb.f cdrvpp.f cdrvpt.f cdrvsp.f cdrvsy.f cdrvsy_rook.f cerrgt.f cerrhe.f cerrlq.f @@ -58,7 +58,7 @@ set(CLINTST cchkaa.f cgbt01.f cgbt02.f cgbt05.f cgelqs.f cgeqls.f cgeqrs.f cgerqs.f cget01.f cget02.f cget03.f cget04.f cget07.f cgtt01.f cgtt02.f - cgtt05.f chet01.f chet01_rook.f chpt01.f claipd.f claptm.f clarhs.f clatb4.f clatb5.f + cgtt05.f chet01.f chet01_rook.f chet01_aasen.f chpt01.f claipd.f claptm.f clarhs.f clatb4.f clatb5.f clatsp.f clatsy.f clattb.f clattp.f clattr.f clavhe.f clavhe_rook.f clavhp.f clavsp.f clavsy.f clavsy_rook.f clqt01.f clqt02.f clqt03.f cpbt01.f cpbt02.f cpbt05.f @@ -87,10 +87,10 @@ 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 dchkql.f dchkqr.f dchkrq.f - dchksp.f dchksy.f dchksy_rook.f dchktb.f dchktp.f dchktr.f + dchksp.f dchksy.f dchksy_rook.f dchksy_aasen.f dchktb.f dchktp.f dchktr.f dchktz.f ddrvgt.f ddrvls.f ddrvpb.f - ddrvpp.f ddrvpt.f ddrvsp.f ddrvsy.f ddrvsy_rook.f + ddrvpp.f ddrvpt.f ddrvsp.f ddrvsy.f ddrvsy_rook.f ddrvsy_aasen.f derrgt.f derrlq.f derrls.f derrps.f derrql.f derrqp.f derrqr.f derrrq.f derrsy.f derrtr.f derrtz.f derrvx.f @@ -106,7 +106,7 @@ set(DLINTST dchkaa.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 + dspt01.f dsyt01.f dsyt01_rook.f dsyt01_aasen.f dtbt02.f dtbt03.f dtbt05.f dtbt06.f dtpt01.f dtpt02.f dtpt03.f dtpt05.f dtpt06.f dtrt01.f dtrt02.f dtrt03.f dtrt05.f dtrt06.f @@ -123,11 +123,11 @@ endif() set(ZLINTST zchkaa.f zchkeq.f zchkgb.f zchkge.f zchkgt.f - zchkhe.f zchkhe_rook.f zchkhp.f zchklq.f zchkpb.f + zchkhe.f zchkhe_rook.f zchkhe_aasen.f zchkhp.f zchklq.f zchkpb.f zchkpo.f zchkps.f zchkpp.f zchkpt.f zchkq3.f zchkql.f zchkqr.f zchkrq.f zchksp.f zchksy.f zchksy_rook.f zchktb.f zchktp.f zchktr.f zchktz.f - zdrvgt.f zdrvhe.f zdrvhe_rook.f zdrvhp.f + zdrvgt.f zdrvhe.f zdrvhe_rook.f zdrvhe_aasen.f zdrvhp.f zdrvls.f zdrvpb.f zdrvpp.f zdrvpt.f zdrvsp.f zdrvsy.f zdrvsy_rook.f zerrgt.f zerrhe.f zerrlq.f @@ -137,7 +137,7 @@ set(ZLINTST zchkaa.f zgbt01.f zgbt02.f zgbt05.f zgelqs.f zgeqls.f zgeqrs.f zgerqs.f zget01.f zget02.f zget03.f zget04.f zget07.f zgtt01.f zgtt02.f - zgtt05.f zhet01.f zhet01.f zhet01_rook.f zhpt01.f zlaipd.f zlaptm.f zlarhs.f zlatb4.f zlatb5.f + zgtt05.f zhet01.f zhet01.f zhet01_rook.f zhet01_aasen.f zhpt01.f zlaipd.f zlaptm.f zlarhs.f zlatb4.f zlatb5.f zlatsp.f zlatsy.f zlattb.f zlattp.f zlattr.f zlavhe.f zlavhe_rook.f zlavhp.f zlavsp.f zlavsy.f zlavsy_rook.f zlqt01.f zlqt02.f zlqt03.f zpbt01.f zpbt02.f zpbt05.f diff --git a/TESTING/LIN/Makefile b/TESTING/LIN/Makefile index 57d4fe2..3232f0f 100644 --- a/TESTING/LIN/Makefile +++ b/TESTING/LIN/Makefile @@ -51,10 +51,10 @@ 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 schkql.o schkqr.o schkrq.o \ - schksp.o schksy.o schksy_rook.o schktb.o schktp.o schktr.o \ + schksp.o schksy.o schksy_rook.o schksy_aasen.o schktb.o schktp.o schktr.o \ schktz.o \ sdrvgt.o sdrvls.o sdrvpb.o \ - sdrvpp.o sdrvpt.o sdrvsp.o sdrvsy_rook.o\ + sdrvpp.o sdrvpt.o sdrvsp.o sdrvsy_rook.o sdrvsy_aasen.o\ serrgt.o serrlq.o serrls.o \ serrps.o serrql.o serrqp.o serrqr.o \ serrrq.o serrtr.o serrtz.o \ @@ -70,7 +70,7 @@ SLINTST = schkaa.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 \ + sspt01.o ssyt01.o ssyt01_rook.o ssyt01_aasen.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 \ @@ -86,11 +86,11 @@ endif CLINTST = cchkaa.o \ cchkeq.o cchkgb.o cchkge.o cchkgt.o \ - cchkhe.o cchkhe_rook.o cchkhp.o cchklq.o cchkpb.o \ + cchkhe.o cchkhe_rook.o cchkhe_aasen.o cchkhp.o cchklq.o cchkpb.o \ cchkpo.o cchkps.o cchkpp.o cchkpt.o cchkq3.o cchkql.o \ cchkqr.o cchkrq.o cchksp.o cchksy.o cchksy_rook.o cchktb.o \ cchktp.o cchktr.o cchktz.o \ - cdrvgt.o cdrvhe_rook.o cdrvhp.o \ + cdrvgt.o cdrvhe_rook.o cdrvhe_aasen.o cdrvhp.o \ cdrvls.o cdrvpb.o cdrvpp.o cdrvpt.o \ cdrvsp.o cdrvsy_rook.o \ cerrgt.o cerrlq.o \ @@ -99,7 +99,7 @@ CLINTST = cchkaa.o \ cgbt01.o cgbt02.o cgbt05.o cgelqs.o cgeqls.o cgeqrs.o \ cgerqs.o cget01.o cget02.o \ cget03.o cget04.o cget07.o cgtt01.o cgtt02.o \ - cgtt05.o chet01.o chet01_rook.o chpt01.o claipd.o claptm.o clarhs.o clatb4.o clatb5.o \ + cgtt05.o chet01.o chet01_rook.o chet01_aasen.o chpt01.o claipd.o claptm.o clarhs.o clatb4.o clatb5.o \ clatsp.o clatsy.o clattb.o clattp.o clattr.o \ clavhe.o clavhe_rook.o clavhp.o clavsp.o clavsy.o clavsy_rook.o clqt01.o \ clqt02.o clqt03.o cpbt01.o cpbt02.o cpbt05.o \ @@ -129,10 +129,10 @@ 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 dchkql.o dchkqr.o dchkrq.o \ - dchksp.o dchksy.o dchksy_rook.o dchktb.o dchktp.o dchktr.o \ + dchksp.o dchksy.o dchksy_rook.o dchksy_aasen.o dchktb.o dchktp.o dchktr.o \ dchktz.o \ ddrvgt.o ddrvls.o ddrvpb.o \ - ddrvpp.o ddrvpt.o ddrvsp.o ddrvsy_rook.o \ + ddrvpp.o ddrvpt.o ddrvsp.o ddrvsy_rook.o ddrvsy_aasen.o\ derrgt.o derrlq.o derrls.o \ derrps.o derrql.o derrqp.o derrqr.o \ derrrq.o derrtr.o derrtz.o \ @@ -148,7 +148,7 @@ DLINTST = dchkaa.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 \ + dspt01.o dsyt01.o dsyt01_rook.o dsyt01_aasen.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 \ @@ -165,11 +165,11 @@ endif ZLINTST = zchkaa.o \ zchkeq.o zchkgb.o zchkge.o zchkgt.o \ - zchkhe.o zchkhe_rook.o zchkhp.o zchklq.o zchkpb.o \ + zchkhe.o zchkhe_rook.o zchkhe_aasen.o zchkhp.o zchklq.o zchkpb.o \ zchkpo.o zchkps.o zchkpp.o zchkpt.o zchkq3.o zchkql.o \ zchkqr.o zchkrq.o zchksp.o zchksy.o zchksy_rook.o zchktb.o \ zchktp.o zchktr.o zchktz.o \ - zdrvgt.o zdrvhe_rook.o zdrvhp.o \ + zdrvgt.o zdrvhe_rook.o zdrvhe_aasen.o zdrvhp.o \ zdrvls.o zdrvpb.o zdrvpp.o zdrvpt.o \ zdrvsp.o zdrvsy_rook.o \ zerrgt.o zerrlq.o \ @@ -178,7 +178,7 @@ ZLINTST = zchkaa.o \ zgbt01.o zgbt02.o zgbt05.o zgelqs.o zgeqls.o zgeqrs.o \ zgerqs.o zget01.o zget02.o \ zget03.o zget04.o zget07.o zgtt01.o zgtt02.o \ - zgtt05.o zhet01.o zhet01_rook.o zhpt01.o zlaipd.o zlaptm.o zlarhs.o zlatb4.o zlatb5.o \ + zgtt05.o zhet01.o zhet01_rook.o zhet01_aasen.o zhpt01.o zlaipd.o zlaptm.o zlarhs.o zlatb4.o zlatb5.o \ zlatsp.o zlatsy.o zlattb.o zlattp.o zlattr.o \ zlavhe.o zlavhe_rook.o zlavhp.o zlavsp.o zlavsy.o zlavsy_rook.o zlqt01.o \ zlqt02.o zlqt03.o zpbt01.o zpbt02.o zpbt05.o \ diff --git a/TESTING/LIN/aladhd.f b/TESTING/LIN/aladhd.f index b2bb2e0..3a53e0b 100644 --- a/TESTING/LIN/aladhd.f +++ b/TESTING/LIN/aladhd.f @@ -53,6 +53,8 @@ *> with "rook" (bounded Bunch-Kaufman) pivoting *> _SP: Symmetric indefinite packed, *> with partial (Bunch-Kaufman) pivoting +*> _HA: (complex) Hermitian , +*> Assen Algorithm *> _HE: (complex) Hermitian indefinite, *> with partial (Bunch-Kaufman) pivoting *> _HR: (complex) Hermitian indefinite, @@ -275,7 +277,27 @@ WRITE( IOUNIT, FMT = 9979 )3 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * - ELSE IF( LSAMEN( 2, P2, 'HE' ) .OR. LSAMEN( 2, P2, 'HP' ) ) THEN + ELSE IF( LSAMEN( 2, P2, 'HA' ) ) THEN +* +* HA: Hermitian +* Aasen algorithm + WRITE( IOUNIT, FMT = 9971 )PATH, 'Hermitian' +* + WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) + WRITE( IOUNIT, FMT = 9983 ) +* + WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) + WRITE( IOUNIT, FMT = 9974 )1 + WRITE( IOUNIT, FMT = 9980 )2 + WRITE( IOUNIT, FMT = 9979 )3 + WRITE( IOUNIT, FMT = 9977 )4 + WRITE( IOUNIT, FMT = 9978 )5 + WRITE( IOUNIT, FMT = 9976 )6 + WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) + + + ELSE IF( LSAMEN( 2, P2, 'HE' ) .OR. + $ LSAMEN( 2, P2, 'HP' ) ) THEN * * HE: Hermitian indefinite full * with partial (Bunch-Kaufman) pivoting algorithm @@ -336,6 +358,8 @@ $ ' positive definite band matrices' ) 9993 FORMAT( / 1X, A3, ' drivers: ', A9, $ ' positive definite tridiagonal' ) + 9971 FORMAT( / 1X, A3, ' drivers: ', A9, ' indefinite matrices', + $ ', "Aasen" Algorithm' ) 9992 FORMAT( / 1X, A3, ' drivers: ', A9, ' indefinite matrices', $ ', "rook" (bounded Bunch-Kaufman) pivoting' ) 9991 FORMAT( / 1X, A3, ' drivers: ', A9, diff --git a/TESTING/LIN/alaerh.f b/TESTING/LIN/alaerh.f index 2f45b1d..4fec452 100644 --- a/TESTING/LIN/alaerh.f +++ b/TESTING/LIN/alaerh.f @@ -490,6 +490,7 @@ ELSE IF( LSAMEN( 2, P2, 'SY' ) $ .OR. LSAMEN( 2, P2, 'SR' ) $ .OR. LSAMEN( 2, P2, 'HE' ) + $ .OR. LSAMEN( 2, P2, 'HA' ) $ .OR. LSAMEN( 2, P2, 'HR' ) ) THEN * * xSY: symmetric indefinite matrices @@ -498,6 +499,8 @@ * with rook (bounded Bunch-Kaufman) pivoting; * xHE: Hermitian indefinite matrices * with partial (Bunch-Kaufman) pivoting. +* xHA: Hermitian matrices +* Aasen Algorithm * xHR: Hermitian indefinite matrices * with rook (bounded Bunch-Kaufman) pivoting; * diff --git a/TESTING/LIN/alahd.f b/TESTING/LIN/alahd.f index 8d56c79..995a544 100644 --- a/TESTING/LIN/alahd.f +++ b/TESTING/LIN/alahd.f @@ -53,6 +53,8 @@ *> with "rook" (bounded Bunch-Kaufman) pivoting *> _SP: Symmetric indefinite packed, *> with partial (Bunch-Kaufman) pivoting +*> _HA: (complex) Hermitian , +*> with Aasen Algorithm *> _HE: (complex) Hermitian indefinite, *> with partial (Bunch-Kaufman) pivoting *> _HR: Symmetric indefinite, @@ -355,6 +357,28 @@ WRITE( IOUNIT, FMT = 9955 )8 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * + ELSE IF( LSAMEN( 2, P2, 'HA' ) ) THEN +* +* HA: Hermitian, +* with Assen Algorithm +* + WRITE( IOUNIT, FMT = 9992 )PATH, 'Hermitian' +* + WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) + WRITE( IOUNIT, FMT = 9972 ) +* + WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) + WRITE( IOUNIT, FMT = 9953 )1 + WRITE( IOUNIT, FMT = 9961 )2 + WRITE( IOUNIT, FMT = 9960 )3 + WRITE( IOUNIT, FMT = 9960 )4 + WRITE( IOUNIT, FMT = 9959 )5 + WRITE( IOUNIT, FMT = 9958 )6 + WRITE( IOUNIT, FMT = 9956 )7 + WRITE( IOUNIT, FMT = 9957 )8 + WRITE( IOUNIT, FMT = 9955 )9 + WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) +* ELSE IF( LSAMEN( 2, P2, 'HE' ) ) THEN * * HE: Hermitian indefinite full, diff --git a/TESTING/LIN/cchkaa.f b/TESTING/LIN/cchkaa.f index 8a97fbb..1f8b2c6 100644 --- a/TESTING/LIN/cchkaa.f +++ b/TESTING/LIN/cchkaa.f @@ -51,6 +51,7 @@ *> CPT 12 List types on next line if 0 < NTYPES < 12 *> CHE 10 List types on next line if 0 < NTYPES < 10 *> CHR 10 List types on next line if 0 < NTYPES < 10 +*> CHA 10 List types on next line if 0 < NTYPES < 10 *> CHP 10 List types on next line if 0 < NTYPES < 10 *> CSY 11 List types on next line if 0 < NTYPES < 11 *> CSR 11 List types on next line if 0 < NTYPES < 11 @@ -102,17 +103,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date November 2016 * *> \ingroup complex_lin * * ===================================================================== PROGRAM CCHKAA * -* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* November 2016 * * ===================================================================== * @@ -641,6 +642,33 @@ WRITE( NOUT, FMT = 9988 )PATH END IF * + ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN +* +* HA: Hermitian matrices, +* Aasen Algorithm +* + NTYPES = 10 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL CCHKHE_AASEN( 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 CDRVHE_AASEN( 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, 'HR' ) ) THEN * * HR: Hermitian indefinite matrices, @@ -867,7 +895,6 @@ ELSE WRITE( NOUT, FMT = 9989 )PATH END IF - * ELSE IF( LSAMEN( 2, C2, 'RQ' ) ) THEN * @@ -926,7 +953,6 @@ ELSE WRITE( NOUT, FMT = 9989 )PATH END IF - * ELSE IF( LSAMEN( 2, C2, 'LS' ) ) THEN * diff --git a/TESTING/LIN/cchkhe_aasen.f b/TESTING/LIN/cchkhe_aasen.f new file mode 100644 index 0000000..355dd25 --- /dev/null +++ b/TESTING/LIN/cchkhe_aasen.f @@ -0,0 +1,578 @@ +*> \brief \b CCHKHE_AASEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCHKHE_AASEN( 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 NN, NNB, NNS, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* REAL RWORK( * ) +* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CCHKHE_AASEN tests CHETRF_AASEN, -TRS_AASEN. +*> \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 (NBVAL) +*> 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 COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX 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 (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. +* +*> \date November 2016 +* +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CCHKHE_AASEN( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, + $ X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NNB, NNS, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + REAL RWORK( * ) + COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER ( ZERO = 0.0E+0 ) + COMPLEX CZERO + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) + INTEGER NTYPES + PARAMETER ( NTYPES = 10 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 9 ) +* .. +* .. Local Scalars .. + LOGICAL TRFCON, ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + 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 Functions .. + REAL DGET06, CLANHE + EXTERNAL DGET06, CLANHE +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, XLAENV, CERRHE, CGET04, + $ ZHECON, CHERFS, CHET01, CHETRF_AASEN, ZHETRI2, + $ CHETRS_AASEN, CLACPY, CLAIPD, CLARHS, CLATB4, + $ CLATMS, CPOT02, ZPOT03, ZPOT05 +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, IMAG, 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. +* +* +* Test path +* + PATH( 1: 1 ) = 'Complex precision' + PATH( 2: 3 ) = 'HA' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Complex precision' + MATPATH( 2: 3 ) = 'HE' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL CERRHE( 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 ) + IF( N .GT. NMAX ) THEN + NFAIL = NFAIL + 1 + WRITE(NOUT, 9995) 'M ', N, NMAX + GO TO 180 + END IF + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 + DO 170 IMAT = 1, 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 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Set up parameters with CLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, + $ ANORM, MODE, CNDNUM, DIST ) +* +* Generate a matrix with CLATMS. +* + SRNAMT = 'CLATMS' + CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from CLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', 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 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 ) = CZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = CZERO + 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 ) = CZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + IZERO = 1 + 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 ) = CZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate test matrix A. +* +* +* Set the imaginary part of the diagonals. +* + CALL CLAIPD( N, A, LDA+1, 0 ) +* +* 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 CLACPY( 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 = ( NB+1 )*LDA + SRNAMT = 'CHETRF_AASEN' + CALL CHETRF_AASEN( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + IF( IZERO.GT.0 ) THEN + J = 1 + K = IZERO + 100 CONTINUE + IF( J.EQ.K ) THEN + K = IWORK( J ) + ELSE IF( IWORK( J ).EQ.K ) THEN + K = J + END IF + IF( J.LT.K ) THEN + J = J + 1 + GO TO 100 + END IF + ELSE + K = 0 + END IF +* +* Check error code from CHETRF and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'CHETRF_AASEN', INFO, K, UPLO, + $ N, N, -1, -1, NB, IMAT, NFAIL, NERRS, + $ NOUT ) + END IF +* +* 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 CHET01_AASEN( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +* +* 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 +* +* Do only the condition estimate if INFO is not 0. +* + IF( TRFCON ) THEN + RCONDC = ZERO + GO TO 140 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 130 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 3 (Using TRS) +* 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 = 'CLARHS' + CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'CHETRS_AASEN' + LWORK = 3*N-2 + CALL CHETRS_AASEN( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Check error code from CHETRS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CHETRS_AASEN', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) + END IF +* + CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL CPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 120 K = 2, 2 + 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 + 1 +* +* End do for each value of NRHS in NSVAL. +* + 130 CONTINUE + 140 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 ) + 9995 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be <=', + $ I6 ) + RETURN +* +* End of CCHKHE_AASEN +* + END diff --git a/TESTING/LIN/cdrvhe_aasen.f b/TESTING/LIN/cdrvhe_aasen.f new file mode 100644 index 0000000..617f307 --- /dev/null +++ b/TESTING/LIN/cdrvhe_aasen.f @@ -0,0 +1,529 @@ +*> \brief \b CDRVHE_AASEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CDRVHE_AASEN( 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 RWORK( * ) +* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CDRVHE_AASEN tests the driver routine CHESV_AASEN. +*> \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 COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX 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 (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. +* +*> \date November 2016 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CDRVHE_AASEN( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NOUT, NRHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + REAL RWORK( * ) + COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 MATPATH, 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 CLANHE, SGET06 + EXTERNAL CLANHE, SGET06 +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, CERRVX, + $ CGET04, CLACPY, CLARHS, CLATB4, CLATMS, + $ CHESV_AASEN, CHET01_AASEN, CPOT02, + $ CHETRF_AASEN +* .. +* .. 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 CMPLX, 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. +* +* Test path +* + PATH( 1: 1 ) = 'Complex precision' + PATH( 2: 3 ) = 'HA' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Complex precision' + MATPATH( 2: 3 ) = 'HE' +* + 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 CERRVX( 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 = 1 +* + DO 170 IMAT = 1, 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 +* +* 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 CLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with CLATMS. +* + SRNAMT = 'CLATMS' + CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from CLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', 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 + IZERO = 1 + ELSE +* +* Set the first 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 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Compute the condition number for comparison with +* the value returned by CHESVX. +* + 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 = CLANHE( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* +c CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +c SRNAMT = 'CHETRF_AASEN' +c CALL CHETRF_AASEN( UPLO, N, AFAC, LDA, IWORK, +c $ WORK, LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* +c CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) +c LWORK = (N+NB+1)*(NB+3) +c SRNAMT = 'CHETRI2' +c CALL CHETRI2( UPLO, N, AINV, LDA, IWORK, WORK, +c $ LWORK, INFO ) +c AINVNM = CLANHE( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* +c IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN +c RCONDC = ONE +c ELSE +c RCONDC = ( ONE / ANORM ) / AINVNM +c END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'CLARHS' + CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test CHESV_AASEN --- +* + IF( IFACT.EQ.2 ) THEN + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using CHESV_AASEN. +* + SRNAMT = 'CHESV_AASEN ' + CALL CHESV_AASEN( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + IF( IZERO.GT.0 ) THEN + J = 1 + K = IZERO + 100 CONTINUE + IF( J.EQ.K ) THEN + K = IWORK( J ) + ELSE IF( IWORK( J ).EQ.K ) THEN + K = J + END IF + IF( J.LT.K ) THEN + J = J + 1 + GO TO 100 + END IF + ELSE + K = 0 + END IF +* +* Check error code from CHESV_AASEN . +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'CHESV_AASEN', 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 CHET01_AASEN( UPLO, N, A, LDA, AFAC, LDA, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +* Compute residual of the computed solution. +* + CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL CPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + CALL CGET04( 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 )'CHESV_AASEN ', + $ 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 ) + RETURN +* +* End of CDRVHE_AASEN +* + END diff --git a/TESTING/LIN/cerrvx.f b/TESTING/LIN/cerrvx.f index 52ca890..380dc69 100644 --- a/TESTING/LIN/cerrvx.f +++ b/TESTING/LIN/cerrvx.f @@ -93,7 +93,7 @@ $ CHESV, CHESV_ROOK, CHESVX, CHKXER, CHPSV, $ CHPSVX, CPBSV, CPBSVX, CPOSV, CPOSVX, CPPSV, $ CPPSVX, CPTSV, CPTSVX, CSPSV, CSPSVX, CSYSV, - $ CSYSV_ROOK, CSYSVX + $ CSYSV_AASEN, CSYSV_ROOK, CSYSVX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -632,6 +632,25 @@ $ RCOND, R1, R2, W, 3, RW, INFO ) CALL CHKXER( 'CHESVX', INFOT, NOUT, LERR, OK ) * + ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN +* +* CHESV_AASEN +* + SRNAMT = 'CHESV_AASEN' + INFOT = 1 + CALL CHESV_AASEN( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_AASEN', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHESV_AASEN( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_AASEN', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHESV_AASEN( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_AASEN', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHESV_AASEN( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_AASEN', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN * * CHESV_ROOK diff --git a/TESTING/LIN/chet01_aasen.f b/TESTING/LIN/chet01_aasen.f new file mode 100644 index 0000000..d87a610 --- /dev/null +++ b/TESTING/LIN/chet01_aasen.f @@ -0,0 +1,267 @@ +*> \brief \b CHET01_AASEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CHET01_AASEN( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, +* C, LDC, RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* COMPLEX RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), +* $ RWORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHET01_AASEN reconstructs a hermitian 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 +*> hermitian 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 COMPLEX array, dimension (LDA,N) +*> The original hermitian 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 COMPLEX 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 CHETRF. +*> \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 CHETRF. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is COMPLEX 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 COMPLEX array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is COMPLEX +*> 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. +* +*> \date November 2016 +* +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CHET01_AASEN( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- LAPACK test routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + REAL RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), + $ RWORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ) ) + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + REAL ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SLAMCH, CLANHE + EXTERNAL LSAME, SLAMCH, CLANHE +* .. +* .. External Subroutines .. + EXTERNAL CLASET, CLAVHE +* .. +* .. 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 = SLAMCH( 'Epsilon' ) + ANORM = CLANHE( '1', UPLO, N, A, LDA, RWORK ) +* +* Initialize C to the tridiagonal matrix T. +* + CALL CLASET( 'Full', N, N, CZERO, CZERO, C, LDC ) + CALL CLACPY( 'F', 1, N, AFAC( 1, 1 ), LDAFAC+1, C( 1, 1 ), LDC+1 ) + IF( N.GT.1 ) THEN + IF( LSAME( UPLO, 'U' ) ) THEN + CALL CLACPY( 'F', 1, N-1, AFAC( 1, 2 ), LDAFAC+1, C( 1, 2 ), + $ LDC+1 ) + CALL CLACPY( 'F', 1, N-1, AFAC( 1, 2 ), LDAFAC+1, C( 2, 1 ), + $ LDC+1 ) + CALL CLACGV( N-1, C( 2, 1 ), LDC+1 ) + ELSE + CALL CLACPY( 'F', 1, N-1, AFAC( 2, 1 ), LDAFAC+1, C( 1, 2 ), + $ LDC+1 ) + CALL CLACPY( 'F', 1, N-1, AFAC( 2, 1 ), LDAFAC+1, C( 2, 1 ), + $ LDC+1 ) + CALL CLACGV( N-1, C( 1, 2 ), LDC+1 ) + ENDIF + ENDIF +* +* Call CTRMM to form the product U' * D (or L * D ). +* + IF( LSAME( UPLO, 'U' ) ) THEN + CALL CTRMM( 'Left', UPLO, 'Conjugate transpose', 'Unit', N-1, + $ N, CONE, AFAC( 1, 2 ), LDAFAC, C( 2, 1 ), LDC ) + ELSE + CALL CTRMM( 'Left', UPLO, 'No transpose', 'Unit', N-1, N, + $ CONE, AFAC( 2, 1 ), LDAFAC, C( 2, 1 ), LDC ) + END IF +* +* Call CTRMM again to multiply by U (or L ). +* + IF( LSAME( UPLO, 'U' ) ) THEN + CALL CTRMM( 'Right', UPLO, 'No transpose', 'Unit', N, N-1, + $ CONE, AFAC( 1, 2 ), LDAFAC, C( 1, 2 ), LDC ) + ELSE + CALL CTRMM( 'Right', UPLO, 'Conjugate transpose', 'Unit', N, + $ N-1, CONE, AFAC( 2, 1 ), LDAFAC, C( 1, 2 ), LDC ) + END IF +* +* Apply hermitian pivots +* + DO J = N, 1, -1 + I = IPIV( J ) + IF( I.NE.J ) + $ CALL CSWAP( N, C( J, 1 ), LDC, C( I, 1 ), LDC ) + END DO + DO J = N, 1, -1 + I = IPIV( J ) + IF( I.NE.J ) + $ CALL CSWAP( N, C( 1, J ), 1, C( 1, I ), 1 ) + END DO +* +* +* Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO J = 1, N + DO I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + END IF +* +* Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = CLANHE( '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 CHET01_AASEN +* + END diff --git a/TESTING/LIN/dchkaa.f b/TESTING/LIN/dchkaa.f index 49478c9..9e7a14a 100644 --- a/TESTING/LIN/dchkaa.f +++ b/TESTING/LIN/dchkaa.f @@ -49,6 +49,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 +*> DSA 10 List types on next line if 0 < NTYPES < 10 *> DSY 10 List types on next line if 0 < NTYPES < 10 *> DSR 10 List types on next line if 0 < NTYPES < 10 *> DSP 10 List types on next line if 0 < NTYPES < 10 @@ -664,6 +665,34 @@ WRITE( NOUT, FMT = 9988 )PATH END IF * + ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN +* +* SY: symmetric indefinite matrices, +* with partial (Aasen's) pivoting algorithm +* + NTYPES = 10 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL DCHKSY_AASEN( 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 DDRVSY_AASEN( 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, 'SP' ) ) THEN * * SP: symmetric indefinite packed matrices, diff --git a/TESTING/LIN/dchksy_aasen.f b/TESTING/LIN/dchksy_aasen.f new file mode 100644 index 0000000..041ef75 --- /dev/null +++ b/TESTING/LIN/dchksy_aasen.f @@ -0,0 +1,577 @@ +*> \brief \b DCHKSY_AASEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DCHKSY_AASEN( 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 +*> +*> DCHKSY_AASEN tests DSYTRF_AASEN, -TRS_AASEN. +*> \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 (NBVAL) +*> 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. +* +*> \date November 2016 +* +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DCHKSY_AASEN( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, + $ X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NN, NNB, NNS, NMAX, 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, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 10 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 9 ) +* .. +* .. Local Scalars .. + LOGICAL TRFCON, ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + 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, RCONDC +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Functions .. + DOUBLE PRECISION DGET06, DLANSY + EXTERNAL DGET06, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, DERRSY, DGET04, DLACPY, + $ DLARHS, DLATB4, DLATMS, DPOT02, DPOT03, DPOT05, + $ DSYCON, DSYRFS, DSYT01, DSYTRF_AASEN, + $ DSYTRI2, DSYTRS_AASEN, 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. +* +* Test path +* + PATH( 1: 1 ) = 'Double precision' + PATH( 2: 3 ) = 'SA' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Double precision' + MATPATH( 2: 3 ) = 'SY' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL DERRSY( 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 ) + IF( N .GT. NMAX ) THEN + NFAIL = NFAIL + 1 + WRITE(NOUT, 9995) 'M ', N, NMAX + GO TO 180 + END IF + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 170 IMAT = 1, 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 +* +* 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( MATPATH, 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 + IZERO = 1 + 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. +* + SRNAMT = 'DSYTRF_AASEN' + LWORK = N*NB + N + CALL DSYTRF_AASEN( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + IF( IZERO.GT.0 ) THEN + J = 1 + K = IZERO + 100 CONTINUE + IF( J.EQ.K ) THEN + K = IWORK( J ) + ELSE IF( IWORK( J ).EQ.K ) THEN + K = J + END IF + IF( J.LT.K ) THEN + J = J + 1 + GO TO 100 + END IF + ELSE + K = 0 + END IF +* +* Check error code from DSYTRF and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'DSYTRF_AASEN', INFO, K, UPLO, + $ N, N, -1, -1, NB, IMAT, NFAIL, NERRS, + $ NOUT ) + END IF +* +* 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 DSYT01_AASEN( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +* +* 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 +* +* Do only the condition estimate if INFO is not 0. +* + IF( TRFCON ) THEN + RCONDC = ZERO + GO TO 140 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 130 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 3 ( Using TRS) +* 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( MATPATH, 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 = 'DSYTRS_AASEN' + LWORK = 3*N-2 + CALL DSYTRS_AASEN( UPLO, N, NRHS, AFAC, LDA, + $ IWORK, X, LDA, WORK, LWORK, + $ INFO ) +* +* Check error code from DSYTRS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DSYTRS_AASEN', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) + END IF +* + CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL DPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +* +* Print information about the tests that did not pass +* the threshold. +* + DO 120 K = 2, 2 + 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 + 1 +* +* End do for each value of NRHS in NSVAL. +* + 130 CONTINUE + 140 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 ) + 9995 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be <=', + $ I6 ) + RETURN +* +* End of DCHKSY_AASEN +* + END diff --git a/TESTING/LIN/ddrvsy_aasen.f b/TESTING/LIN/ddrvsy_aasen.f new file mode 100644 index 0000000..a3520cb --- /dev/null +++ b/TESTING/LIN/ddrvsy_aasen.f @@ -0,0 +1,517 @@ +*> \brief \b DDRVSY_AASEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DDRVSY_AASEN( 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 +*> +*> DDRVSY_AASEN tests the driver routine DSYSV_AASEN. +*> \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. +* +*> \date November 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DDRVSY_AASEN( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* +* .. 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( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 MATPATH, 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, DLANSY + EXTERNAL DGET06, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, DGET04, DLACPY, + $ DLARHS, DLASET, DLATB4, DLATMS, DPOT02, DPOT05, + $ DSYSV_AASEN, DSYT01_AASEN, DSYTRF_AASEN, 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. +* +* Test path +* + PATH( 1: 1 ) = 'Double precision' + PATH( 2: 3 ) = 'SA' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Double precision' + MATPATH( 2: 3 ) = 'SY' +* + 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 = 1 +* + DO 170 IMAT = 1, 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 +* +* 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( MATPATH, 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 + IZERO = 1 + 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 for comparison with +* the value returned by DSYSVX. +* + 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 = DLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* +c CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +c CALL DSYTRF( UPLO, N, AFAC, LDA, IWORK, WORK, +c $ LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* +c CALL DLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) +c LWORK = (N+NB+1)*(NB+3) +c SRNAMT = 'DSYTRI2' +c CALL DSYTRI2( UPLO, N, AINV, LDA, IWORK, WORK, +c $ LWORK, INFO ) +c AINVNM = DLANSY( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* +c IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN +c RCONDC = ONE +c ELSE +c RCONDC = ( ONE / ANORM ) / AINVNM +c END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'DLARHS' + CALL DLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test DSYSV_AASEN --- +* + 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 DSYSV_AASEN. +* + SRNAMT = 'DSYSV_AASEN' + CALL DSYSV_AASEN( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + IF( IZERO.GT.0 ) THEN + J = 1 + K = IZERO + 100 CONTINUE + IF( J.EQ.K ) THEN + K = IWORK( J ) + ELSE IF( IWORK( J ).EQ.K ) THEN + K = J + END IF + IF( J.LT.K ) THEN + J = J + 1 + GO TO 100 + END IF + ELSE + K = 0 + END IF +* +* Check error code from DSYSV_AASEN . +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'DSYSV_AASEN ', 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 DSYT01_AASEN( 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 DPOT02( 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 )'DSYSV_AASEN ', + $ 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 ) + RETURN +* +* End of DDRVSY_AASEN +* + END diff --git a/TESTING/LIN/derrvx.f b/TESTING/LIN/derrvx.f index 36eb8d6..2affbe2 100644 --- a/TESTING/LIN/derrvx.f +++ b/TESTING/LIN/derrvx.f @@ -91,7 +91,7 @@ EXTERNAL CHKXER, DGBSV, DGBSVX, DGESV, DGESVX, DGTSV, $ DGTSVX, DPBSV, DPBSVX, DPOSV, DPOSVX, DPPSV, $ DPPSVX, DPTSV, DPTSVX, DSPSV, DSPSVX, DSYSV, - $ DSYSV_ROOK, DSYSVX + $ DSYSV_AASEN, DSYSV_ROOK, DSYSVX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -627,6 +627,25 @@ $ RCOND, R1, R2, W, 3, IW, INFO ) CALL CHKXER( 'DSYSVX', INFOT, NOUT, LERR, OK ) * + ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN +* +* DSYSV_AASEN +* + SRNAMT = 'DSYSV_AASEN' + INFOT = 1 + CALL DSYSV_AASEN( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_AASEN', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYSV_AASEN( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_AASEN', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYSV_AASEN( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_AASEN', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYSV_AASEN( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_AASEN', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * * DSYSV_ROOK diff --git a/TESTING/LIN/dsyt01_aasen.f b/TESTING/LIN/dsyt01_aasen.f new file mode 100644 index 0000000..f375677 --- /dev/null +++ b/TESTING/LIN/dsyt01_aasen.f @@ -0,0 +1,263 @@ +*> \brief \b DSYT01 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSYT01( 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 +*> +*> DSYT01 reconstructs a 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 +*> 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 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 DSYTRF. +*> \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 DSYTRF. +*> \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. +* +*> \date November 2016 +* +* @precisions fortran d -> s +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DSYT01_AASEN( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* +* .. 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, J + DOUBLE PRECISION ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL LSAME, DLAMCH, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL DLASET, DLAVSY +* .. +* .. 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 = DLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Initialize C to the tridiagonal matrix T. +* + CALL DLASET( 'Full', N, N, ZERO, ZERO, C, LDC ) + CALL DLACPY( 'F', 1, N, AFAC( 1, 1 ), LDAFAC+1, C( 1, 1 ), LDC+1 ) + IF( N.GT.1 ) THEN + IF( LSAME( UPLO, 'U' ) ) THEN + CALL DLACPY( 'F', 1, N-1, AFAC( 1, 2 ), LDAFAC+1, C( 1, 2 ), + $ LDC+1 ) + CALL DLACPY( 'F', 1, N-1, AFAC( 1, 2 ), LDAFAC+1, C( 2, 1 ), + $ LDC+1 ) + ELSE + CALL DLACPY( 'F', 1, N-1, AFAC( 2, 1 ), LDAFAC+1, C( 1, 2 ), + $ LDC+1 ) + CALL DLACPY( 'F', 1, N-1, AFAC( 2, 1 ), LDAFAC+1, C( 2, 1 ), + $ LDC+1 ) + ENDIF + ENDIF +* +* Call DTRMM to form the product U' * D (or L * D ). +* + IF( LSAME( UPLO, 'U' ) ) THEN + CALL DTRMM( 'Left', UPLO, 'Transpose', 'Unit', N-1, N, + $ ONE, AFAC( 1, 2 ), LDAFAC, C( 2, 1 ), LDC ) + ELSE + CALL DTRMM( 'Left', UPLO, 'No transpose', 'Unit', N-1, N, + $ ONE, AFAC( 2, 1 ), LDAFAC, C( 2, 1 ), LDC ) + END IF +* +* Call DTRMM again to multiply by U (or L ). +* + IF( LSAME( UPLO, 'U' ) ) THEN + CALL DTRMM( 'Right', UPLO, 'No transpose', 'Unit', N, N-1, + $ ONE, AFAC( 1, 2 ), LDAFAC, C( 1, 2 ), LDC ) + ELSE + CALL DTRMM( 'Right', UPLO, 'Transpose', 'Unit', N, N-1, + $ ONE, AFAC( 2, 1 ), LDAFAC, C( 1, 2 ), LDC ) + END IF +* +* Apply symmetric pivots +* + DO J = N, 1, -1 + I = IPIV( J ) + IF( I.NE.J ) + $ CALL DSWAP( N, C( J, 1 ), LDC, C( I, 1 ), LDC ) + END DO + DO J = N, 1, -1 + I = IPIV( J ) + IF( I.NE.J ) + $ CALL DSWAP( N, C( 1, J ), 1, C( 1, I ), 1 ) + END DO +* +* +* Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO J = 1, N + DO I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + END IF +* +* Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = DLANSY( '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 DSYT01 +* + END diff --git a/TESTING/LIN/schkaa.f b/TESTING/LIN/schkaa.f index 821710c..a6bfa10 100644 --- a/TESTING/LIN/schkaa.f +++ b/TESTING/LIN/schkaa.f @@ -664,6 +664,33 @@ WRITE( NOUT, FMT = 9988 )PATH END IF * + ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN +* +* SY: symmetric indefinite matrices, +* with partial (Aasen's) pivoting algorithm +* + NTYPES = 10 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL SCHKSY_AASEN( 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 SDRVSY_AASEN( 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, 'SP' ) ) THEN * * SP: symmetric indefinite packed matrices, diff --git a/TESTING/LIN/schksy_aasen.f b/TESTING/LIN/schksy_aasen.f new file mode 100644 index 0000000..659e3fd --- /dev/null +++ b/TESTING/LIN/schksy_aasen.f @@ -0,0 +1,578 @@ +*> \brief \b SCHKSY_AASEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SCHKSY_AAEN( 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 +*> +*> SCHKSY_AASEN tests SSYTRF_AASEN, -TRS_AASEN. +*> \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 (NBVAL) +*> 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. +* +*> \date November 2016 +* +* +*> \ingroup real_lin +* +* ===================================================================== + SUBROUTINE SCHKSY_AASEN( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, + $ X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NN, NNB, NNS, NMAX, 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 + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + 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, RCONDC +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) +* .. +* .. External Functions .. + REAL DGET06, SLANSY + EXTERNAL DGET06, SLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, SERRSY, SGET04, SLACPY, + $ SLARHS, SLATB4, SLATMS, SPOT02, DPOT03, DPOT05, + $ DSYCON, SSYRFS, SSYT01_AASEN, SSYTRF_AASEN, + $ DSYTRI2, SSYTRS_AASEN, 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. +* +* +* Test path +* + PATH( 1: 1 ) = 'Single precision' + PATH( 2: 3 ) = 'SA' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Single precision' + MATPATH( 2: 3 ) = 'SY' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL SERRSY( 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 ) + IF( N .GT. NMAX ) THEN + NFAIL = NFAIL + 1 + WRITE(NOUT, 9995) 'M ', N, NMAX + GO TO 180 + END IF + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 170 IMAT = 1, 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 +* +* 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( MATPATH, 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 + IZERO = 1 + 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. +* + SRNAMT = 'SSYTRF_AASEN' + LWORK = N*NB + N + CALL SSYTRF_AASEN( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + IF( IZERO.GT.0 ) THEN + J = 1 + K = IZERO + 100 CONTINUE + IF( J.EQ.K ) THEN + K = IWORK( J ) + ELSE IF( IWORK( J ).EQ.K ) THEN + K = J + END IF + IF( J.LT.K ) THEN + J = J + 1 + GO TO 100 + END IF + ELSE + K = 0 + END IF +* +* Check error code from SSYTRF and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'SSYTRF_AASEN', INFO, K, UPLO, + $ N, N, -1, -1, NB, IMAT, NFAIL, NERRS, + $ NOUT ) + END IF +* +* 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 SSYT01_AASEN( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +* +* 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 +* +* Do only the condition estimate if INFO is not 0. +* + IF( TRFCON ) THEN + RCONDC = ZERO + GO TO 140 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 130 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 3 ( Using TRS) +* 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( MATPATH, 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 = 'SSYTRS_AASEN' + LWORK = 3*N-2 + CALL SSYTRS_AASEN( UPLO, N, NRHS, AFAC, LDA, + $ IWORK, X, LDA, WORK, LWORK, + $ INFO ) +* +* Check error code from SSYTRS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SSYTRS_AASEN', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) + END IF +* + CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +* +* Print information about the tests that did not pass +* the threshold. +* + DO 120 K = 2, 2 + 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 + 1 +* +* End do for each value of NRHS in NSVAL. +* + 130 CONTINUE + 140 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 ) + 9995 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be <=', + $ I6 ) + RETURN +* +* End of SCHKSY_AASEN +* + END diff --git a/TESTING/LIN/sdrvsy_aasen.f b/TESTING/LIN/sdrvsy_aasen.f new file mode 100644 index 0000000..afa5dc4 --- /dev/null +++ b/TESTING/LIN/sdrvsy_aasen.f @@ -0,0 +1,517 @@ +*> \brief \b SDRVSY_AASEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SDRVSY_AASEN( 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 +*> +*> SDRVSY_AASEN tests the driver routine SSYSV_AASEN. +*> \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. +* +*> \date November 2016 +* +*> \ingroup real_lin +* +* ===================================================================== + SUBROUTINE SDRVSY_AASEN( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* +* .. 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( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 MATPATH, 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 DGET06, SLANSY + EXTERNAL DGET06, SLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, SERRVX, SGET04, SLACPY, + $ SLARHS, SLASET, SLATB4, SLATMS, SPOT02, DPOT05, + $ SSYSV_AASEN, SSYT01_AASEN, SSYTRF_AASEN, 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. +* +* Test path +* + PATH( 1: 1 ) = 'Single precision' + PATH( 2: 3 ) = 'SA' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Single precision' + MATPATH( 2: 3 ) = 'SY' +* + 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 = 1 +* + DO 170 IMAT = 1, 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 +* +* 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( MATPATH, 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 + IZERO = 1 + 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 for comparison with +* the value returned by SSYSVX. +* + 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 = SLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* +c CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +c CALL SSYTRF( UPLO, N, AFAC, LDA, IWORK, WORK, +c $ LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* +c CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) +c LWORK = (N+NB+1)*(NB+3) +c SRNAMT = 'DSYTRI2' +c CALL DSYTRI2( UPLO, N, AINV, LDA, IWORK, WORK, +c $ LWORK, INFO ) +c AINVNM = SLANSY( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* +c IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN +c RCONDC = ONE +c ELSE +c RCONDC = ( ONE / ANORM ) / AINVNM +c END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'SLARHS' + CALL SLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test SSYSV_AASEN --- +* + 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 SSYSV_AASEN. +* + SRNAMT = 'SSYSV_AASEN' + CALL SSYSV_AASEN( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + IF( IZERO.GT.0 ) THEN + J = 1 + K = IZERO + 100 CONTINUE + IF( J.EQ.K ) THEN + K = IWORK( J ) + ELSE IF( IWORK( J ).EQ.K ) THEN + K = J + END IF + IF( J.LT.K ) THEN + J = J + 1 + GO TO 100 + END IF + ELSE + K = 0 + END IF +* +* Check error code from SSYSV_AASEN . +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'SSYSV_AASEN ', 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 SSYT01_AASEN( 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 SPOT02( 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 )'SSYSV_AASEN ', + $ 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 ) + RETURN +* +* End of SDRVSY_AASEN +* + END diff --git a/TESTING/LIN/serrvx.f b/TESTING/LIN/serrvx.f index 7d999c4..41334f5 100644 --- a/TESTING/LIN/serrvx.f +++ b/TESTING/LIN/serrvx.f @@ -91,7 +91,7 @@ EXTERNAL CHKXER, SGBSV, SGBSVX, SGESV, SGESVX, SGTSV, $ SGTSVX, SPBSV, SPBSVX, SPOSV, SPOSVX, SPPSV, $ SPPSVX, SPTSV, SPTSVX, SSPSV, SSPSVX, SSYSV, - $ SSYSV_ROOK, SSYSVX + $ SSYSV_AASEN, SSYSV_ROOK, SSYSVX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -627,6 +627,24 @@ $ RCOND, R1, R2, W, 3, IW, INFO ) CALL CHKXER( 'SSYSVX', INFOT, NOUT, LERR, OK ) * + ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN +* +* SSYSV_AASEN +* + SRNAMT = 'SSYSV_AASEN' + INFOT = 1 + CALL SSYSV_AASEN( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_AASEN', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYSV_AASEN( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_AASEN', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYSV_AASEN( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_AASEN', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYSV_AASEN( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_AASEN', INFOT, NOUT, LERR, OK ) +* ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * * SSYSV_ROOK diff --git a/TESTING/LIN/ssyt01_aasen.f b/TESTING/LIN/ssyt01_aasen.f new file mode 100644 index 0000000..0116393 --- /dev/null +++ b/TESTING/LIN/ssyt01_aasen.f @@ -0,0 +1,262 @@ +*> \brief \b SSYT01_AASEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSYT01_AASEN( 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 +*> +*> SSYT01_AASEN reconstructs a 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 +*> 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 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 SSYTRF. +*> \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 SSYTRF. +*> \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. +* +*> \date November 2016 +* +* +*> \ingroup real_lin +* +* ===================================================================== + SUBROUTINE SSYT01_AASEN( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- LAPACK test routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* +* .. 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, J + REAL ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SLAMCH, SLANSY + EXTERNAL LSAME, SLAMCH, SLANSY +* .. +* .. External Subroutines .. + EXTERNAL SLASET, SLAVSY +* .. +* .. 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 = SLAMCH( 'Epsilon' ) + ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Initialize C to the tridiagonal matrix T. +* + CALL SLASET( 'Full', N, N, ZERO, ZERO, C, LDC ) + CALL SLACPY( 'F', 1, N, AFAC( 1, 1 ), LDAFAC+1, C( 1, 1 ), LDC+1 ) + IF( N.GT.1 ) THEN + IF( LSAME( UPLO, 'U' ) ) THEN + CALL SLACPY( 'F', 1, N-1, AFAC( 1, 2 ), LDAFAC+1, C( 1, 2 ), + $ LDC+1 ) + CALL SLACPY( 'F', 1, N-1, AFAC( 1, 2 ), LDAFAC+1, C( 2, 1 ), + $ LDC+1 ) + ELSE + CALL SLACPY( 'F', 1, N-1, AFAC( 2, 1 ), LDAFAC+1, C( 1, 2 ), + $ LDC+1 ) + CALL SLACPY( 'F', 1, N-1, AFAC( 2, 1 ), LDAFAC+1, C( 2, 1 ), + $ LDC+1 ) + ENDIF + ENDIF +* +* Call STRMM to form the product U' * D (or L * D ). +* + IF( LSAME( UPLO, 'U' ) ) THEN + CALL STRMM( 'Left', UPLO, 'Transpose', 'Unit', N-1, N, + $ ONE, AFAC( 1, 2 ), LDAFAC, C( 2, 1 ), LDC ) + ELSE + CALL STRMM( 'Left', UPLO, 'No transpose', 'Unit', N-1, N, + $ ONE, AFAC( 2, 1 ), LDAFAC, C( 2, 1 ), LDC ) + END IF +* +* Call STRMM again to multiply by U (or L ). +* + IF( LSAME( UPLO, 'U' ) ) THEN + CALL STRMM( 'Right', UPLO, 'No transpose', 'Unit', N, N-1, + $ ONE, AFAC( 1, 2 ), LDAFAC, C( 1, 2 ), LDC ) + ELSE + CALL STRMM( 'Right', UPLO, 'Transpose', 'Unit', N, N-1, + $ ONE, AFAC( 2, 1 ), LDAFAC, C( 1, 2 ), LDC ) + END IF +* +* Apply symmetric pivots +* + DO J = N, 1, -1 + I = IPIV( J ) + IF( I.NE.J ) + $ CALL SSWAP( N, C( J, 1 ), LDC, C( I, 1 ), LDC ) + END DO + DO J = N, 1, -1 + I = IPIV( J ) + IF( I.NE.J ) + $ CALL SSWAP( N, C( 1, J ), 1, C( 1, I ), 1 ) + END DO +* +* +* Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO J = 1, N + DO I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + END IF +* +* Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = SLANSY( '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 SSYT01_AASEN +* + END diff --git a/TESTING/LIN/zchkaa.f b/TESTING/LIN/zchkaa.f index 9212afc..90b98a2 100644 --- a/TESTING/LIN/zchkaa.f +++ b/TESTING/LIN/zchkaa.f @@ -50,6 +50,7 @@ *> ZPB 8 List types on next line if 0 < NTYPES < 8 *> ZPT 12 List types on next line if 0 < NTYPES < 12 *> ZHE 10 List types on next line if 0 < NTYPES < 10 +*> ZHA 10 List types on next line if 0 < NTYPES < 10 *> ZHR 10 List types on next line if 0 < NTYPES < 10 *> ZHP 10 List types on next line if 0 < NTYPES < 10 *> ZSY 11 List types on next line if 0 < NTYPES < 11 @@ -102,17 +103,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date November 2016 * *> \ingroup complex16_lin * * ===================================================================== PROGRAM ZCHKAA * -* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* November 2016 * * ===================================================================== * @@ -639,6 +640,33 @@ WRITE( NOUT, FMT = 9988 )PATH END IF * + ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN +* +* HA: Hermitian indefinite matrices, +* with partial (Aasen's) pivoting algorithm +* + NTYPES = 10 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL ZCHKHE_AASEN( 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 ZDRVHE_AASEN( 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, 'HR' ) ) THEN * * HR: Hermitian indefinite matrices, diff --git a/TESTING/LIN/zchkhe_aasen.f b/TESTING/LIN/zchkhe_aasen.f new file mode 100644 index 0000000..1ebe5ef --- /dev/null +++ b/TESTING/LIN/zchkhe_aasen.f @@ -0,0 +1,579 @@ +*> \brief \b ZCHKHE_AASEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCHKHE_AASEN( 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 NN, NNB, NNS, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZCHKHE_AASEN tests ZHETRF_AASEN, -TRS_AASEN. +*> \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 (NBVAL) +*> 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 COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 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 (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. +* +*> \date November 2016 +* +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZCHKHE_AASEN( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, + $ X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* + IMPLICIT NONE +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NNB, NNS, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) + INTEGER NTYPES + PARAMETER ( NTYPES = 10 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 9 ) +* .. +* .. Local Scalars .. + LOGICAL TRFCON, ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + 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 Functions .. + DOUBLE PRECISION DGET06, ZLANHE + EXTERNAL DGET06, ZLANHE +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, XLAENV, ZERRHE, ZGET04, + $ ZHECON, ZHERFS, ZHET01, ZHETRF_AASEN, ZHETRI2, + $ ZHETRS_AASEN, ZLACPY, ZLAIPD, ZLARHS, ZLATB4, + $ ZLATMS, ZPOT02, ZPOT03, ZPOT05 +* .. +* .. 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. +* +* Test path +* + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'HA' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Zomplex precision' + MATPATH( 2: 3 ) = 'HE' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL ZERRHE( 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 ) + IF( N .GT. NMAX ) THEN + NFAIL = NFAIL + 1 + WRITE(NOUT, 9995) 'M ', N, NMAX + GO TO 180 + END IF + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 + DO 170 IMAT = 1, 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 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Set up parameters with ZLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, + $ ANORM, MODE, CNDNUM, DIST ) +* +* Generate a matrix with ZLATMS. +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from ZLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', 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 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 ) = CZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = CZERO + 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 ) = CZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + IZERO = 1 + 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 ) = CZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate test matrix A. +* +* +* Set the imaginary part of the diagonals. +* + CALL ZLAIPD( N, A, LDA+1, 0 ) +* +* 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 ZLACPY( 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 = ( NB+1 )*LDA + SRNAMT = 'ZHETRF_AASEN' + CALL ZHETRF_AASEN( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + IF( IZERO.GT.0 ) THEN + J = 1 + K = IZERO + 100 CONTINUE + IF( J.EQ.K ) THEN + K = IWORK( J ) + ELSE IF( IWORK( J ).EQ.K ) THEN + K = J + END IF + IF( J.LT.K ) THEN + J = J + 1 + GO TO 100 + END IF + ELSE + K = 0 + END IF +* +* Check error code from ZHETRF and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'ZHETRF_AASEN', INFO, K, UPLO, + $ N, N, -1, -1, NB, IMAT, NFAIL, NERRS, + $ NOUT ) + END IF +* +* 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 ZHET01_AASEN( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +* +* 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 +* +* Do only the condition estimate if INFO is not 0. +* + IF( TRFCON ) THEN + RCONDC = ZERO + GO TO 140 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 130 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 3 (Using TRS) +* 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 = 'ZLARHS' + CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'ZHETRS_AASEN' + LWORK = 3*N-2 + CALL ZHETRS_AASEN( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Check error code from ZHETRS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZHETRS', INFO, 0, UPLO, N, + $ N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) + END IF +* + CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 120 K = 2, 2 + 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 + 1 +* +* End do for each value of NRHS in NSVAL. +* + 130 CONTINUE + 140 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 ) +c 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, +c $ ', test(', I2, ') =', G12.5 ) + 9995 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be <=', + $ I6 ) + RETURN +* +* End of ZCHKHE_AASEN +* + END diff --git a/TESTING/LIN/zdrvhe_aasen.f b/TESTING/LIN/zdrvhe_aasen.f new file mode 100644 index 0000000..0170873 --- /dev/null +++ b/TESTING/LIN/zdrvhe_aasen.f @@ -0,0 +1,525 @@ +*> \brief \b ZDRVHE_AASEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZDRVHE_AASEN( 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 RWORK( * ) +* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDRVHE_AASEN tests the driver routine ZHESV_AASEN. +*> \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 COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 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 (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. +* +*> \date November 2016 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZDRVHE_AASEN( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NOUT, NRHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 MATPATH, 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, ZLANHE + EXTERNAL DGET06, ZLANHE +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, ZERRVX, ZGET04, + $ ZHESV_AASEN, ZHET01_AASEN, ZHETRF_AASEN, + $ ZHETRI2, ZLACPY, ZLAIPD, ZLARHS, ZLATB4, ZLATMS, + $ ZPOT02 +* .. +* .. 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 DCMPLX, 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. +* +* Test path +* + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'HA' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Zomplex precision' + MATPATH( 2: 3 ) = 'HE' +* + 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 ZERRVX( 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 = 1 +* + DO 170 IMAT = 1, 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 +* +* 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 ZLATB4 and generate a test matrix +* with ZLATMS. +* + CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from ZLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', 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 + IZERO = 1 + 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 +* +* Set the imaginary part of the diagonals. +* + CALL ZLAIPD( N, A, LDA+1, 0 ) +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Compute the condition number for comparison with +* the value returned by ZHESVX. +* + 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 = ZLANHE( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* +c CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +c CALL ZHETRF( UPLO, N, AFAC, LDA, IWORK, WORK, +c $ LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* +c CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) +c LWORK = (N+NB+1)*(NB+3) +c CALL ZHETRI2( UPLO, N, AINV, LDA, IWORK, WORK, +c $ LWORK, INFO ) +c AINVNM = ZLANHE( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* +c IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN +c RCONDC = ONE +c ELSE +c RCONDC = ( ONE / ANORM ) / AINVNM +c END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'ZLARHS' + CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test ZHESV_AASEN --- +* + IF( IFACT.EQ.2 ) THEN + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using ZHESV. +* + SRNAMT = 'ZHESV_AASEN ' + CALL ZHESV_AASEN( UPLO, N, NRHS, AFAC, LDA, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + IF( IZERO.GT.0 ) THEN + J = 1 + K = IZERO + 100 CONTINUE + IF( J.EQ.K ) THEN + K = IWORK( J ) + ELSE IF( IWORK( J ).EQ.K ) THEN + K = J + END IF + IF( J.LT.K ) THEN + J = J + 1 + GO TO 100 + END IF + ELSE + K = 0 + END IF +* +* Check error code from ZHESV . +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'ZHESV_AASEN', 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 ZHET01_AASEN( UPLO, N, A, LDA, AFAC, LDA, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +* Compute residual of the computed solution. +* + CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + CALL ZGET04( 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 )'ZHESV_AASEN', 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 ) + RETURN +* +* End of ZDRVHE_AASEN +* + END diff --git a/TESTING/LIN/zerrvx.f b/TESTING/LIN/zerrvx.f index 11a35aa..1bb2d22 100644 --- a/TESTING/LIN/zerrvx.f +++ b/TESTING/LIN/zerrvx.f @@ -93,7 +93,7 @@ $ ZGTSVX, ZHESV, ZHESV_ROOK, ZHESVX, ZHPSV, $ ZHPSVX, ZPBSV, ZPBSVX, ZPOSV, ZPOSVX, ZPPSV, $ ZPPSVX, ZPTSV, ZPTSVX, ZSPSV, ZSPSVX, ZSYSV, - $ ZSYSV_ROOK, ZSYSVX + $ ZSYSV_AASEN, ZSYSV_ROOK, ZSYSVX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -634,6 +634,25 @@ $ RCOND, R1, R2, W, 3, RW, INFO ) CALL CHKXER( 'ZHESVX', INFOT, NOUT, LERR, OK ) * + ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN +* +* ZHESV_AASEN +* + SRNAMT = 'ZHESV_AASEN' + INFOT = 1 + CALL ZHESV_AASEN( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_AASEN', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHESV_AASEN( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_AASEN', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHESV_AASEN( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_AASEN', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHESV_AASEN( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_AASEN', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN * * ZHESV_ROOK diff --git a/TESTING/LIN/zhet01_aasen.f b/TESTING/LIN/zhet01_aasen.f new file mode 100644 index 0000000..89b8799 --- /dev/null +++ b/TESTING/LIN/zhet01_aasen.f @@ -0,0 +1,267 @@ +*> \brief \b ZHET01_AASEN +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHET01_AASEN( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, +* C, LDC, RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* COMPLEX*16 RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), +* $ RWORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHET01_AASEN reconstructs a hermitian 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 +*> hermitian 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 COMPLEX*16 array, dimension (LDA,N) +*> The original hermitian 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 COMPLEX*16 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 ZHETRF. +*> \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 ZHETRF. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is COMPLEX*16 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 COMPLEX*16 array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> RESID is COMPLEX*16 +*> 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. +* +*> \date November 2016 +* +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZHET01_AASEN( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- LAPACK test routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), + $ RWORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, ZLANHE + EXTERNAL LSAME, DLAMCH, ZLANHE +* .. +* .. External Subroutines .. + EXTERNAL ZLASET, ZLAVHE +* .. +* .. 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 = ZLANHE( '1', UPLO, N, A, LDA, RWORK ) +* +* Initialize C to the tridiagonal matrix T. +* + CALL ZLASET( 'Full', N, N, CZERO, CZERO, C, LDC ) + CALL ZLACPY( 'F', 1, N, AFAC( 1, 1 ), LDAFAC+1, C( 1, 1 ), LDC+1 ) + IF( N.GT.1 ) THEN + IF( LSAME( UPLO, 'U' ) ) THEN + CALL ZLACPY( 'F', 1, N-1, AFAC( 1, 2 ), LDAFAC+1, C( 1, 2 ), + $ LDC+1 ) + CALL ZLACPY( 'F', 1, N-1, AFAC( 1, 2 ), LDAFAC+1, C( 2, 1 ), + $ LDC+1 ) + CALL ZLACGV( N-1, C( 2, 1 ), LDC+1 ) + ELSE + CALL ZLACPY( 'F', 1, N-1, AFAC( 2, 1 ), LDAFAC+1, C( 1, 2 ), + $ LDC+1 ) + CALL ZLACPY( 'F', 1, N-1, AFAC( 2, 1 ), LDAFAC+1, C( 2, 1 ), + $ LDC+1 ) + CALL ZLACGV( N-1, C( 1, 2 ), LDC+1 ) + ENDIF + ENDIF +* +* Call ZTRMM to form the product U' * D (or L * D ). +* + IF( LSAME( UPLO, 'U' ) ) THEN + CALL ZTRMM( 'Left', UPLO, 'Conjugate transpose', 'Unit', N-1, + $ N, CONE, AFAC( 1, 2 ), LDAFAC, C( 2, 1 ), LDC ) + ELSE + CALL ZTRMM( 'Left', UPLO, 'No transpose', 'Unit', N-1, N, + $ CONE, AFAC( 2, 1 ), LDAFAC, C( 2, 1 ), LDC ) + END IF +* +* Call ZTRMM again to multiply by U (or L ). +* + IF( LSAME( UPLO, 'U' ) ) THEN + CALL ZTRMM( 'Right', UPLO, 'No transpose', 'Unit', N, N-1, + $ CONE, AFAC( 1, 2 ), LDAFAC, C( 1, 2 ), LDC ) + ELSE + CALL ZTRMM( 'Right', UPLO, 'Conjugate transpose', 'Unit', N, + $ N-1, CONE, AFAC( 2, 1 ), LDAFAC, C( 1, 2 ), LDC ) + END IF +* +* Apply hermitian pivots +* + DO J = N, 1, -1 + I = IPIV( J ) + IF( I.NE.J ) + $ CALL ZSWAP( N, C( J, 1 ), LDC, C( I, 1 ), LDC ) + END DO + DO J = N, 1, -1 + I = IPIV( J ) + IF( I.NE.J ) + $ CALL ZSWAP( N, C( 1, J ), 1, C( 1, I ), 1 ) + END DO +* +* +* Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO J = 1, N + DO I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + END IF +* +* Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = ZLANHE( '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 ZHET01_AASEN +* + END diff --git a/TESTING/ctest.in b/TESTING/ctest.in index e465493..95a7b0d 100644 --- a/TESTING/ctest.in +++ b/TESTING/ctest.in @@ -24,6 +24,7 @@ CPB 8 List types on next line if 0 < NTYPES < 8 CPT 12 List types on next line if 0 < NTYPES < 12 CHE 10 List types on next line if 0 < NTYPES < 10 CHR 10 List types on next line if 0 < NTYPES < 10 +CHA 10 List types on next line if 0 < NTYPES < 10 CHP 10 List types on next line if 0 < NTYPES < 10 CSY 11 List types on next line if 0 < NTYPES < 11 CSR 11 List types on next line if 0 < NTYPES < 11 diff --git a/TESTING/dtest.in b/TESTING/dtest.in index 467a01c..a2343db 100644 --- a/TESTING/dtest.in +++ b/TESTING/dtest.in @@ -22,6 +22,7 @@ DPS 9 List types on next line if 0 < NTYPES < 9 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 +DSA 10 List types on next line if 0 < NTYPES < 10 DSY 10 List types on next line if 0 < NTYPES < 10 DSR 10 List types on next line if 0 < NTYPES < 10 DSP 10 List types on next line if 0 < NTYPES < 10 diff --git a/TESTING/stest.in b/TESTING/stest.in index bd7f884..865adfb 100644 --- a/TESTING/stest.in +++ b/TESTING/stest.in @@ -22,6 +22,7 @@ SPS 9 List types on next line if 0 < NTYPES < 9 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 +SSA 10 List types on next line if 0 < NTYPES < 10 SSY 10 List types on next line if 0 < NTYPES < 10 SSR 10 List types on next line if 0 < NTYPES < 10 SSP 10 List types on next line if 0 < NTYPES < 10 diff --git a/TESTING/ztest.in b/TESTING/ztest.in index 1060351..72a5135 100644 --- a/TESTING/ztest.in +++ b/TESTING/ztest.in @@ -22,6 +22,7 @@ ZPS 9 List types on next line if 0 < NTYPES < 9 ZPP 9 List types on next line if 0 < NTYPES < 9 ZPB 8 List types on next line if 0 < NTYPES < 8 ZPT 12 List types on next line if 0 < NTYPES < 12 +ZHA 10 List types on next line if 0 < NTYPES < 10 ZHE 10 List types on next line if 0 < NTYPES < 10 ZHR 10 List types on next line if 0 < NTYPES < 10 ZHP 10 List types on next line if 0 < NTYPES < 10 -- 2.7.4